| Anonymous | Login | Signup for a new account | 2013-05-22 05:17 CEST |  |
| Main | My View | View Issues | Change Log | Roadmap |
| View Issue Details [ Jump to Notes ] | [ Issue History ] [ Print ] | |||||||||||
| ID | Project | Category | View Status | Date Submitted | Last Update | |||||||
| 0005925 | OCaml | OCaml general | public | 2013-02-18 10:08 | 2013-04-17 11:12 | |||||||
| Reporter | smimram | |||||||||||
| Assigned To | gasche | |||||||||||
| Priority | normal | Severity | crash | Reproducibility | always | |||||||
| Status | resolved | Resolution | suspended | |||||||||
| Platform | amd64 | OS | Linux | OS Version | 3.2.0 | |||||||
| Product Version | 4.00.1 | |||||||||||
| Target Version | Fixed in Version | |||||||||||
| Summary | 0005925: Stack overflow in compiler | |||||||||||
| Description | Compiling the attached file with ocamlopt or ocamlopt.opt results in Fatal error: exception Stack_overflow Obviously this code was generated... It is not incredibly long (less than 4000 lines), but contains quite large expressions. Excepting by removing a few random lines, all my attempts to get a significantly simpler example have failed, sorry. | |||||||||||
| Tags | No tags attached. | |||||||||||
| Attached Files |  br.ml [^] (447,547 bytes) 2013-02-18 10:08 long-bytecode.diff [^] (8,692 bytes) 2013-02-22 18:51 [Show Content] [Hide Content]diff -Naur orig/bytecomp/bytelink.ml long-bytecode/bytecomp/bytelink.ml
--- orig/bytecomp/bytelink.ml 2013-02-22 18:10:28.000000000 +0100
+++ long-bytecode/bytecomp/bytelink.ml 2013-02-19 21:50:56.000000000 +0100
@@ -195,14 +195,14 @@
let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
check_consistency ppf file_name compunit;
seek_in inchan compunit.cu_pos;
- let code_block = input_bytes inchan compunit.cu_codesize in
- Symtable.patch_object code_block compunit.cu_reloc;
+ let code_block = LongString.input_bytes inchan compunit.cu_codesize in
+ Symtable.ls_patch_object code_block compunit.cu_reloc;
if !Clflags.debug && compunit.cu_debug > 0 then begin
seek_in inchan compunit.cu_debug;
let buffer = input_bytes inchan compunit.cu_debugsize in
debug_info := (currpos_fun(), buffer) :: !debug_info
end;
- output_fun code_block;
+ Array.iter output_fun code_block;
if !Clflags.link_everything then
List.iter Symtable.require_primitive compunit.cu_primitives
diff -Naur orig/bytecomp/emitcode.ml long-bytecode/bytecomp/emitcode.ml
--- orig/bytecomp/emitcode.ml 2013-02-22 18:10:28.000000000 +0100
+++ long-bytecode/bytecomp/emitcode.ml 2013-02-19 21:51:10.000000000 +0100
@@ -24,21 +24,21 @@
(* Buffering of bytecode *)
-let out_buffer = ref(String.create 1024)
+let out_buffer = ref(LongString.create 1024)
and out_position = ref 0
let out_word b1 b2 b3 b4 =
let p = !out_position in
- if p >= String.length !out_buffer then begin
- let len = String.length !out_buffer in
- let new_buffer = String.create (2 * len) in
- String.blit !out_buffer 0 new_buffer 0 len;
+ if p >= LongString.length !out_buffer then begin
+ let len = LongString.length !out_buffer in
+ let new_buffer = LongString.create (2 * len) in
+ LongString.blit !out_buffer 0 new_buffer 0 len;
out_buffer := new_buffer
end;
- String.unsafe_set !out_buffer p (Char.unsafe_chr b1);
- String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2);
- String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3);
- String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4);
+ LongString.set !out_buffer p (Char.unsafe_chr b1);
+ LongString.set !out_buffer (p+1) (Char.unsafe_chr b2);
+ LongString.set !out_buffer (p+2) (Char.unsafe_chr b3);
+ LongString.set !out_buffer (p+3) (Char.unsafe_chr b4);
out_position := p + 4
let out opcode =
@@ -88,10 +88,10 @@
let backpatch (pos, orig) =
let displ = (!out_position - orig) asr 2 in
- !out_buffer.[pos] <- Char.unsafe_chr displ;
- !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8);
- !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16);
- !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24)
+ LongString.set !out_buffer pos (Char.unsafe_chr displ);
+ LongString.set !out_buffer (pos+1) (Char.unsafe_chr (displ asr 8));
+ LongString.set !out_buffer (pos+2) (Char.unsafe_chr (displ asr 16));
+ LongString.set !out_buffer (pos+3) (Char.unsafe_chr (displ asr 24))
let define_label lbl =
if lbl >= Array.length !label_table then extend_label_table lbl;
@@ -359,7 +359,7 @@
output_binary_int outchan 0;
let pos_code = pos_out outchan in
emit code;
- output outchan !out_buffer 0 !out_position;
+ LongString.output outchan !out_buffer 0 !out_position;
let (pos_debug, size_debug) =
if !Clflags.debug then begin
let p = pos_out outchan in
@@ -392,7 +392,7 @@
emit init_code;
emit fun_code;
let code = Meta.static_alloc !out_position in
- String.unsafe_blit !out_buffer 0 code 0 !out_position;
+ LongString.unsafe_blit !out_buffer 0 code 0 !out_position;
let reloc = List.rev !reloc_info
and code_size = !out_position in
init();
@@ -403,7 +403,7 @@
let to_packed_file outchan code =
init();
emit code;
- output outchan !out_buffer 0 !out_position;
+ LongString.output outchan !out_buffer 0 !out_position;
let reloc = !reloc_info in
init();
reloc
diff -Naur orig/bytecomp/symtable.ml long-bytecode/bytecomp/symtable.ml
--- orig/bytecomp/symtable.ml 2013-02-22 18:10:28.000000000 +0100
+++ long-bytecode/bytecomp/symtable.ml 2013-02-19 21:51:17.000000000 +0100
@@ -177,25 +177,28 @@
(* Must use the unsafe String.set here because the block may be
a "fake" string as returned by Meta.static_alloc. *)
-let patch_int buff pos n =
- String.unsafe_set buff pos (Char.unsafe_chr n);
- String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
- String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
- String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
+let gen_patch_int str_set buff pos n =
+ str_set buff pos (Char.unsafe_chr n);
+ str_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
+ str_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
+ str_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
-let patch_object buff patchlist =
+let gen_patch_object str_set buff patchlist =
List.iter
(function
(Reloc_literal sc, pos) ->
- patch_int buff pos (slot_for_literal sc)
+ gen_patch_int str_set buff pos (slot_for_literal sc)
| (Reloc_getglobal id, pos) ->
- patch_int buff pos (slot_for_getglobal id)
+ gen_patch_int str_set buff pos (slot_for_getglobal id)
| (Reloc_setglobal id, pos) ->
- patch_int buff pos (slot_for_setglobal id)
+ gen_patch_int str_set buff pos (slot_for_setglobal id)
| (Reloc_primitive name, pos) ->
- patch_int buff pos (num_of_prim name))
+ gen_patch_int str_set buff pos (num_of_prim name))
patchlist
+let patch_object = gen_patch_object String.unsafe_set
+let ls_patch_object = gen_patch_object LongString.set
+
(* Translate structured constants *)
let rec transl_const = function
diff -Naur orig/bytecomp/symtable.mli long-bytecode/bytecomp/symtable.mli
--- orig/bytecomp/symtable.mli 2013-02-22 18:10:28.000000000 +0100
+++ long-bytecode/bytecomp/symtable.mli 2013-02-19 21:51:20.000000000 +0100
@@ -20,6 +20,7 @@
val init: unit -> unit
val patch_object: string -> (reloc_info * int) list -> unit
+val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit
val require_primitive: string -> unit
val initial_global_table: unit -> Obj.t array
val output_global_map: out_channel -> unit
diff -Naur orig/utils/misc.ml long-bytecode/utils/misc.ml
--- orig/utils/misc.ml 2013-02-22 18:10:50.000000000 +0100
+++ long-bytecode/utils/misc.ml 2013-02-19 21:50:31.000000000 +0100
@@ -224,3 +224,52 @@
let fst4 (x, _, _, _) = x
let snd4 (_,x,_, _) = x
let thd4 (_,_,x,_) = x
+
+(* Long string *)
+
+module LongString = struct
+ type t = string array
+
+ let create str_size =
+ let tbl_size = str_size / Sys.max_string_length + 1 in
+ let tbl = Array.make tbl_size "" in
+ for i = 0 to tbl_size - 2 do
+ tbl.(i) <- String.create Sys.max_string_length;
+ done;
+ tbl.(tbl_size - 1) <- String.create (str_size mod Sys.max_string_length);
+ tbl
+ ;;
+
+ let length tbl =
+ let tbl_size = Array.length tbl in
+ Sys.max_string_length * (tbl_size - 1) + String.length tbl.(tbl_size - 1)
+ ;;
+
+ let get tbl ind =
+ tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length]
+ ;;
+
+ let set tbl ind c =
+ tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] <- c;
+ ;;
+
+ let blit src srcoff dst dstoff len =
+ for i = 0 to len - 1 do set dst (dstoff + i) (get src (srcoff + i)) done
+ ;;
+
+ let output oc tbl pos len =
+ for i = pos to pos + len - 1 do output_char oc (get tbl i) done;
+ ;;
+
+ let unsafe_blit src srcoff dst dstoff len =
+ for i = 0 to len - 1 do
+ String.unsafe_set dst (dstoff + i) (get src (srcoff + i))
+ done;
+ ;;
+
+ let input_bytes ic len =
+ let tbl = create len in
+ Array.iter (fun str -> really_input ic str 0 (String.length str)) tbl;
+ tbl
+ ;;
+end;;
diff -Naur orig/utils/misc.mli long-bytecode/utils/misc.mli
--- orig/utils/misc.mli 2013-02-22 18:10:50.000000000 +0100
+++ long-bytecode/utils/misc.mli 2013-02-19 21:50:34.000000000 +0100
@@ -122,3 +122,16 @@
val fst4: 'a * 'b * 'c * 'd -> 'a
val snd4: 'a * 'b * 'c * 'd -> 'b
val thd4: 'a * 'b * 'c * 'd -> 'c
+
+module LongString :
+ sig
+ type t = string array
+ val create : int -> string array
+ val length : string array -> int
+ val get : string array -> int -> char
+ val set : string array -> int -> char -> unit
+ val blit : string array -> int -> string array -> int -> int -> unit
+ val output : out_channel -> string array -> int -> int -> unit
+ val unsafe_blit : string array -> int -> string -> int -> int -> unit
+ val input_bytes : in_channel -> int -> t
+ end
tailrec-asmcomp.diff [^] (45,817 bytes) 2013-02-22 18:51 [Show Content] [Hide Content]diff -Naur orig/asmcomp/comballoc.ml tailrec-asmcomp/asmcomp/comballoc.ml
--- orig/asmcomp/comballoc.ml 2013-02-22 18:11:09.000000000 +0100
+++ tailrec-asmcomp/asmcomp/comballoc.ml 2013-02-19 21:51:50.000000000 +0100
@@ -27,64 +27,72 @@
No_alloc -> 0
| Pending_alloc(reg, ofs) -> ofs
-let rec combine i allocstate =
+let rec combine i allocstate kont =
match i.desc with
Iend | Ireturn | Iexit _ | Iraise ->
- (i, allocated_size allocstate)
+ kont (i, allocated_size allocstate)
| Iop(Ialloc sz) ->
begin match allocstate with
No_alloc ->
- let (newnext, newsz) =
- combine i.next (Pending_alloc(i.res.(0), sz)) in
- (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0)
+ combine i.next (Pending_alloc(i.res.(0), sz)) (fun (newnext, newsz) ->
+ kont (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0))
| Pending_alloc(reg, ofs) ->
if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin
- let (newnext, newsz) =
- combine i.next (Pending_alloc(reg, ofs + sz)) in
- (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext,
- newsz)
+ combine i.next (Pending_alloc(reg, ofs + sz))
+ (fun (newnext, newsz) ->
+ kont (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |]
+ i.res newnext, newsz))
end else begin
- let (newnext, newsz) =
- combine i.next (Pending_alloc(i.res.(0), sz)) in
- (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs)
+ combine i.next (Pending_alloc(i.res.(0), sz))
+ (fun (newnext, newsz) ->
+ kont (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs))
end
end
| Iop(Icall_ind | Icall_imm _ | Iextcall _ |
Itailcall_ind | Itailcall_imm _) ->
- let newnext = combine_restart i.next in
- (instr_cons_debug i.desc i.arg i.res i.dbg newnext,
- allocated_size allocstate)
+ combine_restart i.next (fun newnext ->
+ kont (instr_cons_debug i.desc i.arg i.res i.dbg newnext,
+ allocated_size allocstate))
| Iop op ->
- let (newnext, sz) = combine i.next allocstate in
- (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz)
+ combine i.next allocstate (fun (newnext, sz) ->
+ kont (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz))
| Iifthenelse(test, ifso, ifnot) ->
- let newifso = combine_restart ifso in
- let newifnot = combine_restart ifnot in
- let newnext = combine_restart i.next in
- (instr_cons (Iifthenelse(test, newifso, newifnot)) i.arg i.res newnext,
- allocated_size allocstate)
+ combine_restart ifso (fun newifso ->
+ combine_restart ifnot (fun newifnot ->
+ combine_restart i.next (fun newnext ->
+ kont (instr_cons (Iifthenelse(test, newifso, newifnot))
+ i.arg i.res newnext, allocated_size allocstate))))
| Iswitch(table, cases) ->
- let newcases = Array.map combine_restart cases in
- let newnext = combine_restart i.next in
- (instr_cons (Iswitch(table, newcases)) i.arg i.res newnext,
- allocated_size allocstate)
+ let rec map l kont = match l with
+ | [] -> kont []
+ | hd :: tl ->
+ combine_restart hd (fun x ->
+ map tl (fun y ->
+ kont (x :: y)))
+ in
+ map (Array.to_list cases) (fun newcases ->
+ combine_restart i.next (fun newnext ->
+ kont (instr_cons (Iswitch(table, Array.of_list newcases))
+ i.arg i.res newnext, allocated_size allocstate)))
| Iloop(body) ->
- let newbody = combine_restart body in
- (instr_cons (Iloop(newbody)) i.arg i.res i.next,
- allocated_size allocstate)
+ combine_restart body (fun newbody ->
+ kont (instr_cons (Iloop(newbody)) i.arg i.res i.next,
+ allocated_size allocstate))
| Icatch(io, body, handler) ->
- let (newbody, sz) = combine body allocstate in
- let newhandler = combine_restart handler in
- let newnext = combine_restart i.next in
- (instr_cons (Icatch(io, newbody, newhandler)) i.arg i.res newnext, sz)
+ combine body allocstate (fun (newbody, sz) ->
+ combine_restart handler (fun newhandler ->
+ combine_restart i.next (fun newnext ->
+ kont (instr_cons (Icatch(io, newbody, newhandler))
+ i.arg i.res newnext, sz))))
| Itrywith(body, handler) ->
- let (newbody, sz) = combine body allocstate in
- let newhandler = combine_restart handler in
- let newnext = combine_restart i.next in
- (instr_cons (Itrywith(newbody, newhandler)) i.arg i.res newnext, sz)
+ combine body allocstate (fun (newbody, sz) ->
+ combine_restart handler (fun newhandler ->
+ combine_restart i.next (fun newnext ->
+ kont (instr_cons (Itrywith(newbody, newhandler))
+ i.arg i.res newnext, sz))))
-and combine_restart i =
- let (newi, _) = combine i No_alloc in newi
+and combine_restart i kont =
+ combine i No_alloc (fun (newi, _) -> kont newi)
let fundecl f =
- {f with fun_body = combine_restart f.fun_body}
+ combine_restart f.fun_body (fun r -> {f with fun_body = r})
diff -Naur orig/asmcomp/linearize.ml tailrec-asmcomp/asmcomp/linearize.ml
--- orig/asmcomp/linearize.ml 2013-02-22 18:11:09.000000000 +0100
+++ tailrec-asmcomp/asmcomp/linearize.ml 2013-02-19 21:52:00.000000000 +0100
@@ -166,65 +166,74 @@
(* Linearize an instruction [i]: add it in front of the continuation [n] *)
-let rec linear i n =
+let rec linear i n kont =
match i.Mach.desc with
- Iend -> n
+ Iend -> kont n
| Iop(Itailcall_ind | Itailcall_imm _ as op) ->
- copy_instr (Lop op) i (discard_dead_code n)
+ kont (copy_instr (Lop op) i (discard_dead_code n))
| Iop(Imove | Ireload | Ispill)
when i.Mach.arg.(0).loc = i.Mach.res.(0).loc ->
- linear i.Mach.next n
+ linear i.Mach.next n kont
| Iop op ->
- copy_instr (Lop op) i (linear i.Mach.next n)
+ linear i.Mach.next n (fun new_n -> kont (copy_instr (Lop op) i new_n))
| Ireturn ->
let n1 = copy_instr Lreturn i (discard_dead_code n) in
if !Proc.contains_calls
- then cons_instr Lreloadretaddr n1
- else n1
+ then kont (cons_instr Lreloadretaddr n1)
+ else kont n1
| Iifthenelse(test, ifso, ifnot) ->
- let n1 = linear i.Mach.next n in
+ linear i.Mach.next n (fun n1 ->
begin match (ifso.Mach.desc, ifnot.Mach.desc, n1.desc) with
Iend, _, Lbranch lbl ->
- copy_instr (Lcondbranch(test, lbl)) i (linear ifnot n1)
+ linear ifnot n1 (fun x ->
+ kont (copy_instr (Lcondbranch(test, lbl)) i x))
| _, Iend, Lbranch lbl ->
- copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1)
+ linear ifso n1 (fun x ->
+ kont (copy_instr (Lcondbranch(invert_test test, lbl)) i x))
| Iexit nfail1, Iexit nfail2, _
when is_next_catch nfail1 ->
let lbl2 = find_exit_label nfail2 in
- copy_instr
- (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1)
+ linear ifso n1 (fun x ->
+ kont (copy_instr (Lcondbranch (invert_test test, lbl2)) i x))
| Iexit nfail, _, _ ->
- let n2 = linear ifnot n1
- and lbl = find_exit_label nfail in
- copy_instr (Lcondbranch(test, lbl)) i n2
+ linear ifnot n1 (fun n2 ->
+ let lbl = find_exit_label nfail in
+ kont (copy_instr (Lcondbranch(test, lbl)) i n2))
| _, Iexit nfail, _ ->
- let n2 = linear ifso n1 in
+ linear ifso n1 (fun n2 ->
let lbl = find_exit_label nfail in
- copy_instr (Lcondbranch(invert_test test, lbl)) i n2
+ kont (copy_instr (Lcondbranch(invert_test test, lbl)) i n2))
| Iend, _, _ ->
let (lbl_end, n2) = get_label n1 in
- copy_instr (Lcondbranch(test, lbl_end)) i (linear ifnot n2)
+ linear ifnot n2 (fun x ->
+ kont (copy_instr (Lcondbranch(test, lbl_end)) i x))
| _, Iend, _ ->
let (lbl_end, n2) = get_label n1 in
- copy_instr (Lcondbranch(invert_test test, lbl_end)) i
- (linear ifso n2)
+ linear ifso n2 (fun x ->
+ kont (copy_instr (Lcondbranch(invert_test test, lbl_end)) i x))
| _, _, _ ->
(* Should attempt branch prediction here *)
let (lbl_end, n2) = get_label n1 in
- let (lbl_else, nelse) = get_label (linear ifnot n2) in
- copy_instr (Lcondbranch(invert_test test, lbl_else)) i
- (linear ifso (add_branch lbl_end nelse))
- end
+ linear ifnot n2 (fun x ->
+ let (lbl_else, nelse) = get_label x in
+ linear ifso (add_branch lbl_end nelse) (fun y ->
+ kont (copy_instr (Lcondbranch(invert_test test, lbl_else)) i y)))
+ end)
| Iswitch(index, cases) ->
let lbl_cases = Array.create (Array.length cases) 0 in
- let (lbl_end, n1) = get_label(linear i.Mach.next n) in
+ linear i.Mach.next n (fun x ->
+ let (lbl_end, n1) = get_label x in
let n2 = ref (discard_dead_code n1) in
- for i = Array.length cases - 1 downto 0 do
- let (lbl_case, ncase) =
- get_label(linear cases.(i) (add_branch lbl_end !n2)) in
- lbl_cases.(i) <- lbl_case;
- n2 := discard_dead_code ncase
- done;
+ let rec rev_iter i kont =
+ if i >= 0 then (
+ linear cases.(i) (add_branch lbl_end !n2) (fun y ->
+ let (lbl_case, ncase) = get_label y in
+ lbl_cases.(i) <- lbl_case;
+ n2 := discard_dead_code ncase;
+ rev_iter (i - 1) kont)
+ ) else kont ()
+ in
+ rev_iter (Array.length cases - 1) (fun () ->
(* Switches with 1 and 2 branches have been eliminated earlier.
Here, we do something for switches with 3 branches. *)
if Array.length index = 3 then begin
@@ -232,38 +241,42 @@
let find_label n =
let lbl = lbl_cases.(index.(n)) in
if lbl = fallthrough_lbl then None else Some lbl in
- copy_instr (Lcondbranch3(find_label 0, find_label 1, find_label 2))
- i !n2
+ kont (copy_instr (Lcondbranch3(find_label 0, find_label 1,
+ find_label 2)) i !n2)
end else
- copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index)) i !n2
+ kont (copy_instr (Lswitch(Array.map (fun n -> lbl_cases.(n)) index))
+ i !n2)))
| Iloop body ->
let lbl_head = new_label() in
- let n1 = linear i.Mach.next n in
- let n2 = linear body (cons_instr (Lbranch lbl_head) n1) in
- cons_instr (Llabel lbl_head) n2
+ linear i.Mach.next n (fun n1 ->
+ linear body (cons_instr (Lbranch lbl_head) n1) (fun n2 ->
+ kont (cons_instr (Llabel lbl_head) n2)))
| Icatch(io, body, handler) ->
- let (lbl_end, n1) = get_label(linear i.Mach.next n) in
- let (lbl_handler, n2) = get_label(linear handler n1) in
+ linear i.Mach.next n (fun x ->
+ let (lbl_end, n1) = get_label x in
+ linear handler n1 (fun y ->
+ let (lbl_handler, n2) = get_label y in
exit_label := (io, lbl_handler) :: !exit_label ;
- let n3 = linear body (add_branch lbl_end n2) in
+ linear body (add_branch lbl_end n2) (fun n3 ->
exit_label := List.tl !exit_label;
- n3
+ kont n3)))
| Iexit nfail ->
- let n1 = linear i.Mach.next n in
+ linear i.Mach.next n (fun n1 ->
let lbl = find_exit_label nfail in
- add_branch lbl n1
+ kont (add_branch lbl n1))
| Itrywith(body, handler) ->
- let (lbl_join, n1) = get_label (linear i.Mach.next n) in
- let (lbl_body, n2) =
- get_label (cons_instr Lpushtrap
- (linear body (cons_instr Lpoptrap n1))) in
- cons_instr (Lsetuptrap lbl_body)
- (linear handler (add_branch lbl_join n2))
+ linear i.Mach.next n (fun x ->
+ let (lbl_join, n1) = get_label x in
+ linear body (cons_instr Lpoptrap n1) (fun y ->
+ let (lbl_body, n2) = get_label (cons_instr Lpushtrap y) in
+ linear handler (add_branch lbl_join n2) (fun z ->
+ kont (cons_instr (Lsetuptrap lbl_body) z))))
| Iraise ->
- copy_instr Lraise i (discard_dead_code n)
+ kont (copy_instr Lraise i (discard_dead_code n))
let fundecl f =
+ linear f.Mach.fun_body end_instr (fun body ->
{ fun_name = f.Mach.fun_name;
- fun_body = linear f.Mach.fun_body end_instr;
+ fun_body = body;
fun_fast = f.Mach.fun_fast;
- fun_dbg = f.Mach.fun_dbg }
+ fun_dbg = f.Mach.fun_dbg })
diff -Naur orig/asmcomp/liveness.ml tailrec-asmcomp/asmcomp/liveness.ml
--- orig/asmcomp/liveness.ml 2013-02-22 18:11:09.000000000 +0100
+++ tailrec-asmcomp/asmcomp/liveness.ml 2013-02-19 21:52:07.000000000 +0100
@@ -27,7 +27,7 @@
let live_at_break = ref Reg.Set.empty
let live_at_raise = ref Reg.Set.empty
-let rec live i finally =
+let rec live i finally kont =
(* finally is the set of registers live after execution of the
instruction sequence.
The result of the function is the set of registers live just
@@ -37,84 +37,87 @@
match i.desc with
Iend ->
i.live <- finally;
- finally
+ kont finally
| Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
(* i.live remains empty since no regs are live across *)
- Reg.set_of_array i.arg
+ kont (Reg.set_of_array i.arg)
| Iifthenelse(test, ifso, ifnot) ->
- let at_join = live i.next finally in
- let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in
+ live i.next finally (fun at_join ->
+ live ifso at_join (fun s1 ->
+ live ifnot at_join (fun s2 ->
+ let at_fork = Reg.Set.union s1 s2 in
i.live <- at_fork;
- Reg.add_set_array at_fork i.arg
+ kont (Reg.add_set_array at_fork i.arg))))
| Iswitch(index, cases) ->
- let at_join = live i.next finally in
- let at_fork = ref Reg.Set.empty in
- for i = 0 to Array.length cases - 1 do
- at_fork := Reg.Set.union !at_fork (live cases.(i) at_join)
- done;
- i.live <- !at_fork;
- Reg.add_set_array !at_fork i.arg
+ live i.next finally (fun at_join ->
+ let case_nb = Array.length cases in
+ let rec fold i acc kont =
+ if i = case_nb then kont acc else
+ live cases.(i) at_join (fun case_set ->
+ fold (i + 1) (Reg.Set.union acc case_set) kont)
+ in
+ fold 0 Reg.Set.empty (fun at_fork ->
+ i.live <- at_fork;
+ kont (Reg.add_set_array at_fork i.arg)))
| Iloop(body) ->
- let at_top = ref Reg.Set.empty in
(* Yes, there are better algorithms, but we'll just iterate till
reaching a fixpoint. *)
- begin try
- while true do
- let new_at_top = Reg.Set.union !at_top (live body !at_top) in
- if Reg.Set.equal !at_top new_at_top then raise Exit;
- at_top := new_at_top
- done
- with Exit -> ()
- end;
- i.live <- !at_top;
- !at_top
+ let rec fixpoint at_top kont =
+ live body at_top (fun set ->
+ let new_at_top = Reg.Set.union at_top set in
+ if Reg.Set.equal at_top new_at_top then kont at_top
+ else fixpoint new_at_top kont)
+ in
+ fixpoint Reg.Set.empty (fun at_top -> i.live <- at_top; kont at_top)
| Icatch(nfail, body, handler) ->
- let at_join = live i.next finally in
- let before_handler = live handler at_join in
- let before_body =
- live_at_exit := (nfail,before_handler) :: !live_at_exit ;
- let before_body = live body at_join in
- live_at_exit := List.tl !live_at_exit ;
- before_body in
+ live i.next finally (fun at_join ->
+ live handler at_join (fun before_handler ->
+ live_at_exit := (nfail,before_handler) :: !live_at_exit;
+ live body at_join (fun before_body ->
+ live_at_exit := List.tl !live_at_exit;
i.live <- before_body;
- before_body
+ kont before_body)))
| Iexit nfail ->
let this_live = find_live_at_exit nfail in
i.live <- this_live ;
- this_live
+ kont this_live
| Itrywith(body, handler) ->
- let at_join = live i.next finally in
- let before_handler = live handler at_join in
+ live i.next finally (fun at_join ->
+ live handler at_join (fun before_handler ->
let saved_live_at_raise = !live_at_raise in
live_at_raise := Reg.Set.remove Proc.loc_exn_bucket before_handler;
- let before_body = live body at_join in
+ live body at_join (fun before_body ->
live_at_raise := saved_live_at_raise;
i.live <- before_body;
- before_body
+ kont before_body)))
| Iraise ->
(* i.live remains empty since no regs are live across *)
- Reg.add_set_array !live_at_raise i.arg
+ kont (Reg.add_set_array !live_at_raise i.arg)
| _ ->
- let across_after = Reg.diff_set_array (live i.next finally) i.res in
+ live i.next finally (fun set ->
+ let across_after = Reg.diff_set_array set i.res in
let across =
match i.desc with
- Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _)
- | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
- (* The function call may raise an exception, branching to the
- nearest enclosing try ... with. Similarly for bounds checks.
- Hence, everything that must be live at the beginning of
- the exception handler must also be live across this instr. *)
- Reg.Set.union across_after !live_at_raise
- | _ ->
- across_after in
+ Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _)
+ | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
+ (* The function call may raise an exception, branching to the
+ nearest enclosing try ... with. Similarly for bounds checks.
+ Hence, everything that must be live at the beginning of
+ the exception handler must also be live across this instr. *)
+ Reg.Set.union across_after !live_at_raise
+ | _ ->
+ across_after
+ in
i.live <- across;
- Reg.add_set_array across i.arg
+ kont (Reg.add_set_array across i.arg))
let fundecl ppf f =
- let initially_live = live f.fun_body Reg.Set.empty in
+ live f.fun_body Reg.Set.empty (fun initially_live ->
(* Sanity check: only function parameters can be live at entrypoint *)
- let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in
+ let wrong_live =
+ Reg.Set.diff initially_live (Reg.set_of_array f.fun_args)
+ in
if not (Reg.Set.is_empty wrong_live) then begin
Format.fprintf ppf "%a@." Printmach.regset wrong_live;
- Misc.fatal_error "Liveness.fundecl"
- end
+ Misc.fatal_error "Liveness.fundecl";
+ end)
diff -Naur orig/asmcomp/reloadgen.ml tailrec-asmcomp/asmcomp/reloadgen.ml
--- orig/asmcomp/reloadgen.ml 2013-02-22 18:11:09.000000000 +0100
+++ tailrec-asmcomp/asmcomp/reloadgen.ml 2013-02-19 21:52:21.000000000 +0100
@@ -84,58 +84,73 @@
method reload_test tst args =
self#makeregs args
-method private reload i =
+method private reload i kont =
match i.desc with
(* For function calls, returns, etc: the arguments and results are
already at the correct position (e.g. on stack for some arguments).
However, something needs to be done for the function pointer in
indirect calls. *)
- Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i
+ Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> kont i
| Iop(Itailcall_ind) ->
let newarg = self#makereg1 i.arg in
- insert_moves i.arg newarg
- {i with arg = newarg}
+ kont (insert_moves i.arg newarg {i with arg = newarg})
| Iop(Icall_imm _ | Iextcall _) ->
- {i with next = self#reload i.next}
+ self#reload i.next (fun nxt -> kont {i with next = nxt})
| Iop(Icall_ind) ->
let newarg = self#makereg1 i.arg in
- insert_moves i.arg newarg
- {i with arg = newarg; next = self#reload i.next}
+ self#reload i.next (fun nxt ->
+ kont (insert_moves i.arg newarg {i with arg = newarg; next = nxt}))
| Iop op ->
let (newarg, newres) = self#reload_operation op i.arg i.res in
- insert_moves i.arg newarg
- {i with arg = newarg; res = newres; next =
- (insert_moves newres i.res
- (self#reload i.next))}
+ self#reload i.next (fun nxt ->
+ kont (insert_moves i.arg newarg
+ {i with arg = newarg; res = newres; next =
+ (insert_moves newres i.res nxt)}))
| Iifthenelse(tst, ifso, ifnot) ->
let newarg = self#reload_test tst i.arg in
- insert_moves i.arg newarg
- (instr_cons
- (Iifthenelse(tst, self#reload ifso, self#reload ifnot)) newarg [||]
- (self#reload i.next))
+ self#reload ifso (fun nxt_ifso ->
+ self#reload ifnot (fun nxt_ifnot ->
+ self#reload i.next (fun nxt ->
+ kont (insert_moves i.arg newarg
+ (instr_cons (Iifthenelse(tst, nxt_ifso, nxt_ifnot))
+ newarg [||] nxt)))))
| Iswitch(index, cases) ->
+ let rec map cases kont = match cases with
+ | [] -> kont []
+ | case :: rest ->
+ self#reload case (fun x ->
+ map rest (fun y ->
+ kont (x :: y)))
+ in
let newarg = self#makeregs i.arg in
- insert_moves i.arg newarg
- (instr_cons (Iswitch(index, Array.map (self#reload) cases)) newarg [||]
- (self#reload i.next))
+ map (Array.to_list cases) (fun new_cases ->
+ self#reload i.next (fun new_nxt ->
+ kont (insert_moves i.arg newarg
+ (instr_cons (Iswitch(index, Array.of_list new_cases)) newarg [||]
+ new_nxt))))
| Iloop body ->
- instr_cons (Iloop(self#reload body)) [||] [||] (self#reload i.next)
+ self#reload body (fun new_body ->
+ self#reload i.next (fun new_nxt ->
+ kont (instr_cons (Iloop(new_body)) [||] [||] new_nxt)))
| Icatch(nfail, body, handler) ->
- instr_cons
- (Icatch(nfail, self#reload body, self#reload handler)) [||] [||]
- (self#reload i.next)
+ self#reload body (fun new_body ->
+ self#reload handler (fun new_handler ->
+ self#reload i.next (fun new_nxt ->
+ kont (instr_cons(Icatch(nfail,new_body,new_handler)) [||] [||] new_nxt))))
| Iexit i ->
- instr_cons (Iexit i) [||] [||] dummy_instr
+ kont (instr_cons (Iexit i) [||] [||] dummy_instr)
| Itrywith(body, handler) ->
- instr_cons (Itrywith(self#reload body, self#reload handler)) [||] [||]
- (self#reload i.next)
+ self#reload body (fun new_body ->
+ self#reload handler (fun new_handler ->
+ self#reload i.next (fun new_nxt ->
+ kont (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_nxt))))
method fundecl f =
redo_regalloc <- false;
- let new_body = self#reload f.fun_body in
+ self#reload f.fun_body (fun new_body ->
({fun_name = f.fun_name; fun_args = f.fun_args;
fun_body = new_body; fun_fast = f.fun_fast;
fun_dbg = f.fun_dbg},
- redo_regalloc)
+ redo_regalloc))
end
diff -Naur orig/asmcomp/spill.ml tailrec-asmcomp/asmcomp/spill.ml
--- orig/asmcomp/spill.ml 2013-02-22 18:11:09.000000000 +0100
+++ tailrec-asmcomp/asmcomp/spill.ml 2013-02-19 21:52:29.000000000 +0100
@@ -133,22 +133,22 @@
let reload_at_break = ref Reg.Set.empty
-let rec reload i before =
+let rec reload i before kont =
incr current_date;
record_use i.arg;
record_use i.res;
match i.desc with
Iend ->
- (i, before)
+ kont (i, before)
| Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
- (add_reloads (Reg.inter_set_array before i.arg) i,
- Reg.Set.empty)
+ kont (add_reloads (Reg.inter_set_array before i.arg) i,
+ Reg.Set.empty)
| Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) ->
(* All regs live across must be spilled *)
- let (new_next, finally) = reload i.next i.live in
- (add_reloads (Reg.inter_set_array before i.arg)
- (instr_cons_debug i.desc i.arg i.res i.dbg new_next),
- finally)
+ reload i.next i.live (fun (new_next, finally) ->
+ kont (add_reloads (Reg.inter_set_array before i.arg)
+ (instr_cons_debug i.desc i.arg i.res i.dbg new_next),
+ finally))
| Iop op ->
let new_before =
(* Quick check to see if the register pressure is below the maximum *)
@@ -158,90 +158,84 @@
else add_superpressure_regs op i.live i.res before in
let after =
Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in
- let (new_next, finally) = reload i.next after in
- (add_reloads (Reg.inter_set_array new_before i.arg)
- (instr_cons_debug i.desc i.arg i.res i.dbg new_next),
- finally)
+ reload i.next after (fun (new_next, finally) ->
+ kont (add_reloads (Reg.inter_set_array new_before i.arg)
+ (instr_cons_debug i.desc i.arg i.res i.dbg new_next),
+ finally))
| Iifthenelse(test, ifso, ifnot) ->
let at_fork = Reg.diff_set_array before i.arg in
let date_fork = !current_date in
- let (new_ifso, after_ifso) = reload ifso at_fork in
+ reload ifso at_fork (fun (new_ifso, after_ifso) ->
let date_ifso = !current_date in
current_date := date_fork;
- let (new_ifnot, after_ifnot) = reload ifnot at_fork in
+ reload ifnot at_fork (fun (new_ifnot, after_ifnot) ->
current_date := max date_ifso !current_date;
- let (new_next, finally) =
- reload i.next (Reg.Set.union after_ifso after_ifnot) in
+ reload i.next (Reg.Set.union after_ifso after_ifnot)
+ (fun (new_next, finally) ->
let new_i =
instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
i.arg i.res new_next in
destroyed_at_fork := (new_i, at_fork) :: !destroyed_at_fork;
- (add_reloads (Reg.inter_set_array before i.arg) new_i,
- finally)
+ kont (add_reloads (Reg.inter_set_array before i.arg) new_i,
+ finally))))
| Iswitch(index, cases) ->
let at_fork = Reg.diff_set_array before i.arg in
let date_fork = !current_date in
let date_join = ref 0 in
let after_cases = ref Reg.Set.empty in
- let new_cases =
- Array.map
- (fun c ->
- current_date := date_fork;
- let (new_c, after_c) = reload c at_fork in
- after_cases := Reg.Set.union !after_cases after_c;
- date_join := max !date_join !current_date;
- new_c)
- cases in
+ let rec map cases kont = match cases with
+ | [] -> kont []
+ | c :: rest ->
+ current_date := date_fork;
+ reload c at_fork (fun (new_c, after_c) ->
+ after_cases := Reg.Set.union !after_cases after_c;
+ date_join := max !date_join !current_date;
+ map rest (fun new_rest ->
+ kont (new_c :: new_rest)))
+ in
+ map (Array.to_list cases) (fun new_cases ->
current_date := !date_join;
- let (new_next, finally) = reload i.next !after_cases in
- (add_reloads (Reg.inter_set_array before i.arg)
- (instr_cons (Iswitch(index, new_cases))
- i.arg i.res new_next),
- finally)
+ reload i.next !after_cases (fun (new_next, finally) ->
+ kont (add_reloads (Reg.inter_set_array before i.arg)
+ (instr_cons (Iswitch(index, Array.of_list new_cases))
+ i.arg i.res new_next), finally)))
| Iloop(body) ->
let date_start = !current_date in
- let at_head = ref before in
- let final_body = ref body in
- begin try
- while true do
- current_date := date_start;
- let (new_body, new_at_head) = reload body !at_head in
- let merged_at_head = Reg.Set.union !at_head new_at_head in
- if Reg.Set.equal merged_at_head !at_head then begin
- final_body := new_body;
- raise Exit
- end;
- at_head := merged_at_head
- done
- with Exit -> ()
- end;
- let (new_next, finally) = reload i.next Reg.Set.empty in
- (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
- finally)
+ let rec fold at_head kont =
+ current_date := date_start;
+ reload body at_head (fun (new_body, new_at_head) ->
+ let merged_at_head = Reg.Set.union at_head new_at_head in
+ if Reg.Set.equal merged_at_head at_head then kont new_body
+ else fold merged_at_head kont)
+ in
+ fold before (fun final_body ->
+ reload i.next Reg.Set.empty (fun (new_next, finally) ->
+ kont (instr_cons (Iloop(final_body)) i.arg i.res new_next,
+ finally)))
| Icatch(nfail, body, handler) ->
let new_set = ref Reg.Set.empty in
reload_at_exit := (nfail, new_set) :: !reload_at_exit ;
- let (new_body, after_body) = reload body before in
+ reload body before (fun (new_body, after_body) ->
let at_exit = !new_set in
reload_at_exit := List.tl !reload_at_exit ;
- let (new_handler, after_handler) = reload handler at_exit in
- let (new_next, finally) =
- reload i.next (Reg.Set.union after_body after_handler) in
- (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next,
- finally)
+ reload handler at_exit (fun (new_handler, after_handler) ->
+ reload i.next (Reg.Set.union after_body after_handler)
+ (fun (new_next, finally) ->
+ kont (instr_cons (Icatch(nfail, new_body, new_handler))
+ i.arg i.res new_next, finally))))
| Iexit nfail ->
let set = find_reload_at_exit nfail in
set := Reg.Set.union !set before;
- (i, Reg.Set.empty)
+ kont (i, Reg.Set.empty)
| Itrywith(body, handler) ->
- let (new_body, after_body) = reload body before in
- let (new_handler, after_handler) = reload handler handler.live in
- let (new_next, finally) =
- reload i.next (Reg.Set.union after_body after_handler) in
- (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
- finally)
+ reload body before (fun (new_body, after_body) ->
+ reload handler handler.live (fun (new_handler, after_handler) ->
+ reload i.next (Reg.Set.union after_body after_handler)
+ (fun (new_next, finally) ->
+ kont (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
+ finally))))
| Iraise ->
- (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty)
+ kont (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty)
(* Second pass: add spill instructions based on what we've decided to reload.
That is, any register that may be reloaded in the future must be spilled
@@ -276,113 +270,108 @@
(fun r i -> instr_cons (Iop Ispill) [|r|] [|spill_reg r|] i)
regset i
-let rec spill i finally =
+let rec spill i finally kont =
match i.desc with
Iend ->
- (i, finally)
+ kont (i, finally)
| Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
- (i, Reg.Set.empty)
+ kont (i, Reg.Set.empty)
| Iop Ireload ->
- let (new_next, after) = spill i.next finally in
+ spill i.next finally (fun (new_next, after) ->
let before1 = Reg.diff_set_array after i.res in
- (instr_cons i.desc i.arg i.res new_next,
- Reg.add_set_array before1 i.res)
+ kont (instr_cons i.desc i.arg i.res new_next,
+ Reg.add_set_array before1 i.res))
| Iop _ ->
- let (new_next, after) = spill i.next finally in
+ spill i.next finally (fun (new_next, after) ->
let before1 = Reg.diff_set_array after i.res in
let before =
match i.desc with
- Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _)
- | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
+ Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _)
+ | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) ->
Reg.Set.union before1 !spill_at_raise
- | _ ->
- before1 in
- (instr_cons_debug i.desc i.arg i.res i.dbg
- (add_spills (Reg.inter_set_array after i.res) new_next),
- before)
+ | _ ->
+ before1
+ in
+ kont (instr_cons_debug i.desc i.arg i.res i.dbg
+ (add_spills (Reg.inter_set_array after i.res) new_next),
+ before))
| Iifthenelse(test, ifso, ifnot) ->
- let (new_next, at_join) = spill i.next finally in
- let (new_ifso, before_ifso) = spill ifso at_join in
- let (new_ifnot, before_ifnot) = spill ifnot at_join in
- if
- !inside_loop || !inside_arm
- then
- (instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
- i.arg i.res new_next,
- Reg.Set.union before_ifso before_ifnot)
+ spill i.next finally (fun (new_next, at_join) ->
+ spill ifso at_join (fun (new_ifso, before_ifso) ->
+ spill ifnot at_join (fun (new_ifnot, before_ifnot) ->
+ if !inside_loop || !inside_arm then
+ kont (instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
+ i.arg i.res new_next,
+ Reg.Set.union before_ifso before_ifnot)
else begin
let destroyed = List.assq i !destroyed_at_fork in
let spill_ifso_branch =
Reg.Set.diff (Reg.Set.diff before_ifso before_ifnot) destroyed
and spill_ifnot_branch =
Reg.Set.diff (Reg.Set.diff before_ifnot before_ifso) destroyed in
- (instr_cons
- (Iifthenelse(test, add_spills spill_ifso_branch new_ifso,
- add_spills spill_ifnot_branch new_ifnot))
- i.arg i.res new_next,
- Reg.Set.diff (Reg.Set.diff (Reg.Set.union before_ifso before_ifnot)
- spill_ifso_branch)
- spill_ifnot_branch)
- end
+ kont(instr_cons
+ (Iifthenelse(test, add_spills spill_ifso_branch new_ifso,
+ add_spills spill_ifnot_branch new_ifnot))
+ i.arg i.res new_next,
+ Reg.Set.diff (Reg.Set.diff (Reg.Set.union before_ifso before_ifnot)
+ spill_ifso_branch)
+ spill_ifnot_branch)
+ end)))
| Iswitch(index, cases) ->
- let (new_next, at_join) = spill i.next finally in
+ spill i.next finally (fun (new_next, at_join) ->
let saved_inside_arm = !inside_arm in
inside_arm := true ;
let before = ref Reg.Set.empty in
- let new_cases =
- Array.map
- (fun c ->
- let (new_c, before_c) = spill c at_join in
- before := Reg.Set.union !before before_c;
- new_c)
- cases in
+ let rec map cases kont = match cases with
+ | [] -> kont []
+ | c :: rest ->
+ spill c at_join (fun (new_c, before_c) ->
+ before := Reg.Set.union !before before_c;
+ map rest (fun new_rest ->
+ kont (new_c :: new_rest)))
+ in
+ map (Array.to_list cases) (fun new_cases ->
inside_arm := saved_inside_arm ;
- (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next,
- !before)
+ kont (instr_cons (Iswitch(index, Array.of_list new_cases))
+ i.arg i.res new_next, !before)))
| Iloop(body) ->
- let (new_next, _) = spill i.next finally in
+ spill i.next finally (fun (new_next, _) ->
let saved_inside_loop = !inside_loop in
inside_loop := true;
- let at_head = ref Reg.Set.empty in
- let final_body = ref body in
- begin try
- while true do
- let (new_body, before_body) = spill body !at_head in
- let new_at_head = Reg.Set.union !at_head before_body in
- if Reg.Set.equal new_at_head !at_head then begin
- final_body := new_body; raise Exit
- end;
- at_head := new_at_head
- done
- with Exit -> ()
- end;
+ let rec fold at_head kont =
+ spill body at_head (fun (new_body, before_body) ->
+ let new_at_head = Reg.Set.union at_head before_body in
+ if Reg.Set.equal new_at_head at_head then kont (new_body, at_head)
+ else fold new_at_head kont)
+ in
+ fold Reg.Set.empty (fun (final_body, at_head) ->
inside_loop := saved_inside_loop;
- (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
- !at_head)
+ kont (instr_cons (Iloop(final_body)) i.arg i.res new_next,
+ at_head)))
| Icatch(nfail, body, handler) ->
- let (new_next, at_join) = spill i.next finally in
- let (new_handler, at_exit) = spill handler at_join in
+ spill i.next finally (fun (new_next, at_join) ->
+ spill handler at_join (fun (new_handler, at_exit) ->
let saved_inside_catch = !inside_catch in
inside_catch := true ;
spill_at_exit := (nfail, at_exit) :: !spill_at_exit ;
- let (new_body, before) = spill body at_join in
+ spill body at_join (fun (new_body, before) ->
spill_at_exit := List.tl !spill_at_exit;
- inside_catch := saved_inside_catch ;
- (instr_cons (Icatch(nfail, new_body, new_handler)) i.arg i.res new_next,
- before)
+ inside_catch := saved_inside_catch;
+ kont (instr_cons (Icatch(nfail, new_body, new_handler))
+ i.arg i.res new_next, before))))
| Iexit nfail ->
- (i, find_spill_at_exit nfail)
+ kont (i, find_spill_at_exit nfail)
| Itrywith(body, handler) ->
- let (new_next, at_join) = spill i.next finally in
- let (new_handler, before_handler) = spill handler at_join in
+ spill i.next finally (fun (new_next, at_join) ->
+ spill handler at_join (fun (new_handler, before_handler) ->
let saved_spill_at_raise = !spill_at_raise in
spill_at_raise := before_handler;
- let (new_body, before_body) = spill body at_join in
+ spill body at_join (fun (new_body, before_body) ->
spill_at_raise := saved_spill_at_raise;
- (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
- before_body)
+ kont (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next,
+ before_body))))
| Iraise ->
- (i, !spill_at_raise)
+ kont (i, !spill_at_raise)
(* Entry point *)
@@ -390,8 +379,8 @@
spill_env := Reg.Map.empty;
use_date := Reg.Map.empty;
current_date := 0;
- let (body1, _) = reload f.fun_body Reg.Set.empty in
- let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in
+ reload f.fun_body Reg.Set.empty (fun (body1, _) ->
+ spill body1 Reg.Set.empty (fun (body2, tospill_at_entry) ->
let new_body =
add_spills (Reg.inter_set_array tospill_at_entry f.fun_args) body2 in
spill_env := Reg.Map.empty;
@@ -400,4 +389,4 @@
fun_args = f.fun_args;
fun_body = new_body;
fun_fast = f.fun_fast;
- fun_dbg = f.fun_dbg }
+ fun_dbg = f.fun_dbg }))
diff -Naur orig/asmcomp/split.ml tailrec-asmcomp/asmcomp/split.ml
--- orig/asmcomp/split.ml 2013-02-22 18:11:09.000000000 +0100
+++ tailrec-asmcomp/asmcomp/split.ml 2013-02-19 21:52:35.000000000 +0100
@@ -120,75 +120,79 @@
List.assoc k !exit_subst with
| Not_found -> Misc.fatal_error "Split.find_exit_subst"
-let rec rename i sub =
+let rec rename i sub kont =
match i.desc with
Iend ->
- (i, sub)
+ kont (i, sub)
| Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
- (instr_cons i.desc (subst_regs i.arg sub) [||] i.next,
- None)
+ kont (instr_cons i.desc (subst_regs i.arg sub) [||] i.next,
+ None)
| Iop Ireload when i.res.(0).loc = Unknown ->
begin match sub with
- None -> rename i.next sub
+ None -> rename i.next sub kont
| Some s ->
let oldr = i.res.(0) in
let newr = Reg.clone i.res.(0) in
- let (new_next, sub_next) =
- rename i.next (Some(Reg.Map.add oldr newr s)) in
- (instr_cons i.desc i.arg [|newr|] new_next,
- sub_next)
+ rename i.next (Some(Reg.Map.add oldr newr s))
+ (fun (new_next, sub_next) ->
+ kont (instr_cons i.desc i.arg [|newr|] new_next, sub_next))
end
| Iop _ ->
- let (new_next, sub_next) = rename i.next sub in
- (instr_cons_debug i.desc (subst_regs i.arg sub) (subst_regs i.res sub)
- i.dbg new_next,
- sub_next)
+ rename i.next sub (fun (new_next, sub_next) ->
+ kont (instr_cons_debug i.desc (subst_regs i.arg sub)
+ (subst_regs i.res sub) i.dbg new_next, sub_next))
| Iifthenelse(tst, ifso, ifnot) ->
- let (new_ifso, sub_ifso) = rename ifso sub in
- let (new_ifnot, sub_ifnot) = rename ifnot sub in
- let (new_next, sub_next) =
- rename i.next (merge_substs sub_ifso sub_ifnot i.next) in
- (instr_cons (Iifthenelse(tst, new_ifso, new_ifnot))
- (subst_regs i.arg sub) [||] new_next,
- sub_next)
+ rename ifso sub (fun (new_ifso, sub_ifso) ->
+ rename ifnot sub (fun (new_ifnot, sub_ifnot) ->
+ rename i.next (merge_substs sub_ifso sub_ifnot i.next)
+ (fun (new_next, sub_next) ->
+ kont (instr_cons (Iifthenelse(tst, new_ifso, new_ifnot))
+ (subst_regs i.arg sub) [||] new_next, sub_next))))
| Iswitch(index, cases) ->
- let new_sub_cases = Array.map (fun c -> rename c sub) cases in
+ let rec map cases kont = match cases with
+ | [] -> kont []
+ | case :: rest ->
+ rename case sub (fun x ->
+ map rest (fun y ->
+ kont (x :: y)))
+ in
+ map (Array.to_list cases) (fun new_sub_cases_lst ->
+ let new_sub_cases = Array.of_list new_sub_cases_lst in
let sub_merge =
- merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next in
- let (new_next, sub_next) = rename i.next sub_merge in
- (instr_cons (Iswitch(index, Array.map (fun (n, s) -> n) new_sub_cases))
- (subst_regs i.arg sub) [||] new_next,
- sub_next)
+ merge_subst_array (Array.map (fun (n, s) -> s) new_sub_cases) i.next
+ in
+ rename i.next sub_merge (fun (new_next, sub_next) ->
+ kont (instr_cons (Iswitch(index,Array.map (fun (n,s) -> n) new_sub_cases))
+ (subst_regs i.arg sub) [||] new_next, sub_next)))
| Iloop(body) ->
- let (new_body, sub_body) = rename body sub in
- let (new_next, sub_next) = rename i.next (merge_substs sub sub_body i) in
- (instr_cons (Iloop(new_body)) [||] [||] new_next,
- sub_next)
+ rename body sub (fun (new_body, sub_body) ->
+ rename i.next (merge_substs sub sub_body i) (fun (new_next, sub_next) ->
+ kont (instr_cons (Iloop(new_body)) [||] [||] new_next, sub_next)))
| Icatch(nfail, body, handler) ->
let new_subst = ref None in
exit_subst := (nfail, new_subst) :: !exit_subst ;
- let (new_body, sub_body) = rename body sub in
+ rename body sub (fun (new_body, sub_body) ->
let sub_entry_handler = !new_subst in
exit_subst := List.tl !exit_subst;
- let (new_handler, sub_handler) = rename handler sub_entry_handler in
- let (new_next, sub_next) =
- rename i.next (merge_substs sub_body sub_handler i.next) in
- (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||] new_next,
- sub_next)
+ rename handler sub_entry_handler (fun (new_handler, sub_handler) ->
+ rename i.next (merge_substs sub_body sub_handler i.next)
+ (fun (new_next, sub_next) ->
+ kont (instr_cons (Icatch(nfail, new_body, new_handler)) [||] [||]
+ new_next, sub_next))))
| Iexit nfail ->
let r = find_exit_subst nfail in
r := merge_substs !r sub i;
- (i, None)
+ kont (i, None)
| Itrywith(body, handler) ->
- let (new_body, sub_body) = rename body sub in
- let (new_handler, sub_handler) = rename handler sub in
- let (new_next, sub_next) =
- rename i.next (merge_substs sub_body sub_handler i.next) in
- (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next,
- sub_next)
+ rename body sub (fun (new_body, sub_body) ->
+ rename handler sub (fun (new_handler, sub_handler) ->
+ rename i.next (merge_substs sub_body sub_handler i.next)
+ (fun (new_next, sub_next) ->
+ kont (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next,
+ sub_next))))
| Iraise ->
- (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next,
- None)
+ kont (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next,
+ None)
(* Second pass: replace registers by their final representatives *)
@@ -200,7 +204,7 @@
let fundecl f =
equiv_classes := Reg.Map.empty;
let new_args = Array.copy f.fun_args in
- let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in
+ rename f.fun_body (Some Reg.Map.empty) (fun (new_body, sub_body) ->
repres_regs new_args;
set_repres new_body;
equiv_classes := Reg.Map.empty;
@@ -208,4 +212,4 @@
fun_args = new_args;
fun_body = new_body;
fun_fast = f.fun_fast;
- fun_dbg = f.fun_dbg }
+ fun_dbg = f.fun_dbg })
| |||||||||||
 Relationships |
