diff --git a/CHANGES.md b/CHANGES.md index 1709deba06..2df2d8b848 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,7 +2,7 @@ ## Features/Changes * Misc: bump min ocaml version to 4.08 * Misc: remove some old runtime files to support some external libs -* Effects: improved CPS transform, resulting in lower compilation time and smaller generated code +* Effects: partial CPS transformation, resulting in much better performances, lower compilation time and smaller generated code * Compiler: separate compilation can now drops unused units when linking (similar to ocamlc). (#1378) Feature is disabled by default while dune rules are being fixed. Enable with --enable=auto-link. * Compiler: specialize string to js-string conversion for all valid utf8 strings (previously just ascii) diff --git a/benchmarks/Makefile b/benchmarks/Makefile index 368d733a52..b589dc0906 100644 --- a/benchmarks/Makefile +++ b/benchmarks/Makefile @@ -158,7 +158,7 @@ time-effects.svg: __run_effects -omit minesweeper \ -omit planet \ -omit ocamlc \ - -max 5 -svg 7 400 150 -edgecaption -ylabel "Execution time" \ + -min 0.5 -max 1.5 -svg 7 400 150 -edgecaption -ylabel "Execution time" \ > $@ size-effects.svg: __run_effects @@ -175,7 +175,7 @@ size-effects.svg: __run_effects -append planet \ -append js_of_ocaml \ -append ocamlc \ - -max 2 -svg 7 650 150 -edgecaption -ylabel Size \ + -min 0.8 -max 1.25 -svg 7 650 150 -edgecaption -ylabel Size \ > $@ size-gzipped-effects.svg: __run_effects diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 18505805e7..8d0238fd47 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -107,6 +107,8 @@ module Var : sig val set : 'a t -> key -> 'a -> unit val make : size -> 'a -> 'a t + + val iter : (key -> 'a -> unit) -> 'a t -> unit end module ISet : sig @@ -213,6 +215,11 @@ end = struct let set t x v = t.(x) <- v let make () v = Array.make (count ()) v + + let iter f t = + for i = 0 to Array.length t - 1 do + f i t.(i) + done end module ISet = struct @@ -633,6 +640,25 @@ let rec preorder_traverse' { fold } f pc visited blocks acc = let preorder_traverse fold f pc blocks acc = snd (preorder_traverse' fold f pc Addr.Set.empty blocks acc) +let fold_closures_innermost_first { start; blocks; _ } f accu = + let rec visit blocks pc f accu = + traverse + { fold = fold_children } + (fun pc accu -> + let block = Addr.Map.find pc blocks in + List.fold_left block.body ~init:accu ~f:(fun accu i -> + match i with + | Let (x, Closure (params, cont)) -> + let accu = visit blocks (fst cont) f accu in + f (Some x) params cont accu + | _ -> accu)) + pc + blocks + accu + in + let accu = visit blocks start f accu in + f None [] (start, []) accu + let eq p1 p2 = p1.start = p2.start && Addr.Map.cardinal p1.blocks = Addr.Map.cardinal p2.blocks diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index cdd27b6cba..bfad289662 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -100,6 +100,8 @@ module Var : sig val set : 'a t -> key -> 'a -> unit val make : size -> 'a -> 'a t + + val iter : (key -> 'a -> unit) -> 'a t -> unit end module ISet : sig @@ -231,6 +233,9 @@ type fold_blocs_poly = { fold : 'a. 'a fold_blocs } [@@unboxed] val fold_closures : program -> (Var.t option -> Var.t list -> cont -> 'd -> 'd) -> 'd -> 'd +val fold_closures_innermost_first : + program -> (Var.t option -> Var.t list -> cont -> 'd -> 'd) -> 'd -> 'd + val fold_children : 'c fold_blocs val traverse : diff --git a/compiler/lib/dgraph.ml b/compiler/lib/dgraph.ml index a2db00119a..6834620095 100644 --- a/compiler/lib/dgraph.ml +++ b/compiler/lib/dgraph.ml @@ -58,22 +58,22 @@ struct let m = ref 0 - type stack = - { stack : N.t Stack.t + type queue = + { queue : N.t Queue.t ; mutable set : NSet.t } - let is_empty st = Stack.is_empty st.stack + let is_empty st = Queue.is_empty st.queue let pop st = - let x = Stack.pop st.stack in + let x = Queue.pop st.queue in st.set <- NSet.remove x st.set; x let push x st = if not (NSet.mem x st.set) then ( - Stack.push x st.stack; + Queue.push x st.queue; st.set <- NSet.add x st.set) let rec iterate g f v w = @@ -91,24 +91,26 @@ struct iterate g f v w) else iterate g f v w - let rec traverse g visited stack x = + let rec traverse g visited lst x = if not (NSet.mem x visited) then ( let visited = NSet.add x visited in let visited = - g.fold_children (fun y visited -> traverse g visited stack y) x visited + g.fold_children (fun y visited -> traverse g visited lst y) x visited in - Stack.push x stack; + lst := x :: !lst; visited) else visited let traverse_all g = - let stack = Stack.create () in + let lst = ref [] in let visited = - NSet.fold (fun x visited -> traverse g visited stack x) g.domain NSet.empty + NSet.fold (fun x visited -> traverse g visited lst x) g.domain NSet.empty in assert (NSet.equal g.domain visited); - stack + let queue = Queue.create () in + List.iter ~f:(fun x -> Queue.push x queue) !lst; + queue let f g f = n := 0; @@ -128,7 +130,7 @@ let t1 = Timer.make () in let t1 = Timer.get t1 in let t2 = Timer.make () in *) - let w = { set = g.domain; stack = traverse_all g } in + let w = { set = g.domain; queue = traverse_all g } in (* let t2 = Timer.get t2 in let t3 = Timer.make () in @@ -206,54 +208,55 @@ struct let m = ref 0 - type stack = - { stack : N.t Stack.t + type queue = + { queue : N.t Queue.t ; set : NSet.t } - let is_empty st = Stack.is_empty st.stack + let is_empty st = Queue.is_empty st.queue let pop st = - let x = Stack.pop st.stack in + let x = Queue.pop st.queue in NSet.add st.set x; x let push x st = if NSet.mem st.set x then ( - Stack.push x st.stack; + Queue.push x st.queue; NSet.remove st.set x) - let rec iterate g f v w = + let rec iterate g ~update f v w = if is_empty w then v else let x = pop w in let a = NTbl.get v x in incr m; - let b = f v x in - NTbl.set v x b; + let b = f ~update v x in if not (D.equal a b) then ( - g.iter_children (fun y -> push y w) x; - iterate g f v w) - else iterate g f v w + NTbl.set v x b; + g.iter_children (fun y -> push y w) x); + iterate g ~update f v w - let rec traverse g to_visit stack x = + let rec traverse g to_visit lst x = if NSet.mem to_visit x then ( NSet.remove to_visit x; incr n; - g.iter_children (fun y -> traverse g to_visit stack y) x; - Stack.push x stack) + g.iter_children (fun y -> traverse g to_visit lst y) x; + lst := x :: !lst) let traverse_all g = - let stack = Stack.create () in + let lst = ref [] in let to_visit = NSet.copy g.domain in - NSet.iter (fun x -> traverse g to_visit stack x) g.domain; - { stack; set = to_visit } + NSet.iter (fun x -> traverse g to_visit lst x) g.domain; + let queue = Queue.create () in + List.iter ~f:(fun x -> Queue.push x queue) !lst; + { queue; set = to_visit } - let f size g f = + let f' size g f = n := 0; m := 0; (* @@ -269,12 +272,17 @@ let t2 = Timer.make () in let t2 = Timer.get t2 in let t3 = Timer.make () in *) - let res = iterate g f v w in + let update ~children x = + if children then g.iter_children (fun y -> push y w) x else push x w + in + let res = iterate g ~update f v w in (* let t3 = Timer.get t3 in Format.eprintf "YYY %.2f %.2f %.2f@." t1 t2 t3; Format.eprintf "YYY %d %d (%f)@." !m !n (float !m /. float !n); *) res + + let f size g f = f' size g (fun ~update:_ v x -> f v x) end end diff --git a/compiler/lib/dgraph.mli b/compiler/lib/dgraph.mli index 424f2e2c81..337569f3ae 100644 --- a/compiler/lib/dgraph.mli +++ b/compiler/lib/dgraph.mli @@ -94,5 +94,11 @@ end) module Solver (D : DOMAIN) : sig val f : NTbl.size -> t -> (D.t NTbl.t -> N.t -> D.t) -> D.t NTbl.t + + val f' : + NTbl.size + -> t + -> (update:(children:bool -> N.t -> unit) -> D.t NTbl.t -> N.t -> D.t) + -> D.t NTbl.t end end diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index bc78dff46f..36ccaa0b87 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -28,11 +28,8 @@ let should_export = function | `Named _ | `Anonymous -> true let tailcall p = - if Config.Flag.effects () - then p - else ( - if debug () then Format.eprintf "Tail-call optimization...@."; - Tailcall.f p) + if debug () then Format.eprintf "Tail-call optimization...@."; + Tailcall.f p let deadcode' p = if debug () then Format.eprintf "Dead-code...@."; @@ -83,19 +80,21 @@ let phi p = if debug () then Format.eprintf "Variable passing simplification...@."; Phisimpl.f p +let ( +> ) f g x = g (f x) + +let map_fst f (x, y) = f x, y + let effects p = if Config.Flag.effects () then ( if debug () then Format.eprintf "Effects...@."; - Deadcode.f p |> Effects.f |> Lambda_lifting.f) - else p + p |> Deadcode.f +> Effects.f +> map_fst Lambda_lifting.f) + else p, (Code.Var.Set.empty : Effects.cps_calls) let print p = if debug () then Code.Print.program (fun _ _ -> "") p; p -let ( +> ) f g x = g (f x) - let rec loop max name round i (p : 'a) : 'a = let p' = round p in if i >= max || Code.eq p' p @@ -154,10 +153,22 @@ let round2 = flow +> specialize' +> eval +> deadcode +> o1 let o3 = loop 10 "tailcall+inline" round1 1 +> loop 10 "flow" round2 1 +> print -let generate d ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect (p, live_vars) = +let generate + d + ~exported_runtime + ~wrap_with_fun + ~warn_on_unhandled_effect + ((p, live_vars), cps_calls) = if times () then Format.eprintf "Start Generation...@."; let should_export = should_export wrap_with_fun in - Generate.f p ~exported_runtime ~live_vars ~should_export ~warn_on_unhandled_effect d + Generate.f + p + ~exported_runtime + ~live_vars + ~cps_calls + ~should_export + ~warn_on_unhandled_effect + d let header formatter ~custom_header = match custom_header with @@ -553,7 +564,9 @@ let full d p = let exported_runtime = not standalone in - let opt = specialize_js_once +> profile +> effects +> Generate_closure.f +> deadcode' in + let opt = + specialize_js_once +> profile +> effects +> map_fst (Generate_closure.f +> deadcode') + in let emit = generate d ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect:standalone +> link ~standalone ~linkall diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 0de564b4dc..55002610c0 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -51,7 +51,9 @@ let reverse_graph g = type control_flow_graph = { succs : (Addr.t, Addr.Set.t) Hashtbl.t + ; preds : (Addr.t, Addr.Set.t) Hashtbl.t ; reverse_post_order : Addr.t list + ; block_order : (Addr.t, int) Hashtbl.t } let build_graph blocks pc = @@ -68,19 +70,20 @@ let build_graph blocks pc = l := pc :: !l) in traverse pc; - { succs; reverse_post_order = !l } + let block_order = Hashtbl.create 16 in + List.iteri !l ~f:(fun i pc -> Hashtbl.add block_order pc i); + let preds = reverse_graph succs in + { succs; preds; reverse_post_order = !l; block_order } let dominator_tree g = (* A Simple, Fast Dominance Algorithm Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy *) let dom = Hashtbl.create 16 in - let order = Hashtbl.create 16 in - List.iteri g.reverse_post_order ~f:(fun i pc -> Hashtbl.add order pc i); let rec inter pc pc' = (* Compute closest common ancestor *) if pc = pc' then pc - else if Hashtbl.find order pc < Hashtbl.find order pc' + else if Hashtbl.find g.block_order pc < Hashtbl.find g.block_order pc' then inter pc (Hashtbl.find dom pc') else inter (Hashtbl.find dom pc) pc' in @@ -101,8 +104,25 @@ let dominator_tree g = l); dom +(* pc dominates pc' *) +let rec dominates g idom pc pc' = + pc = pc' + || Hashtbl.find g.block_order pc < Hashtbl.find g.block_order pc' + && dominates g idom pc (Hashtbl.find idom pc') + +(* pc has at least two forward edges moving into it *) +let is_merge_node g pc = + let s = try Hashtbl.find g.preds pc with Not_found -> assert false in + let o = Hashtbl.find g.block_order pc in + let n = + Addr.Set.fold + (fun pc' n -> if Hashtbl.find g.block_order pc' < o then n + 1 else n) + s + 0 + in + n > 1 + let dominance_frontier g idom = - let preds = reverse_graph g.succs in let frontiers = Hashtbl.create 16 in Hashtbl.iter (fun pc preds -> @@ -116,7 +136,7 @@ let dominance_frontier g idom = loop (Hashtbl.find idom runner)) in Addr.Set.iter loop preds) - preds; + g.preds; frontiers (****) @@ -127,7 +147,7 @@ also mark blocks that correspond to function continuations or exception handlers. And we keep track of the exception handler associated to each Poptrap, and possibly Raise. *) -let compute_needed_transformations ~cfg ~idom ~blocks ~start = +let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start = let frontiers = dominance_frontier cfg idom in let transformation_needed = ref Addr.Set.empty in let matching_exn_handler = Hashtbl.create 16 in @@ -160,9 +180,10 @@ let compute_needed_transformations ~cfg ~idom ~blocks ~start = | Some (Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _)))) - -> - (* The block after a function application or an effect - primitive needs to be transformed. *) + when Var.Set.mem x cps_needed -> + (* The block after a function application that needs to + be turned to CPS or an effect primitive needs to be + transformed. *) mark_needed dst; (* We need to transform the englobing exception handlers as well *) @@ -225,15 +246,23 @@ let jump_closures blocks_to_transform idom : jump_closures = idom { closure_of_jump = Addr.Map.empty; closures_of_alloc_site = Addr.Map.empty } +type cps_calls = Var.Set.t + type st = { mutable new_blocks : Code.block Addr.Map.t * Code.Addr.t ; blocks : Code.block Addr.Map.t + ; cfg : control_flow_graph + ; idom : (int, int) Hashtbl.t ; jc : jump_closures - ; closure_continuation : Addr.t -> Var.t + ; closure_info : (Addr.t, Var.t * Code.cont) Hashtbl.t + ; cps_needed : Var.Set.t ; blocks_to_transform : Addr.Set.t ; is_continuation : (Addr.t, [ `Param of Var.t | `Loop ]) Hashtbl.t ; matching_exn_handler : (Addr.t, Addr.t) Hashtbl.t + ; block_order : (Addr.t, int) Hashtbl.t ; live_vars : Deadcode.variable_uses + ; flow_info : Global_flow.info + ; cps_calls : cps_calls ref } let add_block st block = @@ -244,17 +273,19 @@ let add_block st block = let closure_of_pc ~st pc = try Addr.Map.find pc st.jc.closure_of_jump with Not_found -> assert false -let allocate_closure ~st ~params ~body:(body, branch) = +let allocate_closure ~st ~params ~body ~branch = let block = { params = []; body; branch } in let pc = add_block st block in let name = Var.fresh () in [ Let (name, Closure (params, (pc, []))) ], name -let tail_call ?(instrs = []) ~exact ~f args = +let tail_call ~st ?(instrs = []) ~exact ~check ~f args = + assert (exact || check); let ret = Var.fresh () in + if check then st.cps_calls := Var.Set.add ret !(st.cps_calls); instrs @ [ Let (ret, Apply { f; args; exact }) ], Return ret -let cps_branch ~st (pc, args) = +let cps_branch ~st ~src (pc, args) = match Addr.Set.mem pc st.blocks_to_transform with | false -> [], Branch (pc, args) | true -> @@ -267,22 +298,74 @@ let cps_branch ~st (pc, args) = [ x ], [ Let (x, Constant (Int 0l)) ] else args, [] in - tail_call ~instrs ~exact:true ~f:(closure_of_pc ~st pc) args + (* We check the stack depth only for backward edges (so, at + least once per loop iteration) *) + let check = Hashtbl.find st.block_order src >= Hashtbl.find st.block_order pc in + tail_call ~st ~instrs ~exact:true ~check ~f:(closure_of_pc ~st pc) args -let cps_jump_cont ~st ((pc, _) as cont) = +let cps_jump_cont ~st ~src ((pc, _) as cont) = match Addr.Set.mem pc st.blocks_to_transform with | false -> cont | true -> let call_block = - let body, branch = cps_branch ~st cont in + let body, branch = cps_branch ~st ~src cont in add_block st { params = []; body; branch } in call_block, [] -let cps_last ~st pc (last : last) ~k : instr list * last = +let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = + (* We need to allocate an additional closure if [cont] + does not correspond to a continuation that binds [x]. + This closure binds the return value [x], allocates + closures for dominated blocks and jumps to the next + block. When entering a loop, we also have to allocate a + closure to bind [x] if it is used in the loop body. In + other cases, we can just pass the closure corresponding + to the next block. *) + let pc', args = cont in + if (match args with + | [] -> true + | [ x' ] -> Var.equal x x' + | _ -> false) + && + match Hashtbl.find st.is_continuation pc' with + | `Param _ -> true + | `Loop -> st.live_vars.(Var.idx x) = List.length args + then alloc_jump_closures, closure_of_pc ~st pc' + else + let body, branch = cps_branch ~st ~src:pc cont in + let inner_closures, outer_closures = + (* For [Pushtrap], we need to separate the closures + corresponding to the exception handler body (that may make + use of [x]) from the other closures that may be used outside + of the exception handler. *) + if not split_closures + then alloc_jump_closures, [] + else if is_merge_node st.cfg pc' + then [], alloc_jump_closures + else + List.partition + ~f:(fun i -> + match i with + | Let (_, Closure (_, (pc'', []))) -> dominates st.cfg st.idom pc' pc'' + | _ -> assert false) + alloc_jump_closures + in + let body, branch = + allocate_closure ~st ~params:[ x ] ~body:(inner_closures @ body) ~branch + in + outer_closures @ body, branch + +let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = match last with - | Return x -> tail_call ~exact:true ~f:k [ x ] + | Return x -> + assert (List.is_empty alloc_jump_closures); + (* Is the number of successive 'returns' is unbounded is CPS, it + means that we have an unbounded of calls in direct style + (even with tail call optimization) *) + tail_call ~st ~exact:true ~check:false ~f:k [ x ] | Raise (x, _) -> ( + assert (List.is_empty alloc_jump_closures); match Hashtbl.find_opt st.matching_exn_handler pc with | Some pc when not (Addr.Set.mem pc st.blocks_to_transform) -> (* We are within a try ... with which is not @@ -291,44 +374,65 @@ let cps_last ~st pc (last : last) ~k : instr list * last = | _ -> let exn_handler = Var.fresh_n "raise" in tail_call + ~st ~instrs:[ Let (exn_handler, Prim (Extern "caml_pop_trap", [])) ] ~exact:true + ~check:false ~f:exn_handler [ x ]) - | Stop -> [], Stop - | Branch cont -> cps_branch ~st cont + | Stop -> + assert (List.is_empty alloc_jump_closures); + [], Stop + | Branch cont -> + let body, branch = cps_branch ~st ~src:pc cont in + alloc_jump_closures @ body, branch | Cond (x, cont1, cont2) -> - [], Cond (x, cps_jump_cont ~st cont1, cps_jump_cont ~st cont2) + ( alloc_jump_closures + , Cond (x, cps_jump_cont ~st ~src:pc cont1, cps_jump_cont ~st ~src:pc cont2) ) | Switch (x, c1, c2) -> (* To avoid code duplication during JavaScript generation, we need to create a single block per continuation *) - let cps_jump_cont = Fun.memoize (cps_jump_cont ~st) in - [], Switch (x, Array.map c1 ~f:cps_jump_cont, Array.map c2 ~f:cps_jump_cont) - | Pushtrap ((pc, args), _, (handler_pc, _), _) -> ( + let cps_jump_cont = Fun.memoize (cps_jump_cont ~st ~src:pc) in + ( alloc_jump_closures + , Switch (x, Array.map c1 ~f:cps_jump_cont, Array.map c2 ~f:cps_jump_cont) ) + | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont), _) -> ( assert (Hashtbl.mem st.is_continuation handler_pc); match Addr.Set.mem handler_pc st.blocks_to_transform with - | false -> [], last + | false -> alloc_jump_closures, last | true -> - let exn_handler = closure_of_pc ~st handler_pc in + let constr_cont, exn_handler = + allocate_continuation + ~st + ~alloc_jump_closures + ~split_closures:true + pc + exn + handler_cont + in let push_trap = Let (Var.fresh (), Prim (Extern "caml_push_trap", [ Pv exn_handler ])) in - let body, branch = cps_branch ~st (pc, args) in - push_trap :: body, branch) - | Poptrap (pc', args) -> ( + let body, branch = cps_branch ~st ~src:pc body_cont in + constr_cont @ (push_trap :: body), branch) + | Poptrap cont -> ( match Addr.Set.mem (Hashtbl.find st.matching_exn_handler pc) st.blocks_to_transform with - | false -> [], Poptrap (cps_jump_cont ~st (pc', args)) + | false -> alloc_jump_closures, Poptrap (cps_jump_cont ~st ~src:pc cont) | true -> let exn_handler = Var.fresh () in - let body, branch = cps_branch ~st (pc', args) in - Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body, branch) + let body, branch = cps_branch ~st ~src:pc cont in + ( alloc_jump_closures + @ (Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body) + , branch )) let cps_instr ~st (instr : instr) : instr = match instr with - | Let (x, Closure (params, (pc, args))) -> - Let (x, Closure (params @ [ st.closure_continuation pc ], (pc, args))) + | Let (x, Closure (params, (pc, _))) when Var.Set.mem x st.cps_needed -> + (* Add the continuation parameter, and change the initial block if + needed *) + let k, cont = Hashtbl.find st.closure_info pc in + Let (x, Closure (params @ [ k ], cont)) | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with | Pc (Int a) -> @@ -337,6 +441,11 @@ let cps_instr ~st (instr : instr) : instr = , Prim (Extern "caml_alloc_dummy_function", [ size; Pc (Int (Int32.succ a)) ]) ) | _ -> assert false) + | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> + (* At the moment, we turn into CPS any function not called with + the right number of parameter *) + assert (Global_flow.exact_call st.flow_info f (List.length args)); + Let (x, Apply { f; args; exact = true }) | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> assert false | _ -> instr @@ -375,7 +484,7 @@ let cps_block ~st ~k pc block = | exception Not_found -> [] in - let rewrite_instr e = + let rewrite_instr x e = let perform_effect ~effect ~continuation = Some (fun ~k -> @@ -386,14 +495,22 @@ let cps_block ~st ~k pc block = [ Let (x, e) ], Return x) in match e with - | Apply { f; args; exact } -> Some (fun ~k -> tail_call ~exact ~f (args @ [ k ])) + | Apply { f; args; exact } when Var.Set.mem x st.cps_needed -> + Some + (fun ~k -> + let exact = + exact || Global_flow.exact_call st.flow_info f (List.length args) + in + tail_call ~st ~exact ~check:true ~f (args @ [ k ])) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> Some (fun ~k -> let k' = Var.fresh_n "cont" in tail_call + ~st ~instrs:[ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; Pv k ])) ] - ~exact:false + ~exact:(Global_flow.exact_call st.flow_info f 1) + ~check:true ~f [ arg; k' ]) | Prim (Extern "%perform", [ Pv effect ]) -> @@ -406,49 +523,24 @@ let cps_block ~st ~k pc block = let rewritten_block = match List.split_last block.body, block.branch with | Some (body_prefix, Let (x, e)), Return ret -> - Option.map (rewrite_instr e) ~f:(fun f -> + Option.map (rewrite_instr x e) ~f:(fun f -> assert (List.is_empty alloc_jump_closures); assert (Var.equal x ret); let instrs, branch = f ~k in body_prefix, instrs, branch) | Some (body_prefix, Let (x, e)), Branch cont -> - let allocate_continuation f = - let constr_cont, k' = - (* Construct continuation: it binds the return value [x], - allocates closures for dominated blocks and jumps to the - next block. *) - let pc, args = cont in - let f' = closure_of_pc ~st pc in - assert (Hashtbl.mem st.is_continuation pc); - match args with - | [] - when match Hashtbl.find st.is_continuation pc with - | `Param _ -> true - | `Loop -> st.live_vars.(Var.idx x) = 0 -> - (* When entering a loop, we have to allocate a closure - to bind [x] if it is used in the loop body. In - other cases, we can just call the continuation. *) - alloc_jump_closures, f' - | [ x' ] when Var.equal x x' -> alloc_jump_closures, f' - | _ -> - let args, instrs = - if List.is_empty args - then - (* We use a dummy argument since the continuation - expects at least one argument. *) - let x = Var.fresh () in - [ x ], alloc_jump_closures @ [ Let (x, Constant (Int 0l)) ] - else args, alloc_jump_closures - in - allocate_closure - ~st - ~params:[ x ] - ~body:(tail_call ~instrs ~exact:true ~f:f' args) - in - let instrs, branch = f ~k:k' in - body_prefix, constr_cont @ instrs, branch - in - Option.map (rewrite_instr e) ~f:allocate_continuation + Option.map (rewrite_instr x e) ~f:(fun f -> + let constr_cont, k' = + allocate_continuation + ~st + ~alloc_jump_closures + ~split_closures:false + pc + x + cont + in + let instrs, branch = f ~k:k' in + body_prefix, constr_cont @ instrs, branch) | Some (_, (Set_field _ | Offset_ref _ | Array_set _ | Assign _)), _ | Some _, (Raise _ | Stop | Cond _ | Switch _ | Pushtrap _ | Poptrap _) | None, _ -> None @@ -459,12 +551,8 @@ let cps_block ~st ~k pc block = | Some (body_prefix, last_instrs, last) -> List.map body_prefix ~f:(fun i -> cps_instr ~st i) @ last_instrs, last | None -> - let last_instrs, last = cps_last ~st pc block.branch ~k in - let body = - List.map block.body ~f:(fun i -> cps_instr ~st i) - @ alloc_jump_closures - @ last_instrs - in + let last_instrs, last = cps_last ~st ~alloc_jump_closures pc block.branch ~k in + let body = List.map block.body ~f:(fun i -> cps_instr ~st i) @ last_instrs in body, last in @@ -473,50 +561,78 @@ let cps_block ~st ~k pc block = ; branch = last } -let cps_transform ~live_vars p = - let closure_continuation = - (* Provide a name for the continuation of a closure (before CPS - transform), which can be referred from all the blocks it contains *) - let tbl = Hashtbl.create 4 in - fun pc -> - try Hashtbl.find tbl pc - with Not_found -> - let k = Var.fresh_n "cont" in - Hashtbl.add tbl pc k; - k - in - let wrap_toplevel = ref true in +let cps_transform ~live_vars ~flow_info ~cps_needed p = + let closure_info = Hashtbl.create 16 in + let cps_calls = ref Var.Set.empty in let p = - Code.fold_closures + Code.fold_closures_innermost_first p - (fun name_opt _ (start, _) ({ blocks; free_pc; _ } as p) -> - let cfg = build_graph blocks start in + (fun name_opt _ (start, args) ({ blocks; free_pc; _ } as p) -> + (* We speculatively add a block at the beginning of the + function. In case of tail-recursion optimization, the + function implementing the loop body may have to be placed + there. *) + let initial_start = start in + let start', blocks' = + ( free_pc + , Addr.Map.add + free_pc + { params = []; body = []; branch = Branch (start, args) } + blocks ) + in + let cfg = build_graph blocks' start' in let idom = dominator_tree cfg in + let should_compute_needed_transformations = + match name_opt with + | Some name -> Var.Set.mem name cps_needed + | None -> + (* We are handling the toplevel code. There may remain + some CPS calls at toplevel. *) + true + in let blocks_to_transform, matching_exn_handler, is_continuation = - compute_needed_transformations ~cfg ~idom ~blocks ~start + if should_compute_needed_transformations + then + compute_needed_transformations + ~cfg + ~idom + ~cps_needed + ~blocks:blocks' + ~start:start' + else Addr.Set.empty, Hashtbl.create 1, Hashtbl.create 1 in let closure_jc = jump_closures blocks_to_transform idom in + let start, args, blocks, free_pc = + (* Insert an initial block if needed. *) + if Addr.Map.mem start' closure_jc.closures_of_alloc_site + then start', [], blocks', free_pc + 1 + else start, args, blocks, free_pc + in let st = { new_blocks = Addr.Map.empty, free_pc ; blocks + ; cfg + ; idom ; jc = closure_jc - ; closure_continuation + ; closure_info + ; cps_needed ; blocks_to_transform ; is_continuation ; matching_exn_handler + ; block_order = cfg.block_order + ; flow_info ; live_vars + ; cps_calls } in let function_needs_cps = match name_opt with - | Some _ -> true + | Some _ -> should_compute_needed_transformations | None -> (* We are handling the toplevel code. If it performs no CPS call, we can leave it in direct style and we don't need to wrap it within a [caml_callback]. *) - let need_cps = not (Addr.Set.is_empty blocks_to_transform) in - wrap_toplevel := need_cps; - need_cps + not (Addr.Set.is_empty blocks_to_transform) in if debug () then ( @@ -526,16 +642,20 @@ let cps_transform ~live_vars p = (fun pc _ -> if Addr.Set.mem pc blocks_to_transform then Format.eprintf "CPS@."; let block = Addr.Map.find pc blocks in - Code.Print.block (fun _ _ -> "") pc block) + Code.Print.block + (fun _ xi -> Partial_cps_analysis.annot cps_needed xi) + pc + block) start blocks ()); let blocks = let transform_block = if function_needs_cps - then - let k = closure_continuation start in - fun pc block -> cps_block ~st ~k pc block + then ( + let k = Var.fresh_n "cont" in + Hashtbl.add closure_info initial_start (k, (start, args)); + fun pc block -> cps_block ~st ~k pc block) else fun _ block -> { block with body = List.map block.body ~f:(fun i -> cps_instr ~st i) } @@ -553,28 +673,31 @@ let cps_transform ~live_vars p = { p with blocks; free_pc }) p in - if not !wrap_toplevel - then p - else - (* Call [caml_callback] to set up the execution context. *) - let new_start = p.free_pc in - let blocks = - let main = Var.fresh () in - let args = Var.fresh () in - let res = Var.fresh () in - Addr.Map.add - new_start - { params = [] - ; body = - [ Let (main, Closure ([ closure_continuation p.start ], (p.start, []))) - ; Let (args, Prim (Extern "%js_array", [])) - ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])) - ] - ; branch = Return res - } - p.blocks - in - { start = new_start; blocks; free_pc = new_start + 1 } + let p = + match Hashtbl.find_opt closure_info p.start with + | None -> p + | Some (k, _) -> + (* Call [caml_callback] to set up the execution context. *) + let new_start = p.free_pc in + let blocks = + let main = Var.fresh () in + let args = Var.fresh () in + let res = Var.fresh () in + Addr.Map.add + new_start + { params = [] + ; body = + [ Let (main, Closure ([ k ], (p.start, []))) + ; Let (args, Prim (Extern "%js_array", [])) + ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])) + ] + ; branch = Return res + } + p.blocks + in + { start = new_start; blocks; free_pc = new_start + 1 } + in + p, !cps_calls (****) @@ -586,15 +709,16 @@ let current_loop_header frontiers in_loop pc = | Some header when Addr.Set.mem header frontier -> in_loop | _ -> if Addr.Set.mem pc frontier then Some pc else None -let wrap_call p x f args accu = +let wrap_call ~cps_needed p x f args accu = let arg_array = Var.fresh () in ( p + , Var.Set.remove x cps_needed , [ Let (arg_array, Prim (Extern "%js_array", List.map ~f:(fun y -> Pv y) args)) ; Let (x, Prim (Extern "caml_callback", [ Pv f; Pv arg_array ])) ] :: accu ) -let wrap_primitive (p : Code.program) x e accu = +let wrap_primitive ~cps_needed p x e accu = let f = Var.fresh () in let closure_pc = p.free_pc in ( { p with @@ -606,6 +730,7 @@ let wrap_primitive (p : Code.program) x e accu = { params = []; body = [ Let (y, e) ]; branch = Return y }) p.blocks } + , Var.Set.remove x (Var.Set.add f cps_needed) , let args = Var.fresh () in [ Let (f, Closure ([], (closure_pc, []))) ; Let (args, Prim (Extern "%js_array", [])) @@ -613,62 +738,64 @@ let wrap_primitive (p : Code.program) x e accu = ] :: accu ) -let rewrite_toplevel_instr (p, accu) instr = +let rewrite_toplevel_instr (p, cps_needed, accu) instr = match instr with - | Let (x, Apply { f; args; _ }) -> wrap_call p x f args accu + | Let (x, Apply { f; args; _ }) when Var.Set.mem x cps_needed -> + wrap_call ~cps_needed p x f args accu | Let (x, (Prim (Extern ("%resume" | "%perform" | "%reperform"), _) as e)) -> - wrap_primitive p x e accu - | _ -> p, [ instr ] :: accu + wrap_primitive ~cps_needed p x e accu + | _ -> p, cps_needed, [ instr ] :: accu (* Wrap function calls inside [caml_callback] at toplevel to avoid unncessary function nestings. This is not done inside loops since using repeatedly [caml_callback] can be costly. *) -let rewrite_toplevel p = +let rewrite_toplevel ~cps_needed p = let { start; blocks; _ } = p in let cfg = build_graph blocks start in let idom = dominator_tree cfg in let frontiers = dominance_frontier cfg idom in - let rec traverse visited (p : Code.program) in_loop pc = + let rec traverse visited (p : Code.program) cps_needed in_loop pc = if Addr.Set.mem pc visited - then visited, p + then visited, p, cps_needed else let visited = Addr.Set.add pc visited in let in_loop = current_loop_header frontiers in_loop pc in - let p = + let p, cps_needed = if Option.is_none in_loop then let block = Addr.Map.find pc p.blocks in - let p, body_rev = - List.fold_left ~f:rewrite_toplevel_instr ~init:(p, []) block.body + let p, cps_needed, body_rev = + List.fold_left ~f:rewrite_toplevel_instr ~init:(p, cps_needed, []) block.body in let body = List.concat @@ List.rev body_rev in - { p with blocks = Addr.Map.add pc { block with body } p.blocks } - else p + { p with blocks = Addr.Map.add pc { block with body } p.blocks }, cps_needed + else p, cps_needed in Code.fold_children blocks pc - (fun pc (visited, p) -> traverse visited p in_loop pc) - (visited, p) + (fun pc (visited, p, cps_needed) -> traverse visited p cps_needed in_loop pc) + (visited, p, cps_needed) in - let _, p = traverse Addr.Set.empty p None start in - p + let _, p, cps_needed = traverse Addr.Set.empty p cps_needed None start in + p, cps_needed (****) -let split_blocks (p : Code.program) = +let split_blocks ~cps_needed (p : Code.program) = (* Ensure that function applications and effect primitives are in tail position *) let split_block pc block p = let is_split_point i r branch = match i with - | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> ( - (not (List.is_empty r)) + | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + ((not (List.is_empty r)) || match branch with | Branch _ -> false | Return x' -> not (Var.equal x x') | _ -> true) + && Var.Set.mem x cps_needed | _ -> false in let rec split (p : Code.program) pc block accu l branch = @@ -755,8 +882,10 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = let f (p, live_vars) = let t = Timer.make () in let p = remove_empty_blocks ~live_vars p in - let p = split_blocks p in - let p = rewrite_toplevel p in - let p = cps_transform ~live_vars p in + let flow_info = Global_flow.f p in + let cps_needed = Partial_cps_analysis.f p flow_info in + let p, cps_needed = rewrite_toplevel ~cps_needed p in + let p = split_blocks ~cps_needed p in + let p, cps_calls = cps_transform ~live_vars ~flow_info ~cps_needed p in if Debug.find "times" () then Format.eprintf " effects: %a@." Timer.print t; - p + p, cps_calls diff --git a/compiler/lib/effects.mli b/compiler/lib/effects.mli index 253bccad4f..c4afc03e72 100644 --- a/compiler/lib/effects.mli +++ b/compiler/lib/effects.mli @@ -16,4 +16,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val f : Code.program * Deadcode.variable_uses -> Code.program +type cps_calls = Code.Var.Set.t + +val f : Code.program * Deadcode.variable_uses -> Code.program * cps_calls diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index f22f1a40a7..dc53ea2d17 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -61,15 +61,6 @@ let list_group f g l = | [] -> [] | a :: r -> list_group_rec f g r (f a) [ g a ] [] -(* like [List.map] except that it calls the function with - an additional argument to indicate whether we're mapping - over the last element of the list *) -let rec map_last f l = - match l with - | [] -> assert false - | [ x ] -> [ f true x ] - | x :: xs -> f false x :: map_last f xs - (****) type application_description = @@ -152,7 +143,12 @@ module Share = struct | Pc c -> get_constant c t | _ -> t) - let get ?alias_strings ?(alias_prims = false) ?(alias_apply = true) { blocks; _ } : t = + let get + ~cps_calls + ?alias_strings + ?(alias_prims = false) + ?(alias_apply = true) + { blocks; _ } : t = let alias_strings = match alias_strings with | None -> Config.Flag.use_js_string () && not (Config.Flag.share_constant ()) @@ -161,28 +157,11 @@ module Share = struct let count = Addr.Map.fold (fun _ block share -> - let tailcall_name = - (* Systematic tail-call optimization is only enabled when - supporting effects *) - if Config.Flag.effects () - then - match block.branch with - | Return _ -> ( - match List.last block.body with - | Some (Let (x, _)) -> Some x - | _ -> None) - | _ -> None - else None - in List.fold_left block.body ~init:share ~f:(fun share i -> match i with | Let (_, Constant c) -> get_constant c share | Let (x, Apply { args; exact; _ }) -> - let cps = - match tailcall_name with - | Some y -> Var.equal x y - | None -> false - in + let cps = Var.Set.mem x cps_calls in if (not exact) || cps then add_apply { arity = List.length args; exact; cps } share else share @@ -301,6 +280,7 @@ module Ctx = struct ; exported_runtime : (Code.Var.t * bool ref) option ; should_export : bool ; effect_warning : bool ref + ; cps_calls : Effects.cps_calls } let initial @@ -309,6 +289,7 @@ module Ctx = struct ~should_export blocks live + cps_calls share debug = { blocks @@ -318,6 +299,7 @@ module Ctx = struct ; exported_runtime ; should_export ; effect_warning = ref (not warn_on_unhandled_effect) + ; cps_calls } end @@ -1204,10 +1186,10 @@ let throw_statement ctx cx k loc = , loc ) ] -let rec translate_expr ctx queue loc in_tail_position e level : _ * J.statement_list = - let cps = in_tail_position && Config.Flag.effects () in +let rec translate_expr ctx queue loc x e level : _ * J.statement_list = match e with | Apply { f; args; exact } -> + let cps = Var.Set.mem x ctx.Ctx.cps_calls in let args, prop, queue = List.fold_right ~f:(fun x (args, prop, queue) -> @@ -1480,7 +1462,7 @@ let rec translate_expr ctx queue loc in_tail_position e level : _ * J.statement_ in res, [] -and translate_instr ctx expr_queue loc instr in_tail_position = +and translate_instr ctx expr_queue loc instr = match instr with | Assign (x, y) -> let (_py, cy), expr_queue = access_queue expr_queue y in @@ -1489,9 +1471,7 @@ and translate_instr ctx expr_queue loc instr in_tail_position = mutator_p [ J.Expression_statement (J.EBin (J.Eq, J.EVar (J.V x), cy)), loc ] | Let (x, e) -> ( - let (ce, prop, expr_queue), instrs = - translate_expr ctx expr_queue loc in_tail_position e 0 - in + let (ce, prop, expr_queue), instrs = translate_expr ctx expr_queue loc x e 0 in let keep_name x = match Code.Var.get_name x with | None -> false @@ -1555,12 +1535,7 @@ and translate_instrs ctx expr_queue loc instr last = match instr with | [] -> [], expr_queue | instr :: rem -> - let in_tail_position = - match rem, last with - | [], Return _ -> true - | _ -> false - in - let st, expr_queue = translate_instr ctx expr_queue loc instr in_tail_position in + let st, expr_queue = translate_instr ctx expr_queue loc instr in let instrs, expr_queue = translate_instrs ctx expr_queue loc rem last in st @ instrs, expr_queue @@ -1821,7 +1796,7 @@ and compile_decision_tree st loop_stack backs frontier interm loc cx dtree = let l = List.flatten (List.map l ~f:(fun (ints, br) -> - map_last (fun last i -> int i, if last then br else []) ints)) + List.map_last ~f:(fun last i -> int i, if last then br else []) ints)) in !all_never, [ J.Switch_statement (cx, l, Some last, []), loc ] in @@ -2090,11 +2065,12 @@ let f (p : Code.program) ~exported_runtime ~live_vars + ~cps_calls ~should_export ~warn_on_unhandled_effect debug = let t' = Timer.make () in - let share = Share.get ~alias_prims:exported_runtime p in + let share = Share.get ~cps_calls ~alias_prims:exported_runtime p in let exported_runtime = if exported_runtime then Some (Code.Var.fresh_n "runtime", ref false) else None in @@ -2105,6 +2081,7 @@ let f ~should_export p.blocks live_vars + cps_calls share debug in diff --git a/compiler/lib/generate.mli b/compiler/lib/generate.mli index e512270aa5..66053fdc2c 100644 --- a/compiler/lib/generate.mli +++ b/compiler/lib/generate.mli @@ -22,6 +22,7 @@ val f : Code.program -> exported_runtime:bool -> live_vars:Deadcode.variable_uses + -> cps_calls:Effects.cps_calls -> should_export:bool -> warn_on_unhandled_effect:bool -> Parse_bytecode.Debug.t diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml new file mode 100644 index 0000000000..b744c0ce2f --- /dev/null +++ b/compiler/lib/global_flow.ml @@ -0,0 +1,623 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(* +The goal of the analysis is to get a good idea of which function might +be called where, and of which functions might be called from some +unknown location (which function 'escapes'). We also keep track of +blocks, to track functions across modules. +*) + +open! Stdlib + +let debug = Debug.find "global-flow" + +let times = Debug.find "times" + +open Code + +(****) + +(* Compute the list of variables containing the return values of each + function *) +let return_values p = + Code.fold_closures + p + (fun name_opt _ (pc, _) rets -> + match name_opt with + | None -> rets + | Some name -> + let s = + Code.traverse + { fold = fold_children } + (fun pc s -> + let block = Addr.Map.find pc p.blocks in + match block.branch with + | Return x -> Var.Set.add x s + | _ -> s) + pc + p.blocks + Var.Set.empty + in + Var.Map.add name s rets) + Var.Map.empty + +(****) + +(* A variable is either let-bound, or a parameter, to which we + associate a set of possible arguments. +*) +type def = + | Expr of Code.expr + | Phi of + { known : Var.Set.t (* Known arguments *) + ; others : bool (* Can there be other arguments *) + } + +let undefined = Phi { known = Var.Set.empty; others = false } + +let is_undefined d = + match d with + | Expr _ -> false + | Phi { known; others } -> Var.Set.is_empty known && not others + +type escape_status = + | Escape + | Escape_constant (* Escapes but we know the value is not modified *) + | No + +type state = + { vars : Var.ISet.t (* Set of all veriables considered *) + ; deps : Var.Set.t array (* Dependency between variables *) + ; defs : def array (* Definition of each variable *) + ; variable_may_escape : escape_status array + (* Any value bound to this variable may escape *) + ; variable_possibly_mutable : bool array + (* Any value bound to this variable may be mutable *) + ; may_escape : escape_status array (* This value may escape *) + ; possibly_mutable : bool array (* This value may be mutable *) + ; return_values : Var.Set.t Var.Map.t + (* Set of variables holding return values of each function *) + ; known_cases : (Var.t, int list) Hashtbl.t + (* Possible tags for a block after a [switch]. This is used to + get a more precise approximation of the effect of a field + access [Field] *) + ; applied_functions : (Var.t * Var.t, unit) Hashtbl.t + (* Functions that have been already considered at a call site. + This is to avoid repeated computations *) + } + +let add_var st x = Var.ISet.add st.vars x + +(* x depends on y *) +let add_dep st x y = + let idx = Var.idx y in + st.deps.(idx) <- Var.Set.add x st.deps.(idx) + +let add_expr_def st x e = + add_var st x; + let idx = Var.idx x in + assert (is_undefined st.defs.(idx)); + st.defs.(idx) <- Expr e + +let add_assign_def st x y = + add_var st x; + add_dep st x y; + let idx = Var.idx x in + match st.defs.(idx) with + | Expr _ -> assert false + | Phi { known; others } -> st.defs.(idx) <- Phi { known = Var.Set.add y known; others } + +let add_param_def st x = + add_var st x; + let idx = Var.idx x in + assert (is_undefined st.defs.(idx)) + +let rec arg_deps st ?ignore params args = + match params, args with + | x :: params, y :: args -> + (* This is to deal with the [else] clause of a conditional, + where we know that the value of the tested variable is 0. *) + (match ignore with + | Some y' when Var.equal y y' -> () + | _ -> add_assign_def st x y); + arg_deps st params args + | _ -> () + +let cont_deps blocks st ?ignore (pc, args) = + let block = Addr.Map.find pc blocks in + arg_deps st ?ignore block.params args + +let do_escape st level x = st.variable_may_escape.(Var.idx x) <- level + +let possibly_mutable st x = st.variable_possibly_mutable.(Var.idx x) <- true + +let expr_deps blocks st x e = + match e with + | Constant _ | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) | Block _ + -> () + | Prim ((Extern ("caml_check_bound" | "caml_array_unsafe_get") | Array_get), l) -> + (* The analysis knowns about these primitives, and will compute + an approximation of the value they return based on an + approximation of their arguments *) + List.iter + ~f:(fun a -> + match a with + | Pc _ -> () + | Pv y -> add_dep st x y) + l + | Prim (Extern name, l) -> + (* Set the escape status of the arguments *) + let ka = + match Primitive.kind_args name with + | Some l -> l + | None -> ( + match Primitive.kind name with + | `Mutable | `Mutator -> [] + | `Pure -> List.map l ~f:(fun _ -> `Const)) + in + let rec loop args ka = + match args, ka with + | [], _ -> () + | Pc _ :: ax, [] -> loop ax [] + | Pv a :: ax, [] -> + do_escape st Escape a; + loop ax [] + | a :: ax, k :: kx -> + (match a, k with + | Pc _, _ -> () + | Pv v, `Const -> do_escape st Escape_constant v + | Pv v, `Shallow_const -> ( + match st.defs.(Var.idx v) with + | Expr (Block (_, a, _)) -> + Array.iter a ~f:(fun x -> do_escape st Escape x) + | _ -> do_escape st Escape v) + | Pv v, `Object_literal -> ( + match st.defs.(Var.idx v) with + | Expr (Block (_, a, _)) -> + Array.iter a ~f:(fun x -> + match st.defs.(Var.idx x) with + | Expr (Block (_, [| _k; v |], _)) -> do_escape st Escape v + | _ -> do_escape st Escape x) + | _ -> do_escape st Escape v) + | Pv v, `Mutable -> do_escape st Escape v); + loop ax kx + in + loop l ka + | Apply { f; args; _ } -> ( + add_dep st x f; + (* If [f] is obviously a function, we can add appropriate + dependencies right now. This speeds up the analysis + significantly. *) + match st.defs.(Var.idx f) with + | Expr (Closure (params, _)) when List.length args = List.length params -> + Hashtbl.add st.applied_functions (x, f) (); + List.iter2 ~f:(fun p a -> add_assign_def st p a) params args; + Var.Set.iter (fun y -> add_dep st x y) (Var.Map.find f st.return_values) + | _ -> ()) + | Closure (l, cont) -> + List.iter l ~f:(fun x -> add_param_def st x); + cont_deps blocks st cont + | Field (y, _) -> add_dep st x y + +let program_deps st { blocks; _ } = + Addr.Map.iter + (fun _ block -> + List.iter block.body ~f:(fun i -> + match i with + | Let (x, e) -> + add_expr_def st x e; + expr_deps blocks st x e + | Assign (x, y) -> add_assign_def st x y + | Set_field (x, _, y) | Array_set (x, _, y) -> + possibly_mutable st x; + do_escape st Escape y + | Offset_ref _ -> ()); + match block.branch with + | Return _ | Stop -> () + | Raise (x, _) -> do_escape st Escape x + | Branch cont | Poptrap cont -> cont_deps blocks st cont + | Cond (x, cont1, cont2) -> + cont_deps blocks st cont1; + cont_deps blocks st ~ignore:x cont2 + | Switch (x, a1, a2) -> + Array.iter a1 ~f:(fun cont -> cont_deps blocks st cont); + Array.iter a2 ~f:(fun cont -> cont_deps blocks st cont); + let h = Hashtbl.create 16 in + Array.iteri + ~f:(fun i (pc, _) -> + Hashtbl.replace h pc (i :: (try Hashtbl.find h pc with Not_found -> []))) + a2; + Hashtbl.iter + (fun pc tags -> + let block = Addr.Map.find pc blocks in + List.iter + ~f:(fun i -> + match i with + | Let (y, Field (x', _)) when Var.equal x x' -> + Hashtbl.add st.known_cases y tags + | _ -> ()) + block.body) + h + | Pushtrap (cont, x, cont_h, _) -> + add_var st x; + st.defs.(Var.idx x) <- Phi { known = Var.Set.empty; others = true }; + cont_deps blocks st cont_h; + cont_deps blocks st cont) + blocks + +(* For each variable, we keep track of which values, function or + block, it may contain. Other kinds of values are not relevant and + just ignored. We loose a lot of information when going to [Top] + since we have to assume that all functions might escape. So, having + possibly unknown values does not move us to [Top]; we use a flag + for that instead. *) +type approx = + | Top + | Values of + { known : Var.Set.t (* List of possible values (functions and blocks) *) + ; others : bool (* Whether other functions or blocks are possible *) + } + +module Domain = struct + type t = approx + + let bot = Values { known = Var.Set.empty; others = false } + + let others = Values { known = Var.Set.empty; others = true } + + let singleton x = Values { known = Var.Set.singleton x; others = false } + + let equal x y = + match x, y with + | Top, Top -> true + | Values { known; others }, Values { known = known'; others = others' } -> + Var.Set.equal known known' && Bool.equal others others' + | Top, Values _ | Values _, Top -> false + + let higher_escape_status s s' = + match s, s' with + | Escape, Escape -> false + | Escape, (Escape_constant | No) -> true + | Escape_constant, (Escape | Escape_constant) -> false + | Escape_constant, No -> true + | No, (Escape | Escape_constant | No) -> false + + let rec value_escape ~update ~st ~approx s x = + let idx = Var.idx x in + if higher_escape_status s st.may_escape.(idx) + then ( + st.may_escape.(idx) <- s; + match st.defs.(idx) with + | Expr (Block (_, a, _)) -> + Array.iter ~f:(fun y -> variable_escape ~update ~st ~approx s y) a; + if Poly.equal s Escape + then ( + st.possibly_mutable.(idx) <- true; + update ~children:true x) + | Expr (Closure (params, _)) -> + List.iter + ~f:(fun y -> + (match st.defs.(Var.idx y) with + | Phi { known; _ } -> st.defs.(Var.idx y) <- Phi { known; others = true } + | Expr _ -> assert false); + update ~children:false y) + params; + Var.Set.iter + (fun y -> variable_escape ~update ~st ~approx s y) + (Var.Map.find x st.return_values) + | _ -> ()) + + and variable_escape ~update ~st ~approx s x = + if higher_escape_status s st.variable_may_escape.(Var.idx x) + then ( + st.variable_may_escape.(Var.idx x) <- s; + approx_escape ~update ~st ~approx s (Var.Tbl.get approx x)) + + and approx_escape ~update ~st ~approx s a = + match a with + | Top -> () + | Values { known; _ } -> + Var.Set.iter (fun x -> value_escape ~update ~st ~approx s x) known + + let join ~update ~st ~approx x y = + match x, y with + | Top, _ -> + approx_escape ~update ~st ~approx Escape y; + Top + | _, Top -> + approx_escape ~update ~st ~approx Escape x; + Top + | Values { known; others }, Values { known = known'; others = others' } -> + Values { known = Var.Set.union known known'; others = others || others' } + + let join_set ~update ~st ~approx ?others:(o = false) f s = + Var.Set.fold + (fun x a -> join ~update ~st ~approx (f x) a) + s + (if o then others else bot) + + let mark_mutable ~update ~st a = + match a with + | Top -> () + | Values { known; _ } -> + Var.Set.iter + (fun x -> + if not st.possibly_mutable.(Var.idx x) + then ( + st.possibly_mutable.(Var.idx x) <- true; + update ~children:true x)) + known +end + +let propagate st ~update approx x = + match st.defs.(Var.idx x) with + | Phi { known; others } -> + Domain.join_set ~update ~st ~approx ~others (fun y -> Var.Tbl.get approx y) known + | Expr e -> ( + match e with + | Constant _ -> + (* A constant cannot contain a function *) + Domain.bot + | Closure _ | Block _ -> Domain.singleton x + | Field (y, n) -> ( + match Var.Tbl.get approx y with + | Values { known; others } -> + let tags = + try Some (Hashtbl.find st.known_cases x) with Not_found -> None + in + Domain.join_set + ~others + ~update + ~st + ~approx + (fun z -> + match st.defs.(Var.idx z) with + | Expr (Block (t, a, _)) + when n < Array.length a + && + match tags with + | Some tags -> List.memq t ~set:tags + | None -> true -> + let t = a.(n) in + add_dep st x t; + let a = Var.Tbl.get approx t in + if st.possibly_mutable.(Var.idx z) + then Domain.join ~update ~st ~approx Domain.others a + else a + | Expr (Block _ | Closure _) -> Domain.bot + | Phi _ | Expr _ -> assert false) + known + | Top -> Top) + | Prim (Extern "caml_check_bound", [ Pv y; _ ]) -> Var.Tbl.get approx y + | Prim ((Array_get | Extern "caml_array_unsafe_get"), [ Pv y; _ ]) -> ( + match Var.Tbl.get approx y with + | Values { known; others } -> + Domain.join_set + ~update + ~st + ~approx + ~others + (fun z -> + match st.defs.(Var.idx z) with + | Expr (Block (_, lst, _)) -> + Array.iter ~f:(fun t -> add_dep st x t) lst; + let a = + Array.fold_left + ~f:(fun acc t -> + Domain.join ~update ~st ~approx (Var.Tbl.get approx t) acc) + ~init:Domain.bot + lst + in + if st.possibly_mutable.(Var.idx z) + then Domain.join ~update ~st ~approx Domain.others a + else a + | Expr (Closure _) -> Domain.bot + | Phi _ | Expr _ -> assert false) + known + | Top -> Top) + | Prim (Array_get, _) -> assert false + | Prim ((Vectlength | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> + (* The result of these primitive is neither a function nor a + block *) + Domain.bot + | Prim (Extern _, _) -> Domain.others + | Apply { f; args; _ } -> ( + match Var.Tbl.get approx f with + | Values { known; others } -> + if others + then + List.iter + ~f:(fun y -> Domain.variable_escape ~update ~st ~approx Escape y) + args; + Domain.join_set + ~update + ~st + ~approx + ~others + (fun g -> + match st.defs.(Var.idx g) with + | Expr (Closure (params, _)) when List.length args = List.length params + -> + if not (Hashtbl.mem st.applied_functions (x, g)) + then ( + Hashtbl.add st.applied_functions (x, g) (); + List.iter2 + ~f:(fun p a -> + add_assign_def st p a; + update ~children:false p) + params + args; + Var.Set.iter + (fun y -> add_dep st x y) + (Var.Map.find g st.return_values)); + Domain.join_set + ~update + ~st + ~approx + (fun y -> Var.Tbl.get approx y) + (Var.Map.find g st.return_values) + | Expr (Closure (_, _)) -> + (* The funciton is partially applied or over applied *) + List.iter + ~f:(fun y -> Domain.variable_escape ~update ~st ~approx Escape y) + args; + Domain.variable_escape ~update ~st ~approx Escape g; + Domain.others + | Expr (Block _) -> Domain.bot + | Phi _ | Expr _ -> assert false) + known + | Top -> + List.iter + ~f:(fun y -> Domain.variable_escape ~update ~st ~approx Escape y) + args; + Top)) + +let propagate st ~update approx x = + let res = propagate st ~update approx x in + match res with + | Values { known; _ } when Var.Set.cardinal known >= 200 -> + (* When the set of possible values get to large, we give up and + just forget about it. This is crucial to make the analysis + terminates in a reasonable amount of time. This happens when + our analysis is very imprecise (for instance, with + [List.map]), so we may not loose too much by doing that. *) + if debug () then Format.eprintf "TOP %a@." Var.print x; + Domain.approx_escape ~update ~st ~approx Escape res; + Top + | Values _ -> + (match st.variable_may_escape.(Var.idx x) with + | (Escape | Escape_constant) as s -> Domain.approx_escape ~update ~st ~approx s res + | No -> ()); + if st.variable_possibly_mutable.(Var.idx x) then Domain.mark_mutable ~update ~st res; + res + | Top -> Top + +module G = Dgraph.Make_Imperative (Var) (Var.ISet) (Var.Tbl) +module Solver = G.Solver (Domain) + +let solver st = + let g = + { G.domain = st.vars + ; G.iter_children = (fun f x -> Var.Set.iter f st.deps.(Var.idx x)) + } + in + Solver.f' () g (propagate st) + +(****) + +type info = + { info_defs : def array + ; info_approximation : Domain.t Var.Tbl.t + ; info_may_escape : bool array + } + +let f p = + let t = Timer.make () in + let t1 = Timer.make () in + let rets = return_values p in + let nv = Var.count () in + let vars = Var.ISet.empty () in + let deps = Array.make nv Var.Set.empty in + let defs = Array.make nv undefined in + let variable_may_escape = Array.make nv No in + let variable_possibly_mutable = Array.make nv false in + let may_escape = Array.make nv No in + let possibly_mutable = Array.make nv false in + let st = + { vars + ; deps + ; defs + ; return_values = rets + ; variable_may_escape + ; variable_possibly_mutable + ; may_escape + ; possibly_mutable + ; known_cases = Hashtbl.create 16 + ; applied_functions = Hashtbl.create 16 + } + in + program_deps st p; + if times () + then Format.eprintf " global flow analysis (initialize): %a@." Timer.print t1; + let t2 = Timer.make () in + let approximation = solver st in + if times () + then Format.eprintf " global flow analysis (solve): %a@." Timer.print t2; + if times () then Format.eprintf " global flow analysis: %a@." Timer.print t; + if debug () + then + Var.ISet.iter + (fun x -> + let s = Var.Tbl.get approximation x in + if not (Domain.equal s Domain.bot) + then + Format.eprintf + "%a: %a@." + Var.print + x + (fun f a -> + match a with + | Top -> Format.fprintf f "top" + | Values { known; others } -> + Format.fprintf + f + "{%a/%b} mut:%b vmut:%b esc:%s" + (Format.pp_print_list + ~pp_sep:(fun f () -> Format.fprintf f ", ") + (fun f x -> + Format.fprintf + f + "%a(%s)" + Var.print + x + (match st.defs.(Var.idx x) with + | Expr (Closure _) -> "C" + | Expr (Block _) -> + "B" + ^ + if Poly.equal st.may_escape.(Var.idx x) Escape + then "X" + else "" + | _ -> "O"))) + (Var.Set.elements known) + others + st.possibly_mutable.(Var.idx x) + st.variable_possibly_mutable.(Var.idx x) + (match st.may_escape.(Var.idx x) with + | Escape -> "Y" + | Escape_constant -> "y" + | No -> "n")) + s) + vars; + { info_defs = defs + ; info_approximation = approximation + ; info_may_escape = Array.map ~f:(fun s -> Poly.(s <> No)) may_escape + } + +let exact_call info f n = + match Var.Tbl.get info.info_approximation f with + | Top | Values { others = true; _ } -> false + | Values { known; others = false } -> + Var.Set.for_all + (fun g -> + match info.info_defs.(Var.idx g) with + | Expr (Closure (params, _)) -> List.length params = n + | Expr (Block _) -> true + | Expr _ | Phi _ -> assert false) + known diff --git a/compiler/lib/global_flow.mli b/compiler/lib/global_flow.mli new file mode 100644 index 0000000000..3a16223f1c --- /dev/null +++ b/compiler/lib/global_flow.mli @@ -0,0 +1,42 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) +open Code + +type def = + | Expr of Code.expr + | Phi of + { known : Var.Set.t (* Known arguments *) + ; others : bool (* Can there be other arguments *) + } + +type approx = + | Top + | Values of + { known : Var.Set.t (* List of possible values *) + ; others : bool (* Whether other values are possible *) + } + +type info = + { info_defs : def array + ; info_approximation : approx Var.Tbl.t + ; info_may_escape : bool array + } + +val f : Code.program -> info + +val exact_call : info -> Var.t -> int -> bool diff --git a/compiler/lib/lambda_lifting.ml b/compiler/lib/lambda_lifting.ml index 998093ca3e..b14ef61dd3 100644 --- a/compiler/lib/lambda_lifting.ml +++ b/compiler/lib/lambda_lifting.ml @@ -198,12 +198,6 @@ let rec traverse var_depth (program, functions) pc depth limit = Let (f'', Closure (List.map s ~f:snd, (pc'', []))) :: functions in let rem', st = rewrite_body false (program, functions) rem in - assert ( - (not (List.is_empty rem')) - || - match block.branch with - | Return _ -> false - | _ -> true); ( Let (f, Apply { f = f''; args = List.map ~f:fst s; exact = true }) :: rem' , st )) diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml new file mode 100644 index 0000000000..be1f51d636 --- /dev/null +++ b/compiler/lib/partial_cps_analysis.ml @@ -0,0 +1,190 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(* We compute which functions and which call points needs to be in CPS. *) + +open! Stdlib + +let times = Debug.find "times" + +open Code + +let add_var = Var.ISet.add + +(* x depends on y *) +let add_dep deps x y = + let idx = Var.idx y in + deps.(idx) <- Var.Set.add x deps.(idx) + +let add_tail_dep deps x y = + if not (Var.Map.mem x !deps) then deps := Var.Map.add x Var.Set.empty !deps; + deps := + Var.Map.update + y + (fun s -> Some (Var.Set.add x (Option.value ~default:Var.Set.empty s))) + !deps + +let block_deps ~info ~vars ~tail_deps ~deps ~blocks ~fun_name pc = + let block = Addr.Map.find pc blocks in + List.iter_last block.body ~f:(fun is_last i -> + match i with + | Let (x, Apply { f; _ }) -> ( + add_var vars x; + (match fun_name with + | None -> () + | Some g -> + add_var vars g; + (* If a call point is in CPS, then the englobing + function should be in CPS *) + add_dep deps g x); + match Var.Tbl.get info.Global_flow.info_approximation f with + | Top -> () + | Values { known; others } -> + let known_tail_call = + (not others) + && is_last + && + match block.branch with + | Return x' -> Var.equal x x' + | _ -> false + in + Var.Set.iter + (fun g -> + add_var vars g; + (if known_tail_call + then + match fun_name with + | None -> () + | Some f -> add_tail_dep tail_deps f g); + (* If a called function is in CPS, then the call + point is in CPS *) + add_dep deps x g; + (* Conversally, if a call point is in CPS then all + called functions must be in CPS *) + add_dep deps g x) + known) + | Let (x, Prim (Extern ("%perform" | "%reperform" | "%resume"), _)) -> ( + add_var vars x; + match fun_name with + | None -> () + | Some f -> + add_var vars f; + (* If a function contains effect primitives, it must be + in CPS *) + add_dep deps f x) + | Let (x, Closure _) -> add_var vars x + | Let (_, (Prim _ | Block _ | Constant _ | Field _)) + | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ()) + +let program_deps ~info ~vars ~tail_deps ~deps p = + fold_closures + p + (fun fun_name _ (pc, _) _ -> + traverse + { fold = Code.fold_children } + (fun pc () -> + block_deps ~info ~vars ~tail_deps ~deps ~blocks:p.blocks ~fun_name pc) + pc + p.blocks + ()) + () + +module Domain = struct + type t = bool + + let equal = Bool.equal + + let bot = false +end + +module G = Dgraph.Make_Imperative (Var) (Var.ISet) (Var.Tbl) +module Solver = G.Solver (Domain) + +let fold_children g f x acc = + let acc = ref acc in + g.G.iter_children (fun y -> acc := f y !acc) x; + !acc + +let cps_needed ~info ~in_mutual_recursion ~rev_deps st x = + (* Mutually recursive functions are turned into CPS for tail + optimization *) + Var.Set.mem x in_mutual_recursion + || + let idx = Var.idx x in + fold_children rev_deps (fun y acc -> acc || Var.Tbl.get st y) x false + || + match info.Global_flow.info_defs.(idx) with + | Expr (Apply { f; _ }) -> ( + (* If we don't know all possible functions at a call point, it + must be in CPS *) + match Var.Tbl.get info.Global_flow.info_approximation f with + | Top -> true + | Values { others; _ } -> others) + | Expr (Closure _) -> + (* If a function escapes, it must be in CPS *) + info.Global_flow.info_may_escape.(idx) + | Expr (Prim (Extern ("%perform" | "%reperform" | "%resume"), _)) -> + (* Effects primitives are in CPS *) + true + | Expr (Prim _ | Block _ | Constant _ | Field _) | Phi _ -> false + +module SCC = Strongly_connected_components.Make (struct + type t = Var.t + + module Set = Var.Set + module Map = Var.Map +end) + +let find_mutually_recursive_calls tail_deps = + let scc = SCC.component_graph !tail_deps in + Array.fold_left + ~f:(fun s (c, _) -> + match c with + | SCC.No_loop _ -> s + | Has_loop l -> List.fold_left ~f:(fun s x -> Var.Set.add x s) l ~init:s) + ~init:Var.Set.empty + scc + +let annot st xi = + match (xi : Print.xinstr) with + | Instr (Let (x, _)) when Var.Set.mem x st -> "*" + | _ -> " " + +let f p info = + let t = Timer.make () in + let t1 = Timer.make () in + let nv = Var.count () in + let vars = Var.ISet.empty () in + let deps = Array.make nv Var.Set.empty in + let tail_deps = ref Var.Map.empty in + program_deps ~info ~vars ~tail_deps ~deps p; + if times () then Format.eprintf " fun analysis (initialize): %a@." Timer.print t1; + let t2 = Timer.make () in + let in_mutual_recursion = find_mutually_recursive_calls tail_deps in + if times () then Format.eprintf " fun analysis (tail calls): %a@." Timer.print t2; + let t3 = Timer.make () in + let g = + { G.domain = vars; iter_children = (fun f x -> Var.Set.iter f deps.(Var.idx x)) } + in + let rev_deps = G.invert () g in + let res = Solver.f () g (cps_needed ~info ~in_mutual_recursion ~rev_deps) in + if times () then Format.eprintf " fun analysis (solve): %a@." Timer.print t3; + let s = ref Var.Set.empty in + Var.Tbl.iter (fun x v -> if v then s := Var.Set.add x !s) res; + if times () then Format.eprintf " fun analysis: %a@." Timer.print t; + !s diff --git a/compiler/lib/partial_cps_analysis.mli b/compiler/lib/partial_cps_analysis.mli new file mode 100644 index 0000000000..4ec0cb531c --- /dev/null +++ b/compiler/lib/partial_cps_analysis.mli @@ -0,0 +1,21 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +val annot : Code.Var.Set.t -> Code.Print.xinstr -> string + +val f : Code.program -> Global_flow.info -> Code.Var.Set.t diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index faf6bb01aa..6776e737fd 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -277,6 +277,26 @@ module List = struct | x :: xs -> aux (x :: acc) xs in aux [] xs + + (* like [List.map] except that it calls the function with + an additional argument to indicate whether we're mapping + over the last element of the list *) + let rec map_last ~f l = + match l with + | [] -> assert false + | [ x ] -> [ f true x ] + | x :: xs -> f false x :: map_last ~f xs + + (* like [List.iter] except that it calls the function with + an additional argument to indicate whether we're iterating + over the last element of the list *) + let rec iter_last ~f l = + match l with + | [] -> () + | [ a ] -> f true a + | a :: l -> + f false a; + iter_last ~f l end let ( @ ) = List.append diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index 6738b67808..f2046e5a50 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -79,6 +79,22 @@ (preprocess (pps ppx_expect))) +(library + ;; compiler/tests-compiler/effects_call_opt.ml + (name effects_call_opt_15) + (enabled_if true) + (modules effects_call_opt) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (flags -allow-output-patterns) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + (library ;; compiler/tests-compiler/effects_continuations.ml (name effects_continuations_15) diff --git a/compiler/tests-compiler/effects.ml b/compiler/tests-compiler/effects.ml index 5b91a3754d..0994bb3034 100644 --- a/compiler/tests-compiler/effects.ml +++ b/compiler/tests-compiler/effects.ml @@ -47,13 +47,9 @@ let fff () = _b_= [0, function(e,cont) - {return e === E - ?caml_cps_exact_call1 - (cont, - [0,function(k,cont){return caml_cps_exact_call1(cont,11)}]) - :caml_cps_exact_call1(cont,0)}], + {return e === E?cont([0,function(k,cont){return cont(11)}]):cont(0)}], _c_=10; - function _d_(x,cont){return caml_cps_exact_call1(cont,x)} + function _d_(x,cont){return cont(x)} var _e_=Stdlib_Effect[3][5]; return caml_cps_call4 (_e_, diff --git a/compiler/tests-compiler/effects_call_opt.ml b/compiler/tests-compiler/effects_call_opt.ml new file mode 100644 index 0000000000..5ad0e7ccba --- /dev/null +++ b/compiler/tests-compiler/effects_call_opt.ml @@ -0,0 +1,94 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/effects_call_opt.ml" = + let code = + compile_and_parse + ~effects:true + {| + (* Arity of the argument of a function / direct call *) + let test1 () = + let f g x = g x in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x *. 2.) 4.) + + (* Arity of the argument of a function / CPS call *) + let test2 () = + let f g x = g x in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x ^ "a") "a") + + (* Arity of functions in a functor / direct call *) + let test3 x = + let module F(_ : sig end) = struct let f x = x + 1 end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + (M1.f 1, M2.f 2) + + (* Arity of functions in a functor / CPS call *) + let test4 x = + let module F(_ : sig end) = + struct let f x = Printf.printf "%d" x end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + M1.f 1; M2.f 2 +|} + in + print_fun_decl code (Some "test1"); + print_fun_decl code (Some "test2"); + print_fun_decl code (Some "test3"); + print_fun_decl code (Some "test4"); + [%expect + {| + function test1(param,cont) + {function f(g,x){return g(x)} + var _k_=7; + f(function(x){return x + 1 | 0},_k_); + var _l_=4.; + f(function(x){return x * 2.},_l_); + return cont(0)} + //end + function test2(param,cont) + {function f(g,x,cont){return caml_cps_exact_call2(g,x,cont)} + var _f_=7; + function _g_(x,cont){return cont(x + 1 | 0)} + return caml_cps_exact_call3 + (f, + _g_, + _f_, + function(_h_) + {function _i_(x,cont) + {return caml_cps_call3(Stdlib[28],x,cst_a$0,cont)} + return caml_cps_exact_call3 + (f,_i_,cst_a,function(_j_){return cont(0)})})} + //end + function test3(x,cont) + {function F(symbol){function f(x){return x + 1 | 0}return [0,f]} + var M1=F([0]),M2=F([0]),_e_=M2[1](2); + return cont([0,M1[1](1),_e_])} + //end + function test4(x,cont) + {function F(symbol) + {function f(x,cont){return caml_cps_call3(Stdlib_Printf[2],_a_,x,cont)} + return [0,f]} + var M1=F([0]),M2=F([0]),_b_=1,_c_=M1[1]; + return caml_cps_exact_call2 + (_c_,_b_,function(_d_){return caml_cps_exact_call2(M2[1],2,cont)})} + //end |}] diff --git a/compiler/tests-compiler/effects_continuations.ml b/compiler/tests-compiler/effects_continuations.ml index 6b89444da3..27911f421b 100644 --- a/compiler/tests-compiler/effects_continuations.ml +++ b/compiler/tests-compiler/effects_continuations.ml @@ -76,6 +76,15 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = all := line :: !all; prerr_endline line done + + let loop3 () = + let l = List.rev [1;2;3] in + let rec f x = + match x with + | [] -> l + | _ :: r -> f r + in + f l |} in print_fun_decl code (Some "exceptions"); @@ -84,91 +93,97 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = print_fun_decl code (Some "cond3"); print_fun_decl code (Some "loop1"); print_fun_decl code (Some "loop2"); + print_fun_decl code (Some "loop3"); [%expect {| function exceptions(s,cont) {try - {var _z_=runtime.caml_int_of_string(s),n=_z_} - catch(_D_) - {var _s_=caml_wrap_exception(_D_); - if(_s_[1] !== Stdlib[7]) - {var raise$1=caml_pop_trap();return caml_cps_exact_call1(raise$1,_s_)} - var n=0,_t_=0} + {var _C_=runtime.caml_int_of_string(s),n=_C_} + catch(_G_) + {var _v_=caml_wrap_exception(_G_); + if(_v_[1] !== Stdlib[7]){var raise$1=caml_pop_trap();return raise$1(_v_)} + var n=0,_w_=0} try - {if(caml_string_equal(s,cst$0))throw Stdlib[8];var _y_=7,m=_y_} - catch(_C_) - {var _u_=caml_wrap_exception(_C_); - if(_u_ !== Stdlib[8]) - {var raise$0=caml_pop_trap();return caml_cps_exact_call1(raise$0,_u_)} - var m=0,_v_=0} + {if(caml_string_equal(s,cst$0))throw Stdlib[8];var _B_=7,m=_B_} + catch(_F_) + {var _x_=caml_wrap_exception(_F_); + if(_x_ !== Stdlib[8]){var raise$0=caml_pop_trap();return raise$0(_x_)} + var m=0,_y_=0} runtime.caml_push_trap - (function(_B_) - {if(_B_ === Stdlib[8])return caml_cps_exact_call1(cont,0); + (function(_E_) + {if(_E_ === Stdlib[8])return cont(0); var raise=caml_pop_trap(); - return caml_cps_exact_call1(raise,_B_)}); + return raise(_E_)}); if(caml_string_equal(s,cst)) - {var _w_=Stdlib[8],raise=caml_pop_trap(); - return caml_cps_exact_call1(raise,_w_)} - var _x_=Stdlib[79]; + {var _z_=Stdlib[8],raise=caml_pop_trap();return raise(_z_)} + var _A_=Stdlib[79]; return caml_cps_call2 - (_x_, + (_A_, cst_toto, - function(_A_) - {caml_pop_trap(); - return caml_cps_exact_call1(cont,[0,[0,_A_,n,m]])})} + function(_D_){caml_pop_trap();return cont([0,[0,_D_,n,m]])})} //end function cond1(b,cont) - {function _r_(ic){return caml_cps_exact_call1(cont,[0,ic,7])} + {function _u_(ic){return cont([0,ic,7])} return b - ?caml_cps_call2(Stdlib[79],cst_toto$0,_r_) - :caml_cps_call2(Stdlib[79],cst_titi,_r_)} + ?caml_cps_call2(Stdlib[79],cst_toto$0,_u_) + :caml_cps_call2(Stdlib[79],cst_titi,_u_)} //end function cond2(b,cont) - {function _p_(_q_){return caml_cps_exact_call1(cont,7)} + {function _s_(_t_){return cont(7)} return b - ?caml_cps_call2(Stdlib_Printf[3],_a_,_p_) - :caml_cps_call2(Stdlib_Printf[3],_b_,_p_)} + ?caml_cps_call2(Stdlib_Printf[3],_a_,_s_) + :caml_cps_call2(Stdlib_Printf[3],_b_,_s_)} //end function cond3(b,cont) {var x=[0,0]; - function _n_(_o_){return caml_cps_exact_call1(cont,x[1])} - return b - ?(x[1] = 1,caml_cps_exact_call1(_n_,0)) - :caml_cps_call2(Stdlib_Printf[3],_c_,_n_)} + function _q_(_r_){return cont(x[1])} + return b?(x[1] = 1,_q_(0)):caml_cps_call2(Stdlib_Printf[3],_c_,_q_)} //end function loop1(b,cont) - {var all=[0,0],_j_=Stdlib[79]; + {var all=[0,0],_m_=Stdlib[79]; return caml_cps_call2 - (_j_, + (_m_, cst_static_examples_ml, function(ic) - {function _k_(_m_) - {var _l_=Stdlib[83]; + {function _n_(_p_) + {var _o_=Stdlib[83]; return caml_cps_call2 - (_l_, + (_o_, ic, function(line) {all[1] = [0,line,all[1]]; return b - ?caml_cps_call2(Stdlib[53],line,_k_) - :caml_cps_exact_call1(_k_,0)})} - return caml_cps_exact_call1(_k_,0)})} + ?caml_cps_call2(Stdlib[53],line,_n_) + :caml_cps_exact_call1(_n_,0)})} + return _n_(0)})} //end function loop2(param,cont) - {var all=[0,0],_e_=Stdlib[79]; + {var all=[0,0],_h_=Stdlib[79]; return caml_cps_call2 - (_e_, + (_h_, cst_static_examples_ml$0, function(ic) - {var _f_=Stdlib_Printf[3]; - function _g_(_i_) - {var _h_=Stdlib[83]; + {var _i_=Stdlib_Printf[3]; + function _j_(_l_) + {var _k_=Stdlib[83]; return caml_cps_call2 - (_h_, + (_k_, ic, function(line) {all[1] = [0,line,all[1]]; - return caml_cps_call2(Stdlib[53],line,_g_)})} - return caml_cps_call2(_f_,_d_,_g_)})} + return caml_cps_call2(Stdlib[53],line,_j_)})} + return caml_cps_call2(_i_,_d_,_j_)})} + //end + function loop3(param,cont) + {var _f_=Stdlib_List[9]; + return caml_cps_call2 + (_f_, + _e_, + function(l) + {function _g_(x) + {if(! x)return cont(l); + var r=x[2]; + return caml_cps_exact_call1(_g_,r)} + return _g_(l)})} //end |}] diff --git a/compiler/tests-compiler/effects_exceptions.ml b/compiler/tests-compiler/effects_exceptions.ml index 8b5d8148b2..cb75576b91 100644 --- a/compiler/tests-compiler/effects_exceptions.ml +++ b/compiler/tests-compiler/effects_exceptions.ml @@ -36,6 +36,20 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = Some (open_in "toto", n, m) with Not_found -> None + + let handler_is_loop f g l = + try f () + with exn -> + let rec loop l = + match g l with + | `Fallback l' -> loop l' + | `Raise exn -> raise exn + in + loop l + + let handler_is_merge_node g = + let s = try g () with _ -> "" in + s ^ "aaa" |} in print_fun_decl code (Some "exceptions"); @@ -44,32 +58,55 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = function exceptions(s,cont) {try - {var _h_=runtime.caml_int_of_string(s),n=_h_} - catch(_l_) - {var _a_=caml_wrap_exception(_l_); - if(_a_[1] !== Stdlib[7]) - {var raise$1=caml_pop_trap();return caml_cps_exact_call1(raise$1,_a_)} - var n=0,_b_=0} + {var _p_=runtime.caml_int_of_string(s),n=_p_} + catch(_t_) + {var _i_=caml_wrap_exception(_t_); + if(_i_[1] !== Stdlib[7]){var raise$1=caml_pop_trap();return raise$1(_i_)} + var n=0,_j_=0} try - {if(caml_string_equal(s,cst$0))throw Stdlib[8];var _g_=7,m=_g_} - catch(_k_) - {var _c_=caml_wrap_exception(_k_); - if(_c_ !== Stdlib[8]) - {var raise$0=caml_pop_trap();return caml_cps_exact_call1(raise$0,_c_)} - var m=0,_d_=0} - runtime.caml_push_trap - (function(_j_) - {if(_j_ === Stdlib[8])return caml_cps_exact_call1(cont,0); + {if(caml_string_equal(s,cst$0))throw Stdlib[8];var _o_=7,m=_o_} + catch(_s_) + {var _k_=caml_wrap_exception(_s_); + if(_k_ !== Stdlib[8]){var raise$0=caml_pop_trap();return raise$0(_k_)} + var m=0,_l_=0} + caml_push_trap + (function(_r_) + {if(_r_ === Stdlib[8])return cont(0); var raise=caml_pop_trap(); - return caml_cps_exact_call1(raise,_j_)}); + return raise(_r_)}); if(caml_string_equal(s,cst)) - {var _e_=Stdlib[8],raise=caml_pop_trap(); - return caml_cps_exact_call1(raise,_e_)} - var _f_=Stdlib[79]; + {var _m_=Stdlib[8],raise=caml_pop_trap();return raise(_m_)} + var _n_=Stdlib[79]; return caml_cps_call2 - (_f_, + (_n_, cst_toto, - function(_i_) - {caml_pop_trap(); - return caml_cps_exact_call1(cont,[0,[0,_i_,n,m]])})} + function(_q_){caml_pop_trap();return cont([0,[0,_q_,n,m]])})} + //end |}]; + print_fun_decl code (Some "handler_is_loop"); + [%expect + {| + function handler_is_loop(f,g,l,cont) + {caml_push_trap + (function(_g_) + {function _h_(l) + {return caml_cps_call2 + (g, + l, + function(match) + {if(72330306 <= match[1]) + {var l=match[2];return caml_cps_exact_call1(_h_,l)} + var exn=match[2],raise=caml_pop_trap(); + return raise(exn)})} + return _h_(l)}); + var _e_=0; + return caml_cps_call2(f,_e_,function(_f_){caml_pop_trap();return cont(_f_)})} + //end |}]; + print_fun_decl code (Some "handler_is_merge_node"); + [%expect + {| + function handler_is_merge_node(g,cont) + {function _b_(s){return caml_cps_call3(Stdlib[28],s,cst_aaa,cont)} + caml_push_trap(function(_d_){return _b_(cst$1)}); + var _a_=0; + return caml_cps_call2(g,_a_,function(_c_){caml_pop_trap();return _b_(_c_)})} //end |}] diff --git a/compiler/tests-compiler/effects_toplevel.ml b/compiler/tests-compiler/effects_toplevel.ml index c3347c6e78..3b2eb39b67 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/compiler/tests-compiler/effects_toplevel.ml @@ -80,7 +80,7 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = var Test=[0]; runtime.caml_register_global(2,Test,"Test"); return})} - return caml_cps_exact_call1(_c_,_b_)}, + return _c_(_b_)}, [])} (globalThis)); //end |}] diff --git a/compiler/tests-compiler/lambda_lifting.ml b/compiler/tests-compiler/lambda_lifting.ml index 9a8b4d08b5..5026171404 100644 --- a/compiler/tests-compiler/lambda_lifting.ml +++ b/compiler/tests-compiler/lambda_lifting.ml @@ -22,30 +22,16 @@ Printf.printf "%d\n" (f 3) {| (function(globalThis) {"use strict"; - var runtime=globalThis.jsoo_runtime,caml_callback=runtime.caml_callback; - function caml_cps_exact_call1(f,a0) - {return runtime.caml_stack_check_depth() - ?f(a0) - :runtime.caml_trampoline_return(f,[a0])} - function caml_cps_exact_call2(f,a0,a1) - {return runtime.caml_stack_check_depth() - ?f(a0,a1) - :runtime.caml_trampoline_return(f,[a0,a1])} var + runtime=globalThis.jsoo_runtime, global_data=runtime.caml_get_global_data(), Stdlib_Printf=global_data.Stdlib__Printf, _c_=[0,[4,0,0,0,[12,10,0]],runtime.caml_string_of_jsbytes("%d\n")]; - function f(x,cont){var g$0=g(x);return caml_cps_exact_call2(g$0,5,cont)} - function h(x,y) - {function h(z,cont) - {return caml_cps_exact_call1(cont,(x + y | 0) + z | 0)} - return h} - function g(x) - {function g(y,cont) - {var h$0=h(x,y);return caml_cps_exact_call2(h$0,7,cont)} - return g} - var _a_=3,_b_=caml_callback(f,[_a_]),_d_=Stdlib_Printf[2]; - caml_callback(_d_,[_c_,_b_]); + function f(x){var g$0=g(x);return g$0(5)} + function h(x,y){function h(z){return (x + y | 0) + z | 0}return h} + function g(x){function g(y){var h$0=h(x,y);return h$0(7)}return g} + var _a_=3,_b_=f(_a_),_d_=Stdlib_Printf[2]; + runtime.caml_callback(_d_,[_c_,_b_]); var Test=[0]; runtime.caml_register_global(2,Test,"Test"); return} diff --git a/manual/effects.wiki b/manual/effects.wiki index 8825bfcae0..551afee24f 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -1,20 +1,16 @@ == Effect handlers == Js_of_ocaml supports effect handlers with the {{{--enable=effects}}} -flag. This is based on transformation of the whole program to +flag. This is based on partially transforming the program to continuation-passing style. As a consequence, [[tailcall|tail calls]] are also fully optimized. -This is not the default for now since the generated code is slower, +This is not the default for now since the generated code can be slower, larger and less readable. -The [[performances|performance impact]] is especially large for code -that involves a lot of function calls without allocation, since the -transformation introduces many intermediate continuation -functions. -We hope to improve on this by transforming the code only partially to -continuation-passing style, and by trying alternative compilation +The transformation is based on an analysis to detect parts of the code that cannot involves effects and keep it in direct style. +The analysis is especially effective on monomorphic code. It is not so effective when higher-order functions are heavily used ({{{Lwt}}}, {{{Async}}}, {{{incremental}}}). +We hope to improve on this by trying alternative compilation strategies. - === Dune integration === We're still working on dune support for compiling js_of_ocaml programs @@ -63,4 +59,4 @@ Trying to use separate compilation would result in a error while attempting to l js_of_ocaml: Error: Incompatible build info detected while linking. - test6.bc.runtime.js: effects=false - .cmphash.eobjs/byte/dune__exe.cmo.js: effects=true -}}} \ No newline at end of file +}}} diff --git a/manual/files/performances/size-bzip2-effects.png b/manual/files/performances/size-bzip2-effects.png index 6d3bec700b..b718e483a5 100644 Binary files a/manual/files/performances/size-bzip2-effects.png and b/manual/files/performances/size-bzip2-effects.png differ diff --git a/manual/files/performances/size-effects.png b/manual/files/performances/size-effects.png index 2cc3aa87b7..5b55c273c8 100644 Binary files a/manual/files/performances/size-effects.png and b/manual/files/performances/size-effects.png differ diff --git a/manual/files/performances/time-effects.png b/manual/files/performances/time-effects.png index 5578a1c850..1296865d5f 100644 Binary files a/manual/files/performances/time-effects.png and b/manual/files/performances/time-effects.png differ diff --git a/manual/overview.wiki b/manual/overview.wiki index 09be05724b..9b6fc1c6fb 100644 --- a/manual/overview.wiki +++ b/manual/overview.wiki @@ -79,7 +79,7 @@ functions are optimized: * trampolines are used otherwise. <>. -Effect handlers are fully supported with the {{{--enable=effects}}} flag. This is not the default for now since the generated code is slower, larger and less readable. +Effect handlers are fully supported with the {{{--enable=effects}}} flag. This is not the default for now since effects are not widely used at the moment and the generated code can be slower, larger and less readable. Data representation differs from the usual one. Most notably, integers are 32 bits (rather than 31 bits or 63 bits), which is their diff --git a/manual/performances.wiki b/manual/performances.wiki index 51d0546753..3715d9f0d8 100644 --- a/manual/performances.wiki +++ b/manual/performances.wiki @@ -26,17 +26,17 @@ See how various js_of_ocaml options affect the generated size and execution time <> We show the performance impact of supporting effect handlers. The code -is about 30% larger. The impact on compressed code is actually much lower -since we are adding a lot of function definitions, which are rather -verbose in JavaScript but compress well: the compressed code size -hardly increases for large files compressed with {{{bzip2}}}. -Code that involves a lot of function calls without allocation, such as -{{{fib}}}, becomes much slower. The overhead is reasonable for -code that performs a lot of allocations ({{{hamming}}}) or that -performs some numeric computations ({{{almabench}}}, {{{fft}}}). -Exception handling is faster ({{{boyer}}}). +is about 20% larger. The impact on compressed code is actually much +lower since we are adding a lot of function definitions, which are +rather verbose in JavaScript but compress well: the compressed code +size hardly increases for large files compressed with {{{bzip2}}}. +Code that heavily uses {{{Lwt}}}, {{{Async}}} or {{{Incremental}}} can +see a larger size increase (up to 45% larger, or 7% larger when +compressed). There is almost no speed impact for small monomorphic +programs. We estimate that the slowdown will usually be below 30%, +though it can be larger for code that heavily use higher-order +functions and polymorphism ({{{Lwt}}} code, for instance). <> <> <> - diff --git a/runtime/effect.js b/runtime/effect.js index 6e9deb77dd..886c1ed29c 100644 --- a/runtime/effect.js +++ b/runtime/effect.js @@ -120,20 +120,22 @@ function caml_perform_effect(eff, cont, k0) { } //Provides: caml_alloc_stack -//Requires: caml_pop_fiber, caml_fiber_stack, caml_call_gen +//Requires: caml_pop_fiber, caml_fiber_stack, caml_call_gen, caml_stack_check_depth, caml_trampoline_return //If: effects function caml_alloc_stack(hv, hx, hf) { + function call(i, x) { + var f=caml_fiber_stack.h[i]; + var args = [x, caml_pop_fiber()]; + return caml_stack_check_depth()?caml_call_gen(f,args) + :caml_trampoline_return(f,args); + } function hval(x) { // Call [hv] in the parent fiber - var f=caml_fiber_stack.h[1]; - var k=caml_pop_fiber(); - return caml_call_gen(f, [x, k]); + return call(1, x); } function hexn(e) { // Call [hx] in the parent fiber - var f=caml_fiber_stack.h[2]; - var k=caml_pop_fiber(); - return caml_call_gen(f, [e, k]); + return call(2, e); } return [0, hval, [0, hexn, 0], [0, hv, hx, hf], 0]; }