diff --git a/compiler/.depend b/compiler/.depend index 7157e66e1a..856da1ed74 100644 --- a/compiler/.depend +++ b/compiler/.depend @@ -24,14 +24,14 @@ driver.cmo : varPrinter.cmi util.cmi tailcall.cmi specialize_js.cmi \ specialize.cmi reserved.cmi pretty_print.cmi phisimpl.cmi \ parse_bytecode.cmi option.cmi linker.cmi jsoo_primitive.cmi \ jsoo_deadcode.cmi js_traverse.cmi js_output.cmi js_assign.cmi \ - javascript.cmi inline.cmi generate.cmi flow.cmi eval.cmi \ - compiler_version.cmi code.cmi driver.cmi + javascript.cmi inline.cmi generate_closure.cmi generate.cmi flow.cmi \ + eval.cmi compiler_version.cmi code.cmi driver.cmi driver.cmx : varPrinter.cmx util.cmx tailcall.cmx specialize_js.cmx \ specialize.cmx reserved.cmx pretty_print.cmx phisimpl.cmx \ parse_bytecode.cmx option.cmx linker.cmx jsoo_primitive.cmx \ jsoo_deadcode.cmx js_traverse.cmx js_output.cmx js_assign.cmx \ - javascript.cmx inline.cmx generate.cmx flow.cmx eval.cmx \ - compiler_version.cmx code.cmx driver.cmi + javascript.cmx inline.cmx generate_closure.cmx generate.cmx flow.cmx \ + eval.cmx compiler_version.cmx code.cmx driver.cmi driver.cmi : source_map.cmi pretty_print.cmi parse_bytecode.cmi code.cmi eval.cmo : jsoo_primitive.cmi flow.cmi code.cmi eval.cmi eval.cmx : jsoo_primitive.cmx flow.cmx code.cmx eval.cmi @@ -44,12 +44,19 @@ flow.cmi : code.cmi freevars.cmo : util.cmi option.cmi code.cmi freevars.cmi freevars.cmx : util.cmx option.cmx code.cmx freevars.cmi freevars.cmi : util.cmi code.cmi +generate_closure.cmo : util.cmi option.cmi jsoo_subst.cmi \ + jsoo_strongly_connected_components.cmi freevars.cmi code.cmi \ + generate_closure.cmi +generate_closure.cmx : util.cmx option.cmx jsoo_subst.cmx \ + jsoo_strongly_connected_components.cmx freevars.cmx code.cmx \ + generate_closure.cmi +generate_closure.cmi : code.cmi generate.cmo : util.cmi parse_js.cmi parse_info.cmi parse_bytecode.cmi \ - option.cmi jsoo_subst.cmi jsoo_primitive.cmi js_tailcall.cmi js_simpl.cmi \ - javascript.cmi freevars.cmi code.cmi generate.cmi + option.cmi jsoo_subst.cmi jsoo_primitive.cmi js_simpl.cmi javascript.cmi \ + code.cmi generate.cmi generate.cmx : util.cmx parse_js.cmx parse_info.cmx parse_bytecode.cmx \ - option.cmx jsoo_subst.cmx jsoo_primitive.cmx js_tailcall.cmx js_simpl.cmx \ - javascript.cmx freevars.cmx code.cmx generate.cmi + option.cmx jsoo_subst.cmx jsoo_primitive.cmx js_simpl.cmx javascript.cmx \ + code.cmx generate.cmi generate.cmi : parse_bytecode.cmi javascript.cmi code.cmi inline.cmo : util.cmi option.cmi jsoo_primitive.cmi code.cmi inline.cmi inline.cmx : util.cmx option.cmx jsoo_primitive.cmx code.cmx inline.cmi @@ -62,10 +69,10 @@ javascript.cmo : varPrinter.cmi util.cmi reserved.cmi parse_info.cmi \ javascript.cmx : varPrinter.cmx util.cmx reserved.cmx parse_info.cmx \ code.cmx javascript.cmi javascript.cmi : parse_info.cmi code.cmi -js_assign.cmo : util.cmi option.cmi js_traverse.cmi javascript.cmi code.cmi \ - js_assign.cmi -js_assign.cmx : util.cmx option.cmx js_traverse.cmx javascript.cmx code.cmx \ - js_assign.cmi +js_assign.cmo : util.cmi reserved.cmi option.cmi js_traverse.cmi \ + javascript.cmi code.cmi js_assign.cmi +js_assign.cmx : util.cmx reserved.cmx option.cmx js_traverse.cmx \ + javascript.cmx code.cmx js_assign.cmi js_assign.cmi : javascript.cmi js_lexer.cmo : parse_info.cmi js_token.cmi js_lexer.cmi js_lexer.cmx : parse_info.cmx js_token.cmx js_lexer.cmi @@ -87,6 +94,11 @@ jsoo_findlib_support_internal.cmx : util.cmx jsoo_primitive.cmo : util.cmi parse_info.cmi jsoo_primitive.cmi jsoo_primitive.cmx : util.cmx parse_info.cmx jsoo_primitive.cmi jsoo_primitive.cmi : util.cmi parse_info.cmi +jsoo_strongly_connected_components.cmo : \ + jsoo_strongly_connected_components.cmi +jsoo_strongly_connected_components.cmx : \ + jsoo_strongly_connected_components.cmi +jsoo_strongly_connected_components.cmi : jsoo_subst.cmo : util.cmi code.cmi jsoo_subst.cmi jsoo_subst.cmx : util.cmx code.cmx jsoo_subst.cmi jsoo_subst.cmi : code.cmi @@ -101,16 +113,13 @@ js_parser.cmi : js_token.cmi javascript.cmi js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi js_simpl.cmi : javascript.cmi code.cmi -js_tailcall.cmo : option.cmi js_traverse.cmi javascript.cmi code.cmi \ - js_tailcall.cmi -js_tailcall.cmx : option.cmx js_traverse.cmx javascript.cmx code.cmx \ - js_tailcall.cmi -js_tailcall.cmi : js_traverse.cmi javascript.cmi code.cmi js_token.cmo : parse_info.cmi js_token.cmi js_token.cmx : parse_info.cmx js_token.cmi js_token.cmi : parse_info.cmi -js_traverse.cmo : util.cmi javascript.cmi code.cmi js_traverse.cmi -js_traverse.cmx : util.cmx javascript.cmx code.cmx js_traverse.cmi +js_traverse.cmo : util.cmi option.cmi javascript.cmi code.cmi \ + js_traverse.cmi +js_traverse.cmx : util.cmx option.cmx javascript.cmx code.cmx \ + js_traverse.cmi js_traverse.cmi : util.cmi javascript.cmi code.cmi linker.cmo : util.cmi reserved.cmi parse_js.cmi parse_info.cmi option.cmi \ jsoo_primitive.cmi js_traverse.cmi js_token.cmi javascript.cmi \ diff --git a/compiler/.merlin b/compiler/.merlin new file mode 100644 index 0000000000..3317ce893e --- /dev/null +++ b/compiler/.merlin @@ -0,0 +1,6 @@ +B ./** +S ./** +PKG cmdliner +PKG menhirLib + +EXT js \ No newline at end of file diff --git a/compiler/Makefile b/compiler/Makefile index 9d6310a535..b654dfdefa 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -29,8 +29,9 @@ OBJS=compiler_version.cmx \ instr.cmx jsoo_subst.cmx pure_fun.cmx jsoo_deadcode.cmx \ flow.cmx specialize.cmx specialize_js.cmx eval.cmx inline.cmx \ tailcall.cmx freevars.cmx phisimpl.cmx \ - js_traverse.cmx js_assign.cmx js_tailcall.cmx \ - linker.cmx parse_bytecode.cmx generate.cmx driver.cmx \ + js_traverse.cmx js_assign.cmx \ + linker.cmx parse_bytecode.cmx jsoo_strongly_connected_components.cmx \ + generate_closure.cmx generate.cmx driver.cmx \ pseudoFs.cmx COMPOBJS=$(OBJS) $(FINDLIB_SUPPORT_OBJ) commonArg.cmx compileArg.cmx jsoo_compile.cmx diff --git a/compiler/code.ml b/compiler/code.ml index b6fefd8592..5ca8132151 100644 --- a/compiler/code.ml +++ b/compiler/code.ml @@ -41,6 +41,7 @@ module Var : sig val to_string : ?origin:t -> t -> string val fresh : unit -> t + val fresh_n : string -> t val fork : t -> t val count : unit -> int @@ -48,6 +49,7 @@ module Var : sig val compare : t -> t -> int val name : t -> string -> unit + val get_name : t -> string option val propagate_name : t -> t -> unit val reset : unit -> unit @@ -70,9 +72,15 @@ end = struct let to_string ?origin i = VarPrinter.to_string printer ?origin i let print f x = Format.fprintf f "v%d" x - (* Format.fprintf f "%s" (to_string x) *) + (* Format.fprintf f "%s" (to_string x) *) + + let name i nm = VarPrinter.name printer i nm let fresh () = incr last_var; !last_var + let fresh_n nm = + incr last_var; + name !last_var nm; + !last_var let count () = !last_var + 1 @@ -82,7 +90,8 @@ end = struct let compare v1 v2 = v1 - v2 - let name i nm = VarPrinter.name printer i nm + let get_name i = VarPrinter.get_name printer i + let propagate_name i j = VarPrinter.propagate_name printer i j let set_pretty b = VarPrinter.set_pretty printer b let set_stable b = VarPrinter.set_stable printer b diff --git a/compiler/code.mli b/compiler/code.mli index f3e6745be0..ec5744bf89 100644 --- a/compiler/code.mli +++ b/compiler/code.mli @@ -36,12 +36,14 @@ module Var : sig val to_string : ?origin:t -> t -> string val fresh : unit -> t + val fresh_n : string -> t val fork : t -> t val count : unit -> int val compare : t -> t -> int + val get_name : t -> string option val name : t -> string -> unit val propagate_name : t -> t -> unit val reset : unit -> unit diff --git a/compiler/driver.ml b/compiler/driver.ml index ac4f237f98..71fa9db3fd 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -424,7 +424,7 @@ let pack ~wrap_with_fun ?(toplevel=false) js = let configure formatter p = let pretty = Option.Optim.pretty () in Pretty_print.set_compact formatter (not pretty); - Code.Var.set_pretty pretty; + Code.Var.set_pretty (pretty && not (Option.Optim.shortvar ())); Code.Var.set_stable (Option.Optim.stable_var ()); p @@ -434,6 +434,7 @@ let f ?(standalone=true) ?(wrap_with_fun=false) ?(profile=o1) ?toplevel ?linkall ?source_map ?custom_header formatter d = configure formatter >> profile >> + Generate_closure.f >> deadcode' >> generate d ?toplevel >> diff --git a/compiler/generate.ml b/compiler/generate.ml index ae8dab5bd6..aab5511005 100644 --- a/compiler/generate.ml +++ b/compiler/generate.ml @@ -179,8 +179,7 @@ module Share = struct try J.EVar (StringMap.find s t.vars.strings) with Not_found -> - let x = Var.fresh() in - Var.name x "str"; + let x = Var.fresh_n "str" in let v = J.V x in t.vars <- { t.vars with strings = StringMap.add s v t.vars.strings }; J.EVar v @@ -200,8 +199,7 @@ module Share = struct try J.EVar (StringMap.find s t.vars.prims) with Not_found -> - let x = Var.fresh() in - Code.Var.name x s; + let x = Var.fresh_n s in let v = J.V x in t.vars <- { t.vars with prims = StringMap.add s v t.vars.prims }; J.EVar v @@ -217,8 +215,7 @@ module Share = struct else try J.EVar (IntMap.find n t.vars.applies) with Not_found -> - let x = Var.fresh() in - Code.Var.name x (Printf.sprintf "caml_call_gen%d" n); + let x = Var.fresh_n (Printf.sprintf "caml_call_gen%d" n) in let v = J.V x in t.vars <- { t.vars with applies = IntMap.add n v t.vars.applies }; J.EVar v @@ -229,12 +226,11 @@ module Ctx = struct type t = { mutable blocks : block AddrMap.t; live : int array; - mutated_vars : VarSet.t AddrMap.t; share: Share.t; debug : Parse_bytecode.Debug.data } - let initial blocks live mutated_vars share debug = - { blocks; live; mutated_vars; share; debug } + let initial blocks live share debug = + { blocks; live; share; debug } end @@ -350,8 +346,7 @@ let rec constant_rec ~ctx x level instrs = (fun (acc,instrs) js -> match js with | J.EArr _ -> - let v = Code.Var.fresh () in - Var.name v "partial"; + let v = Code.Var.fresh_n "partial" in let instrs = (J.Variable_statement [J.V v, Some (js,J.N)],J.N) :: instrs in @@ -686,13 +681,11 @@ let apply_fun_raw f params = [f; J.EArr (List.map (fun x -> Some x) params)], J.N)) let generate_apply_fun n = - let f' = Var.fresh () in + let f' = Var.fresh_n "fun" in let f = J.V f' in - Code.Var.name f' "fun"; let params = Array.to_list (Array.init n (fun i -> - let a = Var.fresh () in - Var.name a ("var"^(string_of_int i)); + let a = Var.fresh_n (Printf.sprintf "var%d" i) in J.V a)) in let f' = J.EVar f in @@ -931,52 +924,7 @@ let _ = (****) -let varset_disjoint s s' = not (VarSet.exists (fun x -> VarSet.mem x s') s) - -let rec group_closures_rec closures req = - match closures with - [] -> - ([], VarSet.empty) - | ((var, vars, req_tc, _clo) as elt) :: rem -> - let req = VarSet.union vars req in - let req = VarSet.union req req_tc in - let (closures', prov) = group_closures_rec rem req in - match closures' with - | [] -> - ([elt] :: closures', VarSet.singleton var) - | _ when varset_disjoint prov req -> - ([elt] :: closures', VarSet.singleton var) - | l :: r -> ((elt :: l) :: r, VarSet.add var prov) - -let group_closures l = fst (group_closures_rec l VarSet.empty) - -let rec collect_closures ctx l = - match l with - Let (x, Closure (args, ((pc, _) as cont))) :: rem -> - let clo = compile_closure ctx false cont in - - let all_vars = AddrMap.find pc ctx.Ctx.mutated_vars in - - let tc = (new Js_tailcall.tailcall) in - ignore(tc#sources clo); - let req_tc = (tc#get) in - - let vars = VarSet.remove x all_vars in - let loc = source_location ctx ~after:true pc in - let clo = - match clo with - (st, J.N) :: rem -> (st, J.U) :: rem - | _ -> clo - in - let cl = J.EFun (None, List.map (fun v -> J.V v) args, clo, loc) in - let (l', rem') = collect_closures ctx rem in - ((x, vars, req_tc, cl) :: l', rem') - | _ -> - ([], l) - -(****) - -and translate_expr ctx queue loc _x e level : _ * J.statement_list = +let rec translate_expr ctx queue loc _x e level : _ * J.statement_list = match e with Const i -> (int32 i, const_p, queue),[] @@ -1014,9 +962,15 @@ and translate_expr ctx queue loc _x e level : _ * J.statement_list = | Field (x, n) -> let ((px, cx), queue) = access_queue queue x in (J.EAccess (cx, int (n + 1)), or_p px mutable_p, queue),[] - | Closure _ -> - (* this is done by translate_instr *) - assert false + | Closure (args, ((pc, _) as cont)) -> + let loc = source_location ctx ~after:true pc in + let clo = compile_closure ctx false cont in + let clo = match clo with + | (st, J.N) :: rem -> (st, J.U) :: rem + | _ -> clo + in + let clo = J.EFun (None, List.map (fun v -> J.V v) args, clo, loc) in + (clo, flush_p, queue), [] | Constant c -> let js, instrs = constant ~ctx c level in (js, const_p, queue), instrs @@ -1050,6 +1004,15 @@ and translate_expr ctx queue loc _x e level : _ * J.statement_list = with Parse_js.Parsing_error pi -> failwith (Printf.sprintf "Parsing error %S at l:%d col:%d" nm (pi.Parse_info.line + 1) pi.Parse_info.col) end + | Extern "%js_array", l -> + let (args, prop, queue) = + List.fold_right + (fun x (args, prop, queue) -> + let ((prop', cx), queue) = access_queue' ~ctx queue x in + (cx :: args, or_p prop prop', queue)) + l ([], const_p, queue) + in + J.EArr (List.map (fun x -> Some x) args), prop, queue | Extern "%closure", [Pc (IString name | String name)] -> let prim = Share.get_prim s_var name ctx.Ctx.share in prim, kind (Primitive.kind name), queue @@ -1196,162 +1159,64 @@ and translate_expr ctx queue loc _x e level : _ * J.statement_list = assert false in res,[] -and translate_closures ctx expr_queue l loc = - match l with - [] -> - ([], expr_queue) - | [(x, vars, req_tc, cl)] :: rem -> - let vars = - vars - >> VarSet.elements - >> List.map (fun v -> J.V v) - in - let prim name = Share.get_prim s_var name ctx.Ctx.share in - let defs = Js_tailcall.rewrite [x,cl,loc,req_tc] prim in - let rec return_last x = function - | [] -> [J.Statement (J.Return_statement (Some (J.EVar (J.V x)))),J.N] - | [(J.Variable_statement l as sts, loc)] -> - let l' = List.rev l in - begin match l' with - | (J.V x',Some (e,pc)) :: rem when x = x' -> - [J.Statement (J.Variable_statement (List.rev rem)), loc; - J.Statement (J.Return_statement (Some e)), pc] - | _ -> [J.Statement sts, loc] - end - | (y,loc)::xs -> (J.Statement y, loc) :: return_last x xs - in - let statements = - if vars = [] then defs else - [J.Variable_statement [ - J.V x, - Some ( - J.ECall (J.EFun (None, vars, return_last x defs, J.N), - List.map (fun x -> J.EVar x) vars, J.N), J.N)], J.N] - in - - let (st, expr_queue) = - match ctx.Ctx.live.(Var.idx x),statements with - | 1, [J.Variable_statement [(J.V x',Some (e', _))],_] when x == x' -> - enqueue expr_queue flush_p x e' loc 1 [] - | 0, _ -> (* deadcode is off *) - flush_queue expr_queue flush_p statements - | _ -> - flush_queue expr_queue flush_p statements - in - let (st', expr_queue) = translate_closures ctx expr_queue rem loc in - (st @ st', expr_queue) - | l :: rem -> - let names = - List.fold_left (fun s (x, _, _, _) -> VarSet.add x s) VarSet.empty l in - let vars = - List.fold_left (fun s (_, s', _, _) -> VarSet.union s s') VarSet.empty l - in - let vars = - VarSet.diff vars names - >> VarSet.elements - >> List.map (fun v -> J.V v) - in - let defs' = - List.map (fun (x, _, req_tc, cl) -> (x, cl, loc, req_tc)) l in - let prim name = Share.get_prim s_var name ctx.Ctx.share in - let defs = Js_tailcall.rewrite defs' prim in - let statements = - if vars = [] then defs - else begin - let tbl = Var.fresh () in - Var.name tbl "funenv"; - let arr = - J.EArr - (List.map (fun (x, _, _, _) -> Some (J.EVar (J.V x))) l) - in - let assgn = - List.fold_left - (fun (l, n) (x, _, _, _) -> - ((J.V x, - Some (J.EAccess (J.EVar (J.V tbl), int n), loc)) :: l, - n + 1)) - ([], 0) l - in - [J.Variable_statement - ((J.V tbl, - Some - (J.ECall - (J.EFun (None, vars, - List.map (fun (s, loc) -> (J.Statement s, loc)) defs - @ [J.Statement (J.Return_statement (Some arr)),J.N], - J.N), - List.map (fun x -> J.EVar x) vars, J.N), J.N)) :: - List.rev (fst assgn)), - J.N] - end - in - let (st, expr_queue) = flush_queue expr_queue flush_p statements in - let (st', expr_queue) = translate_closures ctx expr_queue rem loc in - (st @ st', expr_queue) - and translate_instr ctx expr_queue loc instr = match instr with - [] -> - ([], expr_queue) - | Let (_, Closure _) :: _ -> - let (l, rem) = collect_closures ctx instr in - let l = group_closures l in - let (st, expr_queue) = translate_closures ctx expr_queue l loc in - let (instrs, expr_queue) = translate_instr ctx expr_queue loc rem in - (st @ instrs, expr_queue) - | i :: rem -> - let (st, expr_queue) = - match i with - Let (x, e) -> - let (ce, prop, expr_queue),instrs = - translate_expr ctx expr_queue loc x e 0 in - begin match ctx.Ctx.live.(Var.idx x),e with - | 0,_ -> flush_queue expr_queue prop - (instrs @ [J.Expression_statement ce, loc]) - | 1,_ when Option.Optim.compact () -> enqueue expr_queue prop x ce loc 1 instrs - (* We could inline more. - size_v : length of the variable after serialization - size_c : length of the constant after serialization - num : number of occurence - size_c * n < size_v * n + size_v + 1 + size_c - *) - | n,(Const _| Constant (Int _|Float _)) -> - enqueue expr_queue prop x ce loc n instrs - | _ -> flush_queue expr_queue prop - (instrs@ - [J.Variable_statement [J.V x, Some (ce, loc)], loc]) - end - | Set_field (x, n, y) -> - let ((_px, cx), expr_queue) = access_queue expr_queue x in - let ((_py, cy), expr_queue) = access_queue expr_queue y in - flush_queue expr_queue mutator_p - [J.Expression_statement - ((J.EBin (J.Eq, J.EAccess (cx, int (n + 1)), cy))), loc] - | Offset_ref (x, 1) -> - (* FIX: may overflow.. *) - let ((_px, cx), expr_queue) = access_queue expr_queue x in - flush_queue expr_queue mutator_p - [J.Expression_statement - ((J.EUn (J.IncrA, (J.EAccess (cx, J.ENum 1.))))), loc] - | Offset_ref (x, n) -> - (* FIX: may overflow.. *) - let ((_px, cx), expr_queue) = access_queue expr_queue x in - flush_queue expr_queue mutator_p - [J.Expression_statement - ((J.EBin (J.PlusEq, (J.EAccess (cx, J.ENum 1.)), int n))), - loc] - | Array_set (x, y, z) -> - let ((_px, cx), expr_queue) = access_queue expr_queue x in - let ((_py, cy), expr_queue) = access_queue expr_queue y in - let ((_pz, cz), expr_queue) = access_queue expr_queue z in - flush_queue expr_queue mutator_p - [J.Expression_statement - ((J.EBin (J.Eq, J.EAccess (cx, plus_int cy one), - cz))), - loc] - in - let (instrs, expr_queue) = translate_instr ctx expr_queue loc rem in - (st @ instrs, expr_queue) + | Let (x, e) -> + let (ce, prop, expr_queue),instrs = + translate_expr ctx expr_queue loc x e 0 in + begin match ctx.Ctx.live.(Var.idx x),e with + | 0,_ -> (* deadcode is off *) + flush_queue expr_queue prop (instrs @ [J.Expression_statement ce, loc]) + | 1,_ when Option.Optim.compact () -> enqueue expr_queue prop x ce loc 1 instrs + (* We could inline more. + size_v : length of the variable after serialization + size_c : length of the constant after serialization + num : number of occurence + size_c * n < size_v * n + size_v + 1 + size_c + *) + | n,(Const _| Constant (Int _|Float _)) -> + enqueue expr_queue prop x ce loc n instrs + | _ -> flush_queue expr_queue prop + (instrs@ + [J.Variable_statement [J.V x, Some (ce, loc)], loc]) + end + | Set_field (x, n, y) -> + let ((_px, cx), expr_queue) = access_queue expr_queue x in + let ((_py, cy), expr_queue) = access_queue expr_queue y in + flush_queue expr_queue mutator_p + [J.Expression_statement + ((J.EBin (J.Eq, J.EAccess (cx, int (n + 1)), cy))), loc] + | Offset_ref (x, 1) -> + (* FIX: may overflow.. *) + let ((_px, cx), expr_queue) = access_queue expr_queue x in + flush_queue expr_queue mutator_p + [J.Expression_statement + ((J.EUn (J.IncrA, (J.EAccess (cx, J.ENum 1.))))), loc] + | Offset_ref (x, n) -> + (* FIX: may overflow.. *) + let ((_px, cx), expr_queue) = access_queue expr_queue x in + flush_queue expr_queue mutator_p + [J.Expression_statement + ((J.EBin (J.PlusEq, (J.EAccess (cx, J.ENum 1.)), int n))), + loc] + | Array_set (x, y, z) -> + let ((_px, cx), expr_queue) = access_queue expr_queue x in + let ((_py, cy), expr_queue) = access_queue expr_queue y in + let ((_pz, cz), expr_queue) = access_queue expr_queue z in + flush_queue expr_queue mutator_p + [J.Expression_statement + ((J.EBin (J.Eq, J.EAccess (cx, plus_int cy one), + cz))), + loc] + +and translate_instrs ctx expr_queue loc instr = + match instr with + | [] -> + ([], expr_queue) + | instr :: rem -> + let st, expr_queue = translate_instr ctx expr_queue loc instr in + let (instrs, expr_queue) = translate_instrs ctx expr_queue loc rem in + (st @ instrs, expr_queue) and compile_block st queue (pc : addr) frontier interm = if queue <> [] && (AddrSet.mem pc st.loops || not (Option.Optim.inline ())) then @@ -1384,8 +1249,7 @@ else begin in let new_frontier = resolve_nodes interm grey in let block = AddrMap.find pc st.blocks in - let (seq, queue) = - translate_instr st.ctx queue (source_location st.ctx pc) block.body in + let (seq, queue) = translate_instrs st.ctx queue (source_location st.ctx pc) block.body in let body = seq @ match block.branch with @@ -1490,8 +1354,7 @@ else begin (* Single branch, no need to discriminate *) (J.Empty_statement, J.N), block, [] else - let after_poptrap = Code.Var.fresh () in - Code.Var.name after_poptrap "no_exn"; + let after_poptrap = Code.Var.fresh_n "no_exn" in (J.Variable_statement [J.V after_poptrap,Some (J.ENum 1.,J.N)], J.N), Js_simpl.if_statement (J.EVar (J.V after_poptrap)) J.N (J.Block block, J.N) false @@ -1525,8 +1388,7 @@ else begin | _ -> let (new_frontier, new_interm) = if AddrSet.cardinal new_frontier > 1 then begin - let x = Code.Var.fresh () in - Code.Var.name x "switch"; + let x = Code.Var.fresh_n "switch" in let a = Array.of_list (AddrSet.elements new_frontier) in if debug () then Format.eprintf "@ var %a;" Code.Var.print x; let idx = st.interm_idx in @@ -1885,10 +1747,9 @@ let compile_program ctx pc = res let f ((pc, blocks, _) as p) ?toplevel live_vars debug = - let mutated_vars = Freevars.f p in let t' = Util.Timer.make () in let share = Share.get ?alias_prims:toplevel p in - let ctx = Ctx.initial blocks live_vars mutated_vars share debug in + let ctx = Ctx.initial blocks live_vars share debug in let p = compile_program ctx pc in if times () then Format.eprintf " code gen.: %a@." Util.Timer.print t'; p diff --git a/compiler/generate_closure.ml b/compiler/generate_closure.ml new file mode 100644 index 0000000000..44d365dd7c --- /dev/null +++ b/compiler/generate_closure.ml @@ -0,0 +1,285 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2010 Jérôme Vouillon + * Laboratoire PPS - CNRS Université Paris Diderot + * + * 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 closure_info = { + f_name : Code.Var.t; + args : Code.Var.t list; + cont : Code.cont; + mutated : Code.VarSet.t; + tc : Code.AddrSet.t Code.VarMap.t +} + +module SCC = Jsoo_strongly_connected_components.Make(struct + include Var + module Map = VarMap + module Set = VarSet + end) + +let add_multi k v map = + let set = + try VarMap.find k map + with Not_found -> AddrSet.empty + in + VarMap.add k (AddrSet.add v set) map + +let rec tailcall pc blocks visited tc = + if AddrSet.mem pc visited + then visited, tc + else + let visited = AddrSet.add pc visited in + let block = AddrMap.find pc blocks in + let tc_opt = match block.branch with + | Return x -> + begin match Util.last block.body with + | Some (Let (y, Apply (z, _, true))) when Code.Var.compare x y = 0 -> + Some (add_multi z pc tc) + | None -> None + | Some _ -> None + end + | _ -> None + in + match tc_opt with + | Some tc -> visited, tc + | None -> + Code.fold_children blocks pc + (fun pc (visited,tc) -> tailcall pc blocks visited tc) + (visited, tc) + +let rec collect_closures mutated_vars blocks l = + match l with + | Let (f_name, Closure (args, ((pc,_) as cont))) :: rem -> + let tc = snd (tailcall pc blocks AddrSet.empty VarMap.empty) in + let env = AddrMap.find pc mutated_vars in + let l,rem = collect_closures mutated_vars blocks rem in + let mutated = VarSet.remove f_name env in + {f_name; args; cont; mutated; tc} :: l, rem + | rem -> [], rem + + +module Trampoline = struct + + let direct_call_block block ~counter ~x ~f ~args = + let counter_plus_1 = Code.Var.fork counter in + let return = Code.Var.fork x in + { block with + body = + [ + Let (counter_plus_1, + Prim (Extern "%int_add", [Pv counter; Pc (Int 1l)])); + Let (return, + Apply (f,counter_plus_1::args,true)) + ] ; + branch = Return return; + } + + let bounce_call_block block ~x ~f ~args = + let return = Code.Var.fork x in + let new_args = Code.Var.fresh () in + { block with + body = + [ + Let (new_args, + (Prim (Extern "%js_array", + (Pc (Int 0l) :: List.map (fun x -> Pv x) args)))); + Let (return, + Prim (Extern "caml_trampoline_return", [Pv f; Pv new_args])) + ] ; + branch = Return return; + } + + let wrapper_block f ~args ~counter = + let result1 = Code.Var.fresh () in + let result2 = Code.Var.fresh () in + let block = + { params = []; + handler = None; + body = [ + Let (counter, Constant (Int 0l)); + Let (result1, Apply (f, counter :: args, true)); + Let (result2, Prim (Extern "caml_trampoline", [Pv result1])) + ]; + branch = Return result2 + } + in + block + + let wrapper_closure pc args = Closure (args, (pc, [])) + + let f closures blocks free_pc = + let names = + List.fold_left (fun names x -> VarSet.add x.f_name names) VarSet.empty closures + in + let closures_map = + List.fold_left (fun closures_map x -> VarMap.add x.f_name x closures_map) VarMap.empty closures + in + let graph = + List.fold_left (fun graph x -> + let tc = VarMap.fold (fun x _ tc -> VarSet.add x tc) x.tc VarSet.empty in + let tc = VarSet.inter names tc in + VarMap.add x.f_name tc graph) VarMap.empty closures + in + let components = SCC.connected_components_sorted_from_roots_to_leaf graph in + let (blocks, free_pc, instrs) = + Array.fold_left (fun (blocks, free_pc, instrs) component -> + match component with + | SCC.No_loop id -> + let ci = VarMap.find id closures_map in + let instr = Let (ci.f_name, Closure (ci.args, ci.cont)) in + blocks, free_pc, instr :: instrs + | SCC.Has_loop all -> + let all = List.map (fun id -> + Code.Var.fresh_n "counter", + VarMap.find id closures_map + ) all in + let blocks, free_pc, instrs = + List.fold_left (fun (blocks, free_pc, instrs) (counter, ci) -> + let new_f = Code.Var.fork ci.f_name in + let new_args = List.map Code.Var.fork ci.args in + let wrapper_pc = free_pc in + let free_pc = free_pc + 1 in + + let new_counter = Code.Var.fork counter in + let wrapper_block = wrapper_block new_f ~args:new_args ~counter:new_counter in + let blocks = AddrMap.add wrapper_pc wrapper_block blocks in + + let instr_wrapper = Let (ci.f_name, wrapper_closure wrapper_pc new_args) in + let instr_real = Let (new_f, Closure (counter :: ci.args, ci.cont)) in + + let counter_and_pc = + List.fold_left (fun acc (counter,ci2) -> + try + let pcs = AddrSet.elements (VarMap.find ci.f_name ci2.tc) in + List.map (fun x -> counter, x) pcs @ acc + with Not_found -> acc + ) [] all + in + let blocks, free_pc = + List.fold_left (fun (blocks, free_pc) (counter, pc) -> + let block = AddrMap.find pc blocks in + let direct_call_pc = free_pc in + let bounce_call_pc = free_pc + 1 in + let free_pc = free_pc + 2 in + match List.rev block.body with + | Let (x, Apply (f,args,true)) :: rem_rev -> + assert (f = ci.f_name); + let blocks = + AddrMap.add direct_call_pc + (direct_call_block block ~counter ~x ~f:new_f ~args) blocks + in + let blocks = + AddrMap.add bounce_call_pc + (bounce_call_block block ~x ~f:new_f ~args) blocks + in + let direct = Code.Var.fresh () in + let branch = Cond (IsTrue, direct, (direct_call_pc, []), (bounce_call_pc, [])) in + let last = + Let (direct, Prim (Lt, + [Pv counter; + Pc (Int (Int32.of_int (Option.Param.tailcall_max_depth ())))])) + in + let block = { block with body = List.rev (last :: rem_rev); branch = branch } in + AddrMap.add pc block blocks, free_pc + | _ -> assert false + ) (blocks, free_pc) counter_and_pc + in + blocks, free_pc, instr_real :: instr_wrapper :: instrs + ) (blocks, free_pc, instrs) all + in + blocks, free_pc, instrs + ) (blocks, free_pc, []) components + in + instrs, blocks, free_pc +end + +module Ident = struct + let f closures blocks free_pc = + let instrs = + List.map (fun ci -> + Let (ci.f_name, Closure (ci.args, ci.cont)) + ) closures + in + instrs, blocks, free_pc +end + +let rewrite_tc closures blocks free_pc = + let open Option.Param in + match tailcall_optim () with + | TcNone -> Ident.f closures blocks free_pc + | TcTrampoline -> Trampoline.f closures blocks free_pc + +let f ((pc, blocks, free_pc) as p) : Code.program = + let mutated_vars = Freevars.f p in + let rewrite_list = ref [] in + let blocks,free_pc = + AddrMap.fold + (fun pc block (blocks,free_pc) -> + let closures,rem = collect_closures mutated_vars blocks block.body in + let closures, blocks, free_pc = rewrite_tc closures blocks free_pc in + let body = closures @ rem in + let body_rev, blocks, free_pc = + List.fold_left + (fun (body_rev, blocks, free_pc) i -> + match i with + | Let (x, Closure (params, (pc, pc_args ))) -> + let all_vars = + try AddrMap.find pc mutated_vars + with Not_found -> VarSet.empty + in + let vars = VarSet.elements (VarSet.remove x all_vars) in + if vars = [] + then i::body_rev, blocks, free_pc + else begin + let new_pc = free_pc in + let free_pc = free_pc + 1 in + let closure = Code.Var.fork x in + let args = List.map Code.Var.fork vars in + let mapping = + Jsoo_subst.from_map + (Jsoo_subst.build_mapping vars args) + in + rewrite_list := (mapping, pc) :: !rewrite_list; + let body_rev = + Let (x, Apply (closure, vars, true)) + :: Let (closure, Closure (args, (new_pc, []))) + :: body_rev + in + let new_block = + let x = Code.Var.fork x in + { params = []; + handler = None; + body = [Let (x, Closure (params, (pc, List.map mapping pc_args)))]; + branch = Return x } + in + let blocks = AddrMap.add new_pc new_block blocks in + body_rev, blocks, free_pc + end + | _ -> i::body_rev, blocks, free_pc + ) + ([], blocks, free_pc) body + in + AddrMap.add pc { block with body = List.rev body_rev } blocks, free_pc + ) + blocks (blocks,free_pc) + in + List.fold_left (fun program (mapping,pc) -> + Jsoo_subst.cont mapping pc program + ) (pc, blocks, free_pc) !rewrite_list diff --git a/compiler/js_tailcall.mli b/compiler/generate_closure.mli similarity index 72% rename from compiler/js_tailcall.mli rename to compiler/generate_closure.mli index 7672bcbf6e..1bd672901a 100644 --- a/compiler/js_tailcall.mli +++ b/compiler/generate_closure.mli @@ -1,6 +1,7 @@ (* Js_of_ocaml compiler * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2014 Hugo Heuzard + * Copyright (C) 2010 Jérôme Vouillon + * Laboratoire PPS - CNRS Université Paris Diderot * * 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 @@ -17,13 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -class tailcall : object - inherit Js_traverse.mapper - method clear : unit - method get : Code.VarSet.t -end +open Code -val rewrite : - (Code.Var.t * Javascript.expression * Javascript.location * Code.VarSet.t) - list -> - (string -> Javascript.expression) -> Javascript.statement_list +val f : program -> program diff --git a/compiler/js_assign.ml b/compiler/js_assign.ml index 6159f9721d..34c04df6a7 100644 --- a/compiler/js_assign.ml +++ b/compiler/js_assign.ml @@ -18,6 +18,24 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Javascript +open Util +let debug = Option.Debug.find "shortvar" + +module S = Code.VarSet +module VM = Code.VarMap + +module Var = Code.Var + +module type Strategy = sig + type t + val create : int -> t + val record_block : t -> Js_traverse.t -> catch:bool -> Javascript.ident list -> unit + val allocate_variables : t -> count:int Javascript.IdentMap.t -> string array +end + +module Min : Strategy = struct + (* We are trying to achieve the following goals: (1) variable names should be as short as possible @@ -60,243 +78,307 @@ while compiling the OCaml toplevel: unchanged) *) -open Javascript + type alloc = + { mutable first_free : int; + mutable used : bool array } -let debug = Option.Debug.find "shortvar" + let make_alloc_table () = + { first_free = 0; + used = Array.make 32 false } -module S = Code.VarSet -module VM = Code.VarMap - -module Var = Code.Var - -type alloc = - { mutable first_free : int; - mutable used : bool array } - -let make_alloc_table () = - { first_free = 0; - used = Array.make 32 false } - -let next_available a i = - let i = ref (max i a.first_free) in - let len = Array.length a.used in - while !i < len && a.used.(!i) do incr i done; - !i - -let allocate a i = - let len = Array.length a.used in - if i >= len then begin - let l = ref len in - while l := 2 * !l; i >= !l do () done; - let u = Array.make !l false in - Array.blit a.used 0 u 0 len; - a.used <- u - end; - assert (not a.used.(i)); - a.used.(i) <- true; - if a.first_free = i then begin - let i = ref a.first_free in + let next_available a i = + let i = ref (max i a.first_free) in let len = Array.length a.used in while !i < len && a.used.(!i) do incr i done; - a.first_free <- !i - end - -let is_available l i = - List.for_all (fun a -> Array.length a.used <= i || not a.used.(i)) l - -let first_available l = - let rec find_rec n = - let n' = List.fold_left (fun n a -> next_available a n) n l in - if n = n' then n else find_rec n' - in - find_rec 0 + !i -let mark_allocated l i = List.iter (fun a -> allocate a i) l - -type g = { - constr : alloc list array; (* Constraints on variables *) - mutable parameters : Var.t list array; (* Function parameters *) - mutable constraints : S.t list } (* For debugging *) - -let create nv = - { constr = Array.make nv []; - parameters = [|[]|]; - constraints = [] } - -let output_debug_information t count = - - - let weight v = (IdentMap.find (V v) count) in - - let usage = - List.fold_left - (fun u s -> - S.fold - (fun v u -> VM.add v (try 1 + VM.find v u with Not_found -> 1) u) - s u) - VM.empty t.constraints - in - - let l = List.map fst (VM.bindings usage) in - - let ch = open_out "/tmp/weights.txt" in - List.iter - (fun v -> - Printf.fprintf ch "%d / %d / %d\n" (weight v) - (VM.find v usage) (Code.Var.idx v)) - l; - close_out ch; - - let ch = open_out "/tmp/problem.txt" in - Printf.fprintf ch "Maximize\n"; - let a = Array.of_list l in - Printf.fprintf ch " "; - for i = 0 to Array.length a - 1 do - let v = a.(i) in - let w = weight v in - if i > 0 then Printf.fprintf ch " + "; - Printf.fprintf ch "%d x%d" w (Code.Var.idx v) - done; - Printf.fprintf ch "\n"; - Printf.fprintf ch "Subject To\n"; - List.iter - (fun s -> - if S.cardinal s > 0 then begin - Printf.fprintf ch " "; - let a = Array.of_list (S.elements s) in - for i = 0 to Array.length a - 1 do - if i > 0 then Printf.fprintf ch " + "; - Printf.fprintf ch "x%d" (Code.Var.idx a.(i)) - done; - Printf.fprintf ch "<= 54\n" - end) - t.constraints; - Printf.fprintf ch "Binary\n "; - List.iter (fun v -> Printf.fprintf ch " x%d" (Code.Var.idx v)) l; - Printf.fprintf ch "\nEnd\n"; - close_out ch; - - let ch = open_out "/tmp/problem2" in - let var x = string_of_int (Code.Var.idx x) in - let a = List.map (fun v -> (var v, weight v)) l in - let b = - List.map (fun s -> List.map var (S.elements s)) t.constraints in - let c = List.map var l in - output_value ch - ((a, b, c) : (string * int) list * string list list * string list); - close_out ch - -let allocate_variables t nv count = - let weight v = try IdentMap.find (V (Code.Var.of_idx v)) count with Not_found -> 0 in - let constr = t.constr in - let len = nv in - let idx = Array.make len 0 in - for i = 0 to len - 1 do - idx.(i) <- i - done; - Array.stable_sort (fun i j -> compare (weight j) (weight i)) idx; - let name = Array.make len "" in - let n0 = ref 0 in - let n1 = ref 0 in - let n2 = ref 0 in - let n3 = ref 0 in - let stats i n = - incr n0; - if n < 54 then begin incr n1; n2 := !n2 + (weight i) end; - n3 := !n3 + (weight i) - in - let nm ~origin n = - name.(origin) <- Var.to_string ~origin:(Var.of_idx origin) (Var.of_idx n) in - let total = ref 0 in - let bad = ref 0 in - for i = 0 to Array.length t.parameters - 1 do - List.iter - (fun x -> - incr total; - let idx = Var.idx x in - let l = constr.(idx) in - if is_available l i then begin - nm ~origin:idx i; - mark_allocated l i; - stats idx i - end else - incr bad) - (List.rev t.parameters.(i)) - done; - if debug () then - Format.eprintf - "Function parameter properly assigned: %d/%d@." (!total - !bad) !total; - for i = 0 to len - 1 do - let l = constr.(idx.(i)) in - if l <> [] && String.length name.(idx.(i)) = 0 then begin - let n = first_available l in - let idx = idx.(i) in - nm ~origin:idx n; - mark_allocated l n; - stats idx n - end; - if l = [] then assert (weight (idx.(i)) = 0); - done; - if debug () then begin - Format.eprintf "short variable count: %d/%d@." !n1 !n0; - Format.eprintf "short variable occurrences: %d/%d@." !n2 !n3 - end; - name - -let add_constraints global u ?(offset=0) params = - if Option.Optim.shortvar () then begin - - let constr = global.constr in - let c = make_alloc_table () in - - S.iter (fun v -> let i = Code.Var.idx v in constr.(i) <- c :: constr.(i)) u; - let params = Array.of_list params in - let len = Array.length params in - let len_max = len + offset in - if Array.length global.parameters < len_max then begin - let a = Array.make (2 * len_max) [] in - Array.blit global.parameters 0 a 0 (Array.length global.parameters); - global.parameters <- a + let allocate a i = + let len = Array.length a.used in + if i >= len then begin + let l = ref len in + while l := 2 * !l; i >= !l do () done; + let u = Array.make !l false in + Array.blit a.used 0 u 0 len; + a.used <- u end; + assert (not a.used.(i)); + a.used.(i) <- true; + if a.first_free = i then begin + let i = ref a.first_free in + let len = Array.length a.used in + while !i < len && a.used.(!i) do incr i done; + a.first_free <- !i + end + + let is_available l i = + List.for_all (fun a -> Array.length a.used <= i || not a.used.(i)) l + + let first_available l = + let rec find_rec n = + let n' = List.fold_left (fun n a -> next_available a n) n l in + if n = n' then n else find_rec n' + in + find_rec 0 + + let mark_allocated l i = List.iter (fun a -> allocate a i) l + + type t = { + constr : alloc list array; (* Constraints on variables *) + mutable parameters : Var.t list array; (* Function parameters *) + mutable constraints : S.t list } (* For debugging *) + + let create nv = + { constr = Array.make nv []; + parameters = [|[]|]; + constraints = [] } + + (* let output_debug_information t count = + * + * + * let weight v = (IdentMap.find (V v) count) in + * + * let usage = + * List.fold_left + * (fun u s -> + * S.fold + * (fun v u -> VM.add v (try 1 + VM.find v u with Not_found -> 1) u) + * s u) + * VM.empty t.constraints + * in + * + * let l = List.map fst (VM.bindings usage) in + * + * let ch = open_out "/tmp/weights.txt" in + * List.iter + * (fun v -> + * Printf.fprintf ch "%d / %d / %d\n" (weight v) + * (VM.find v usage) (Var.idx v)) + * l; + * close_out ch; + * + * let ch = open_out "/tmp/problem.txt" in + * Printf.fprintf ch "Maximize\n"; + * let a = Array.of_list l in + * Printf.fprintf ch " "; + * for i = 0 to Array.length a - 1 do + * let v = a.(i) in + * let w = weight v in + * if i > 0 then Printf.fprintf ch " + "; + * Printf.fprintf ch "%d x%d" w (Var.idx v) + * done; + * Printf.fprintf ch "\n"; + * Printf.fprintf ch "Subject To\n"; + * List.iter + * (fun s -> + * if S.cardinal s > 0 then begin + * Printf.fprintf ch " "; + * let a = Array.of_list (S.elements s) in + * for i = 0 to Array.length a - 1 do + * if i > 0 then Printf.fprintf ch " + "; + * Printf.fprintf ch "x%d" (Var.idx a.(i)) + * done; + * Printf.fprintf ch "<= 54\n" + * end) + * t.constraints; + * Printf.fprintf ch "Binary\n "; + * List.iter (fun v -> Printf.fprintf ch " x%d" (Var.idx v)) l; + * Printf.fprintf ch "\nEnd\n"; + * close_out ch; + * + * let ch = open_out "/tmp/problem2" in + * let var x = string_of_int (Var.idx x) in + * let a = List.map (fun v -> (var v, weight v)) l in + * let b = + * List.map (fun s -> List.map var (S.elements s)) t.constraints in + * let c = List.map var l in + * output_value ch + * ((a, b, c) : (string * int) list * string list list * string list); + * close_out ch *) + + let allocate_variables t ~count = + let weight v = try IdentMap.find (V (Var.of_idx v)) count with Not_found -> 0 in + let constr = t.constr in + let len = Array.length constr in + let idx = Array.make len 0 in + for i = 0 to len - 1 do + idx.(i) <- i + done; + Array.stable_sort (fun i j -> compare (weight j) (weight i)) idx; + let name = Array.make len "" in + let n0 = ref 0 in + let n1 = ref 0 in + let n2 = ref 0 in + let n3 = ref 0 in + let stats i n = + incr n0; + if n < 54 then begin incr n1; n2 := !n2 + (weight i) end; + n3 := !n3 + (weight i) + in + let nm ~origin n = + name.(origin) <- Var.to_string ~origin:(Var.of_idx origin) (Var.of_idx n) in + let total = ref 0 in + let bad = ref 0 in + for i = 0 to Array.length t.parameters - 1 do + List.iter + (fun x -> + incr total; + let idx = Var.idx x in + let l = constr.(idx) in + if is_available l i then begin + nm ~origin:idx i; + mark_allocated l i; + stats idx i + end else + incr bad) + (List.rev t.parameters.(i)) + done; + if debug () then + Format.eprintf + "Function parameter properly assigned: %d/%d@." (!total - !bad) !total; for i = 0 to len - 1 do - match params.(i) with + let l = constr.(idx.(i)) in + if l <> [] && String.length name.(idx.(i)) = 0 then begin + let n = first_available l in + let idx = idx.(i) in + nm ~origin:idx n; + mark_allocated l n; + stats idx n + end; + if l = [] then assert (weight (idx.(i)) = 0); + done; + if debug () then begin + Format.eprintf "short variable count: %d/%d@." !n1 !n0; + Format.eprintf "short variable occurrences: %d/%d@." !n2 !n3 + end; + name + + let add_constraints global u ?(offset=0) params = + if Option.Optim.shortvar () then begin + + let constr = global.constr in + let c = make_alloc_table () in + + S.iter (fun v -> let i = Var.idx v in constr.(i) <- c :: constr.(i)) u; + let params = Array.of_list params in + let len = Array.length params in + let len_max = len + offset in + if Array.length global.parameters < len_max then begin + let a = Array.make (2 * len_max) [] in + Array.blit global.parameters 0 a 0 (Array.length global.parameters); + global.parameters <- a + end; + for i = 0 to len - 1 do + match params.(i) with | V x -> global.parameters.(i + offset) <- x :: global.parameters.(i + offset) | _ -> () - done; - global.constraints <- u :: global.constraints - end - -class ['state] color (state : 'state) = object(m) - inherit Js_traverse.free as super + done; + global.constraints <- u :: global.constraints + end - method block ?(catch =false) params = + let record_block state scope ~catch params = let offset = if catch then 5 else 0 in - let all = S.union m#state.Js_traverse.def m#state.Js_traverse.use in + let all = S.union scope.Js_traverse.def scope.Js_traverse.use in add_constraints state all ~offset params; - super#block params +end +module Preserve : Strategy = struct + (* Try to preserve variable names. + - Assign the origin name if present: "{original_name}" + - If present but not available, derive a similar name: "{original_name}${n}" (eg. result$3). + - If not present, make up a name: "$${n}" + + Color variables one scope/block at a time - outer scope first. + *) + + type t = { + size : int; + mutable scopes : (S.t * Js_traverse.t) list + } + let create size = { size ; scopes = [] } + + let record_block t scope ~catch param = + let defs = match catch, param with + | true, [V x] -> S.singleton x + | true, [S _] -> S.empty + | true, _ -> assert false + | false, _ -> scope.Js_traverse.def + in + t.scopes <- (defs,scope) :: t.scopes + let allocate_variables t ~count:_ = + let names = Array.make t.size "" in + List.iter (fun (defs, state) -> + let assigned = + List.fold_left StringSet.union StringSet.empty + [ + state.Js_traverse.def_name; + state.Js_traverse.use_name; + Reserved.keyword + ] + in + let assigned = S.fold (fun var acc -> + let name = names.(Var.idx var) in + if name <> "" + then StringSet.add name acc + else acc + ) (S.union state.Js_traverse.use state.Js_traverse.def) assigned in + let _assigned = S.fold (fun var assigned -> + assert (names.(Var.idx var) = ""); + let name = + match Var.get_name var with + | Some expected_name -> + assert(expected_name <> ""); + if not (StringSet.mem expected_name assigned) + then expected_name + else + let i = ref 0 in + while StringSet.mem (Printf.sprintf "%s$%d" expected_name !i) assigned do + incr i + done; + Printf.sprintf "%s$%d" expected_name !i + | None -> Var.to_string var + in + names.(Var.idx var) <- name; + StringSet.add name assigned + ) defs assigned in + () + ) t.scopes; + names + end +class traverse record_block = object(m) + inherit Js_traverse.free as super + method block ?(catch=false) params = + record_block m#state ~catch params; + super#block params +end -let program p = - let color,p = - if Option.Optim.shortvar () - then - let nv = Code.Var.count () in - let state = create nv in - let coloring = new color state in - let p = coloring#program p in - coloring#block []; - if S.cardinal (coloring#get_free) <> 0 - then begin - Util.failwith_ "Some variables escaped (#%d)" (S.cardinal (coloring#get_free)) - (* S.iter(fun s -> (Format.eprintf "%s@." (Code.Var.to_string s))) coloring#get_free *) - end; - let name = allocate_variables state nv coloring#state.Js_traverse.count in - if debug () then output_debug_information state coloring#state.Js_traverse.count; - (function V v -> S {name=name.(Code.Var.idx v);var=Some v} | x -> x),p - else (function V v -> S {name=Var.to_string v;var=Some v} | x -> x),p +let program' (module Strategy : Strategy) p = + let nv = Var.count () in + let state = Strategy.create nv in + let mapper = new traverse (Strategy.record_block state) in + let p = mapper#program p in + mapper#block []; + if S.cardinal (mapper#get_free) <> 0 + then begin + Util.failwith_ "Some variables escaped (#%d)" (S.cardinal (mapper#get_free)) + (* S.iter(fun s -> (Format.eprintf "%s@." (Var.to_string s))) coloring#get_free *) + end; + let names = Strategy.allocate_variables state ~count:mapper#state.Js_traverse.count in + (* if debug () then output_debug_information state coloring#state.Js_traverse.count; *) + let color = function + | V v -> + let name = names.(Var.idx v) in + assert (name <> ""); + S {name;var=Some v} + | x -> x in (new Js_traverse.subst color)#program p + + +let program p = + if Option.Optim.shortvar () + then program' (module Min) p + else program' (module Preserve) p diff --git a/compiler/js_tailcall.ml b/compiler/js_tailcall.ml deleted file mode 100644 index 2d4b74122e..0000000000 --- a/compiler/js_tailcall.ml +++ /dev/null @@ -1,188 +0,0 @@ -(* Js_of_ocaml compiler - * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2014 Hugo Heuzard - * - * 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 -module J = Javascript -open Js_traverse -open Javascript - - -class tailcall = object(m) - inherit map as super - - val mutable tc = VarSet.empty - - method expression e = - match e with - | EFun _ -> e - | _ -> super#expression e - - method statement s = - let s = super#statement s in - match s with - | Return_statement (Some e) -> - ignore(m#last_e e); - s - | _ -> s - - method source s = - match s with - | Function_declaration _ -> s - | Statement s -> Statement (m#statement s) - - method get = tc - - method clear = tc <- VarSet.empty - - method private last_e e = - match e with - | ECall (EVar (V var), _args, _) -> tc <- VarSet.add var tc - | ESeq (_,e) -> m#last_e e - | ECond (_,e1,e2) -> m#last_e e1;m#last_e e2 - | _ -> () -end - -class tailcall_rewrite f = object(m) - inherit map as super - method expression e = - match e with - | EFun _ -> e - | _ -> super#expression e - - method statement s = - let s = super#statement s in - match s with - | Return_statement(Some e) -> begin match m#last_e e with - | None -> s - | Some s -> s - end - | _ -> s - - method private last_e e = - match e with - | ECall (EVar var,args, _) -> f var args - | ECond (cond,e1,e2) -> - let e1' = m#last_e e1 in - let e2' = m#last_e e2 in - begin match e1',e2' with - | None,None -> None - | Some s,None -> - Some (If_statement(cond,(s, N),Some (Return_statement (Some e2),N))) - | None,Some s -> - Some (If_statement(cond,(Return_statement (Some e1),N),Some (s, N))) - | Some s1,Some s2 -> - Some (If_statement(cond,(s1, N),Some (s2, N))) - end - | ESeq (e1,e2) -> - begin match m#last_e e2 with - | None -> None - | Some s2 -> Some (Block ([(Expression_statement e1, N);(s2, N)])) - end - | _ -> None - method source s = - match s with - | Statement st -> Statement (m#statement st) - | Function_declaration _ -> s - - -end - - -module type TC = sig - val rewrite : - (Code.Var.t * Javascript.expression * J.location * VarSet.t) list -> - (string -> Javascript.expression) -> Javascript.statement_list -end - -module Ident : TC = struct - let rewrite closures _get_prim = - [J.Variable_statement - (List.map (fun (name, cl, loc, _) -> J.V name, Some (cl, loc)) - closures), J.N] - -end - -module While : TC = struct - let rewrite _closures _get_prim = failwith "todo" -end - -module Tramp : TC = struct - - let rewrite cls get_prim = - match cls with - | [x,_cl,_,req_tc] when not (VarSet.mem x req_tc) -> - Ident.rewrite cls get_prim - | _ -> - let counter = Var.fresh () in - Var.name counter "counter"; - let _m2old,m2new = List.fold_right (fun (v,_,_,_) (m2old,m2new) -> - let v' = Var.fork v in - VarMap.add v' v m2old, VarMap.add v v' m2new - ) cls (VarMap.empty,VarMap.empty)in - let rewrite v args = - try - match v with - | J.S _ -> None - | J.V v -> - let n = J.V (VarMap.find v m2new) in - let st = J.Return_statement ( - Some ( - J.ECond ( - J.EBin (J.Lt, - J.EVar (J.V counter), - J.ENum (float_of_int (Option.Param.tailcall_max_depth ()))), - J.ECall(J.EVar n, J.EBin (J.Plus,J.ENum 1.,J.EVar (J.V counter)) :: args,J.N), - J.ECall ( - get_prim "caml_trampoline_return", - [J.EVar n ; J.EArr (List.map (fun x -> Some x) (J.ENum 0. :: args))], J.N - )))) - in Some st - with Not_found -> None - in - let rw = new tailcall_rewrite rewrite in - let wrappers = List.map (fun (v,clo,_,_) -> - match clo with - | J.EFun (_, args, _, nid) -> - let b = J.ECall( - get_prim "caml_trampoline", - [J.ECall(J.EVar (J.V (VarMap.find v m2new)), J.ENum 0. :: List.map (fun i -> J.EVar i) args, J.N)], J.N) in - let b = (J.Statement (J.Return_statement (Some b)), J.N) in - v,J.EFun (None, args,[b],nid ) - | _ -> assert false) cls in - let reals = List.map (fun (v,clo,_,_) -> - VarMap.find v m2new, - match clo with - | J.EFun (nm,args,body,nid) -> - J.EFun (nm,(J.V counter)::args,rw#sources body, nid) - | _ -> assert false - ) cls in - let make binds = - [J.Variable_statement - (List.map (fun (name, ex) -> J.V (name), Some (ex, J.N)) binds), - J.N] in - make (reals@wrappers) - -end - -let rewrite l = - let open Option.Param in - match tailcall_optim () with - | TcNone -> Ident.rewrite l - | TcTrampoline -> Tramp.rewrite l - | TcWhile -> While.rewrite l diff --git a/compiler/js_traverse.ml b/compiler/js_traverse.ml index 1c5cb3d0b8..eea5d86b6f 100644 --- a/compiler/js_traverse.ml +++ b/compiler/js_traverse.ml @@ -246,8 +246,7 @@ class share_constant = object(m) | _ -> None in match shareit with | Some name -> - let v = Code.Var.fresh () in - Code.Var.name v name; + let v = Code.Var.fresh_n name in Hashtbl.add all x (V v) | _ -> () ) count ; @@ -454,8 +453,7 @@ class rename_variable keeps = object if StringSet.mem name keeps then () else - let v = Code.Var.fresh () in - Code.Var.name v name; + let v = Code.Var.fresh_n name in Hashtbl.add h name v) from#state.def_name in let f = function | (S {name}) when Hashtbl.mem h name -> V (Hashtbl.find h name) @@ -476,8 +474,7 @@ class rename_variable keeps = object | Try_statement (b,w,f) -> let w = match w with | Some(S {name},block) -> - let v = Code.Var.fresh () in - Code.Var.name v name; + let v = Code.Var.fresh_n name in let sub = function | S {name=name'} when name' = name -> V v | x -> x in diff --git a/compiler/jsoo_strongly_connected_components.ml b/compiler/jsoo_strongly_connected_components.ml new file mode 100644 index 0000000000..62a9bc2043 --- /dev/null +++ b/compiler/jsoo_strongly_connected_components.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module IntSet = Set.Make(struct type t = int let compare = compare end) + +module Kosaraju : sig + type component_graph = + { sorted_connected_components : int list array; + component_edges : int list array; + } + + val component_graph : int list array -> component_graph +end = struct + let transpose graph = + let size = Array.length graph in + let transposed = Array.make size [] in + let add src dst = transposed.(src) <- dst :: transposed.(src) in + Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts) + graph; + transposed + + let depth_first_order (graph : int list array) : int array = + let size = Array.length graph in + let marked = Array.make size false in + let stack = Array.make size ~-1 in + let pos = ref 0 in + let push i = + stack.(!pos) <- i; + incr pos + in + let rec aux node = + if not marked.(node) + then begin + marked.(node) <- true; + List.iter aux graph.(node); + push node + end + in + for i = 0 to size - 1 do + aux i + done; + stack + + let mark order graph = + let size = Array.length graph in + let graph = transpose graph in + let marked = Array.make size false in + let id = Array.make size ~-1 in + let count = ref 0 in + let rec aux node = + if not marked.(node) + then begin + marked.(node) <- true; + id.(node) <- !count; + List.iter aux graph.(node) + end + in + for i = size - 1 downto 0 do + let node = order.(i) in + if not marked.(node) + then begin + aux order.(i); + incr count + end + done; + id, !count + + let kosaraju graph = + let dfo = depth_first_order graph in + let components, ncomponents = mark dfo graph in + ncomponents, components + + type component_graph = + { sorted_connected_components : int list array; + component_edges : int list array; + } + + let component_graph graph = + let ncomponents, components = kosaraju graph in + let id_scc = Array.make ncomponents [] in + let component_graph = Array.make ncomponents IntSet.empty in + let add_component_dep node set = + let node_deps = graph.(node) in + List.fold_left (fun set dep -> IntSet.add components.(dep) set) + set node_deps + in + Array.iteri (fun node component -> + id_scc.(component) <- node :: id_scc.(component); + component_graph.(component) <- + add_component_dep node (component_graph.(component))) + components; + { sorted_connected_components = id_scc; + component_edges = Array.map IntSet.elements component_graph; + } +end + +module type S = sig + module Id : sig + type t + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + end + type directed_graph = Id.Set.t Id.Map.t + + type component = + | Has_loop of Id.t list + | No_loop of Id.t + + val connected_components_sorted_from_roots_to_leaf + : directed_graph + -> component array + + val component_graph : directed_graph -> (component * int list) array +end + +module Make (Id : sig + type t + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + end) = struct + + module Id = Id + + type directed_graph = Id.Set.t Id.Map.t + + type component = + | Has_loop of Id.t list + | No_loop of Id.t + + type numbering = { + back : int Id.Map.t; + forth : Id.t array; + } + + let number graph = + let size = Id.Map.cardinal graph in + let bindings = Id.Map.bindings graph in + let a = Array.of_list bindings in + let forth = Array.map fst a in + let back = + let back = ref Id.Map.empty in + for i = 0 to size - 1 do + back := Id.Map.add forth.(i) i !back; + done; + !back + in + let integer_graph = + Array.init size (fun i -> + let _, dests = a.(i) in + Id.Set.fold (fun dest acc -> + let v = + try Id.Map.find dest back + with Not_found -> assert false + in + v :: acc) + dests []) + in + { back; forth }, integer_graph + + let component_graph graph = + let numbering, integer_graph = number graph in + let { Kosaraju. sorted_connected_components; + component_edges } = + Kosaraju.component_graph integer_graph + in + Array.mapi (fun component nodes -> + match nodes with + | [] -> assert false + | [node] -> + (if List.mem node integer_graph.(node) + then Has_loop [numbering.forth.(node)] + else No_loop numbering.forth.(node)), + component_edges.(component) + | _::_ -> + (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)), + component_edges.(component)) + sorted_connected_components + + let connected_components_sorted_from_roots_to_leaf graph = + Array.map fst (component_graph graph) +end diff --git a/compiler/jsoo_strongly_connected_components.mli b/compiler/jsoo_strongly_connected_components.mli new file mode 100644 index 0000000000..a729a17b5b --- /dev/null +++ b/compiler/jsoo_strongly_connected_components.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Kosaraju's algorithm for strongly connected components. *) + +module type S = sig + module Id : sig + type t + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + end + type directed_graph = Id.Set.t Id.Map.t + (** If (a -> set) belongs to the map, it means that there are edges + from [a] to every element of [set]. It is assumed that no edge + points to a vertex not represented in the map. *) + + type component = + | Has_loop of Id.t list + | No_loop of Id.t + + val connected_components_sorted_from_roots_to_leaf + : directed_graph + -> component array + + val component_graph : directed_graph -> (component * int list) array +end + +module Make (Id : sig + type t + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + end) : S with module Id = Id + diff --git a/compiler/jsoo_subst.ml b/compiler/jsoo_subst.ml index 164d3937ea..ecce9e674f 100644 --- a/compiler/jsoo_subst.ml +++ b/compiler/jsoo_subst.ml @@ -20,6 +20,8 @@ open Code +let subst_cont s (pc, arg) = (pc, List.map (fun x -> s x) arg) + let expr s e = match e with Const _ | Constant _ -> @@ -31,7 +33,7 @@ let expr s e = | Field (x, n) -> Field (s x, n) | Closure (l, pc) -> - Closure (l, pc) + Closure (l, subst_cont s pc) | Prim (p, l) -> Prim (p, List.map (fun x -> match x with Pv x -> Pv (s x) | Pc _ -> x) l) @@ -48,8 +50,6 @@ let instr s i = let instrs s l = List.map (fun i -> instr s i) l -let subst_cont s (pc, arg) = (pc, List.map (fun x -> s x) arg) - let last s l = match l with Stop -> @@ -69,20 +69,41 @@ let last s l = Array.map (fun cont -> subst_cont s cont) a1, Array.map (fun cont -> subst_cont s cont) a2) | Poptrap cont -> - Poptrap (subst_cont s cont) + Poptrap (subst_cont s cont) + +let block s block = + { params = block.params; + handler = Util.opt_map + (fun (x, cont) -> (x, subst_cont s cont)) block.handler; + body = instrs s block.body; + branch = last s block.branch } let program s (pc, blocks, free_pc) = - let blocks = - AddrMap.map - (fun block -> - { params = block.params; - handler = Util.opt_map - (fun (x, cont) -> (x, subst_cont s cont)) block.handler; - body = instrs s block.body; - branch = last s block.branch }) blocks - in + let blocks = AddrMap.map (fun b -> block s b) blocks in (pc, blocks, free_pc) +let rec cont' s pc blocks visited = + if AddrSet.mem pc visited + then blocks, visited + else + let visited = AddrSet.add pc visited in + let b = AddrMap.find pc blocks in + let b = block s b in + let blocks = AddrMap.add pc b blocks in + let blocks,visited = + List.fold_left (fun (blocks, visited) instr -> + match instr with + | Let (_, Closure (_, (pc,_))) -> cont' s pc blocks visited + | _ -> blocks, visited + ) (blocks, visited) b.body + in + Code.fold_children blocks pc + (fun pc (blocks,visited) -> cont' s pc blocks visited) + (blocks, visited) + +let cont s addr (pc, blocks, free_pc) = + let blocks,_ = cont' s addr blocks AddrSet.empty in + (pc, blocks, free_pc) (****) let from_array s = diff --git a/compiler/jsoo_subst.mli b/compiler/jsoo_subst.mli index e7489414b9..8fd10a094a 100644 --- a/compiler/jsoo_subst.mli +++ b/compiler/jsoo_subst.mli @@ -26,6 +26,7 @@ val instr : (Var.t -> Var.t) -> instr -> instr val instrs : (Var.t -> Var.t) -> instr list -> instr list val last : (Var.t -> Var.t) -> last -> last +val cont : (Var.t -> Var.t) -> int -> program -> program val from_array : Var.t option array -> Var.t -> Var.t val build_mapping : Var.t list -> Var.t list -> Var.t VarMap.t diff --git a/compiler/option.ml b/compiler/option.ml index 1456aade90..c2cafde295 100644 --- a/compiler/option.ml +++ b/compiler/option.ml @@ -159,11 +159,11 @@ module Param = struct type tc = | TcNone | TcTrampoline - | TcWhile + (* | TcWhile *) let tc_default = TcTrampoline - let _tc_all = tc_default :: List.filter ((<>) tc_default) [TcNone;TcTrampoline(* ;TcWhile *)] + let _tc_all = tc_default :: List.filter ((<>) tc_default) [TcNone;TcTrampoline] let tailcall_optim = p ~name:"tc" diff --git a/compiler/option.mli b/compiler/option.mli index 1e2b723881..c463802a3b 100644 --- a/compiler/option.mli +++ b/compiler/option.mli @@ -62,7 +62,7 @@ module Param : sig type tc = | TcNone | TcTrampoline - | TcWhile + (* | TcWhile *) val tailcall_optim : unit -> tc end diff --git a/compiler/parse_bytecode.ml b/compiler/parse_bytecode.ml index bc3d80aa2f..7c8d90e031 100644 --- a/compiler/parse_bytecode.ml +++ b/compiler/parse_bytecode.ml @@ -510,8 +510,7 @@ module State = struct Dummy -> Dummy :: stack | Var x -> - let y = Var.fresh () in - Var.propagate_name x y; + let y = Var.fork x in Var y :: stack) state.stack [] in @@ -1820,10 +1819,9 @@ let override_global = Prim(Extern "%overrideMod",[Pc (String name);Pc (String func)]) in [ "CamlinternalMod",(fun _orig instrs -> - let x = Var.fresh () in - Var.name x "internalMod"; - let init_mod = Var.fresh () in - let update_mod = Var.fresh () in + let x = Var.fresh_n "internalMod" in + let init_mod = Var.fresh_n "init_mod" in + let update_mod = Var.fresh_n "update_mod" in x, Let(x,Block(0,[| init_mod; update_mod |])):: Let(init_mod,jsmodule "CamlinternalMod" "init_mod"):: Let(update_mod,jsmodule "CamlinternalMod" "update_mod"):: diff --git a/compiler/reserved.ml b/compiler/reserved.ml index 272215f7c0..f0e9575884 100644 --- a/compiler/reserved.ml +++ b/compiler/reserved.ml @@ -54,6 +54,10 @@ let keyword = List.fold_left (fun acc x -> StringSet.add x acc) "undefined"; "this"; + (* Unexpected eval or arguments in strict mode *) + "eval"; + "arguments"; + (* also reserved in ECMAScript 3 *) "abstract"; "boolean"; "byte"; "char"; "const"; "double"; "final"; "float"; "goto"; "int"; "long"; "native"; "short"; diff --git a/compiler/tailcall.ml b/compiler/tailcall.ml index ceb36f69be..5ac4617adb 100644 --- a/compiler/tailcall.ml +++ b/compiler/tailcall.ml @@ -44,22 +44,23 @@ let rewrite_block (f, f_params, f_pc, args) pc blocks = (*Format.eprintf "%d@." pc;*) let block = AddrMap.find pc blocks in match block.branch with - | Return x -> - begin match tail_call x f block.body with - Some f_args when List.length f_params = List.length f_args -> - let m = Subst.build_mapping f_params f_args in - AddrMap.add pc - { params = block.params; - handler = block.handler; - body = remove_last block.body; - branch = - Branch (f_pc, List.map (fun x -> VarMap.find x m) args) } - blocks - | _ -> - blocks - end + | Return x -> + begin match tail_call x f block.body with + Some f_args when List.length f_params = List.length f_args -> + let m = Subst.build_mapping f_params f_args in + List.iter2 (fun p a -> Code.Var.propagate_name p a) f_params f_args; + AddrMap.add pc + { params = block.params; + handler = block.handler; + body = remove_last block.body; + branch = + Branch (f_pc, List.map (fun x -> VarMap.find x m) args) } + blocks | _ -> blocks + end + | _ -> + blocks let (>>) x f = f x diff --git a/compiler/util.cppo.ml b/compiler/util.cppo.ml index f010bb6426..74760440ab 100644 --- a/compiler/util.cppo.ml +++ b/compiler/util.cppo.ml @@ -123,6 +123,11 @@ let take n l = let x,xs = take' [] n l in List.rev x, xs +let rec last = function + | [] -> None + | [x] -> Some x + | _ :: xs -> last xs + module Timer = struct type t = float let timer = ref (fun _ -> 0.) diff --git a/compiler/util.mli b/compiler/util.mli index efa895b791..05959f8f43 100644 --- a/compiler/util.mli +++ b/compiler/util.mli @@ -43,6 +43,7 @@ val absolute_path : string -> string val read_file : string -> string val take : int -> 'a list -> 'a list * 'a list +val last : 'a list -> 'a option val is_ascii : string -> bool val has_backslash : string -> bool diff --git a/compiler/varPrinter.ml b/compiler/varPrinter.ml index ecf2b81e51..9ef6e21432 100644 --- a/compiler/varPrinter.ml +++ b/compiler/varPrinter.ml @@ -33,7 +33,15 @@ let c2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$" let name_raw t v nm = Hashtbl.add t.names v nm let propagate_name t v v' = - try name_raw t v' (Hashtbl.find t.names v) with Not_found -> () + try + let name = Hashtbl.find t.names v in + name_raw t v' name(* ; + * (try + * let n = Hashtbl.find t.names v' in + * if n <> name + * then Printf.eprintf "erasing name %s by %s\n%!" n name + * with _ -> ()) *) + with Not_found -> () let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') let is_num c = (c >= '0' && c <= '9') @@ -64,6 +72,8 @@ let name t v nm_orig = then name_raw t v str end +let get_name t v = try Some (Hashtbl.find t.names v) with Not_found -> None + let rec format_ident x = assert (x >= 0); let char c x = String.make 1 (c.[x]) in diff --git a/compiler/varPrinter.mli b/compiler/varPrinter.mli index e35c865e1f..c5ba78702a 100644 --- a/compiler/varPrinter.mli +++ b/compiler/varPrinter.mli @@ -25,6 +25,7 @@ val create : ?pretty:bool -> ?stable:bool -> unit -> t val reset : t -> unit val to_string : t -> ?origin:int -> int -> string val name : t -> int -> string -> unit +val get_name : t -> int -> string option val propagate_name : t -> int -> int -> unit val set_pretty : t -> bool -> unit val set_stable : t -> bool -> unit diff --git a/examples/Makefile.common b/examples/Makefile.common index 710597a63d..3502fd77c6 100644 --- a/examples/Makefile.common +++ b/examples/Makefile.common @@ -8,7 +8,7 @@ OCAMLC=ocamlfind ocamlc -g -package lwt -pp "camlp4o ../../lib/syntax/pa_js.cmo" STDLIB=$(LIBNAME).cma $(NAME).js: $(NAME).byte $(COMP) $(JSFILES) - $(COMP) --noruntime $(JSFILES) $(OPTIONS) --source-map $(NAME).byte --debug-info --pretty -I ../../../lwt + $(COMP) --noruntime $(JSFILES) $(OPTIONS) --source-map $(NAME).byte --disable shortvar --pretty -I ../../../lwt $(NAME).byte: $(OBJS) $(OCAMLC) -linkpkg -o $@ $(STDLIB) $^