|||||||||||||||||||||
|
|||||||||||||||||||||
 Relationships |
|
Notes |
|
|
(0008857) gasche (developer) 2013-02-18 11:31 |
This is an instance of the well-known issue of "compiler code not being tail-recursive". Marking "resolved > suspended" as this is extremely low-priority. The advice for now is to fix code generators to avoid too deep nestings, or contribute patches that solve the issue without degrading code readability (not necessarily easy). |
|
(0008890) bvaugon (reporter) 2013-02-22 18:51 |
To solve your compilation problems, I wrote two patches on OCaml 4.00.1 distribution: * long-bytecode.diff: it makes possible to compile programs like yours in bytecode on 32 bits architectures (without Invalid_argument("String.create")). It uses string arrays instead of strings to store bytecode at compile time and link time. * tailrec-asmcomp.diff: it makes possible to compile programs like yours in native code (without StackOverflow). It is just a tail recursive version of the ocamlopt assembler generator using continuation passing style. The source code size and readability are not very degradated, and compilation performances seems to be similar. |
|
(0008934) smimram (reporter) 2013-02-28 11:11 |
Hi, Would it be possible to reopen this bug so that Benoit's patches are reviewed (and hopefully integrated)? It is quite important, when developping a library, to know that OCaml can reliably used as a target language and that the work won't have to be done again in C (or some other language whose compiler does not have stack overflows)... Thanks! |
|
(0008936) gasche (developer) 2013-02-28 13:57 edited on: 2013-02-28 13:58 |
I had a look at Benoît's patches, but thanks for the ping, I had forgotten to add some feedback here. The long-bytecode patch is short and self-contained. I'm wondering what the performance implications of such a change are (my first reaction was: if it's so simple, why don't we define strings in this way in the standard library?). Besides this unknown (Benoît, if you have data on this, do not hesitate to share), it suffers from the problem of only making sense on 32 bits architecture, which makes it quite hard to convince maintainers that it's worth the (even small) increase in code size. The other patch is a typical example of the easy and boring transformation that *does* hurt readability, and is also relatively invasive. My strictly personal dream is that, someday, we have a reliable monadic notation for OCaml (or a syntax extension mechanism for that that I could use on the compiler itself without getting killed), and *that* would make the CPS version readable and reasonable to use. It's not the case for now. I'm keeping the bug "resolved > suspended" (means: meh, we probably won't do anything) for now. It's good that the patches are here so that users that really need them can consider using them, but I would still advise you to fix the code generator for now. Sorry. |
|
(0008939) smimram (reporter) 2013-03-01 09:14 |
Thanks for your answer! I personally find the CPS quite readable, but I guess there is very little I can argue about style... |
|
(0009155) gasche (developer) 2013-04-17 11:12 |
Small update: with help/review from chetsky in PR#5957, I commited the long-bytecode patch. This unfortunately will not alone resolve the issue at hand, but may help with similar code-generation settings -- and affected human users as well. Thanks, Benoît, for your patch! |
|
Notes |
|
Issue History |
|||
| Date Modified | Username | Field | Change |
| 2013-02-18 10:08 | smimram | New Issue | |
| 2013-02-18 10:08 | smimram | File Added: br.ml | |
| 2013-02-18 11:27 | gasche | Relationship added | related to 0005626 |
| 2013-02-18 11:27 | gasche | Relationship added | related to 0004405 |
| 2013-02-18 11:28 | gasche | Relationship added | parent of 0005844 |
| 2013-02-18 11:28 | gasche | Relationship deleted | parent of 0005844 |
| 2013-02-18 11:28 | gasche | Relationship added | related to 0005844 |
| 2013-02-18 11:31 | gasche | Note Added: 0008857 | |
| 2013-02-18 11:31 | gasche | Status | new => resolved |
| 2013-02-18 11:31 | gasche | Resolution | open => suspended |
| 2013-02-18 11:31 | gasche | Assigned To | => gasche |
| 2013-02-22 18:51 | bvaugon | Note Added: 0008890 | |
| 2013-02-22 18:51 | bvaugon | File Added: long-bytecode.diff | |
| 2013-02-22 18:51 | bvaugon | File Added: tailrec-asmcomp.diff | |
| 2013-02-28 11:11 | smimram | Note Added: 0008934 | |
| 2013-02-28 13:57 | gasche | Note Added: 0008936 | |
| 2013-02-28 13:58 | gasche | Note Edited: 0008936 | View Revisions |
| 2013-03-01 09:14 | smimram | Note Added: 0008939 | |
| 2013-03-17 17:26 | gasche | Relationship added | related to 0005920 |
| 2013-03-21 22:04 | gasche | Relationship added | has duplicate 0005957 |
| 2013-03-21 22:04 | gasche | Relationship deleted | has duplicate 0005957 |
| 2013-04-17 11:12 | gasche | Note Added: 0009155 | |
|
Issue History |
| Copyright © 2000 - 2011 MantisBT Group |
 |