diff --git a/compiler/driver.ml b/compiler/driver.ml index 7ac8fbdf27..662aac3adf 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -154,10 +154,10 @@ let o3 = loop 10 "flow" round2 1 >> print -let generate d ?toplevel (p,live_vars) = +let generate d ~exported_runtime ~toplevel (p,live_vars) = if times () then Format.eprintf "Start Generation...@."; - Generate.f p ?toplevel live_vars d + Generate.f p ~toplevel ~exported_runtime live_vars d let header formatter ~standalone ~custom_header js = @@ -242,7 +242,7 @@ let gen_missing js missing = (Statement (Variable_statement miss), N) :: js -let link ~standalone ?linkall js = +let link ~standalone ?linkall ~export_runtime js = if standalone then begin @@ -275,6 +275,19 @@ let link ~standalone ?linkall js = then gen_missing js missing else js in if times () then Format.eprintf " linking: %a@." Util.Timer.print t; + let js = + if export_runtime + then + let open Javascript in + let all = Linker.all linkinfos in + let all = List.map (fun name -> PNI name,EVar (S {name ;var=None})) all in + (Statement (Expression_statement( + EBin(Eq, + EDot(EVar (S {name=global_object;var=None}),"jsoo_runtime"), + EObj all))),N) + :: js + else js + in Linker.link js linkinfos end else js @@ -348,7 +361,7 @@ let output formatter ?source_map js = Js_output.program formatter ?source_map js; if times () then Format.eprintf " write: %a@." Util.Timer.print t -let pack ~wrap_with_fun ?(toplevel=false) js = +let pack ~wrap_with_fun ~toplevel js = let module J = Javascript in let t = Util.Timer.make () in if times () @@ -433,16 +446,17 @@ let configure formatter p = type profile = Code.program -> Code.program let f ?(standalone=true) ?(wrap_with_fun=false) ?(profile=o1) - ?toplevel ?linkall ?source_map ?custom_header formatter d = + ?(toplevel=false) ?linkall ?source_map ?custom_header formatter d = + let exported_runtime = not standalone in configure formatter >> profile >> Generate_closure.f >> deadcode' >> - generate d ?toplevel >> + generate d ~exported_runtime ~toplevel >> - link ~standalone ?linkall >> + link ~standalone ?linkall ~export_runtime:toplevel >> - pack ~wrap_with_fun ?toplevel >> + pack ~wrap_with_fun ~toplevel >> coloring >> diff --git a/compiler/generate.ml b/compiler/generate.ml index cdd4c5e272..0466476836 100644 --- a/compiler/generate.ml +++ b/compiler/generate.ml @@ -227,10 +227,11 @@ module Ctx = struct { mutable blocks : block AddrMap.t; live : int array; share: Share.t; - debug : Parse_bytecode.Debug.data } + debug : Parse_bytecode.Debug.data; + exported_runtime : Code.Var.t option } - let initial blocks live share debug = - { blocks; live; share; debug } + let initial ~exported_runtime blocks live share debug = + { blocks; live; share; debug; exported_runtime } end @@ -266,6 +267,12 @@ let float_const f = val_float (J.ENum f) let s_var name = J.EVar (J.S {J.name=name; J.var = None}) +let runtime_fun ctx name = + match ctx.Ctx.exported_runtime with + | Some runtime -> + J.EDot (J.EVar (J.V runtime), name) + | None -> s_var name + let str_js s = J.EStr (s,`Bytes) @@ -296,7 +303,7 @@ let rec constant_rec ~ctx x level instrs = match x with String s -> let e = Share.get_string str_js s ctx.Ctx.share in - let p = Share.get_prim s_var "caml_new_string" ctx.Ctx.share in + let p = Share.get_prim (runtime_fun ctx) "caml_new_string" ctx.Ctx.share in J.ECall (p,[e],J.N), instrs | IString s -> Share.get_string str_js s ctx.Ctx.share, instrs @@ -328,7 +335,7 @@ let rec constant_rec ~ctx x level instrs = let (js, instrs) = constant_rec ~ctx elt level instrs in (Some js)::arr, instrs) ([], instrs) elts_rev in - let p = Share.get_prim s_var "caml_list_of_js_array" ctx.Ctx.share in + let p = Share.get_prim (runtime_fun ctx) "caml_list_of_js_array" ctx.Ctx.share in J.ECall (p,[J.EArr arr],J.N), instrs | None -> let split = level = constant_max_depth in @@ -672,15 +679,15 @@ let parallel_renaming params args continuation queue = (****) -let apply_fun_raw f params = +let apply_fun_raw ctx f params = let n = List.length params in J.ECond (J.EBin (J.EqEq, J.EDot (f, "length"), J.ENum (float n)), J.ECall (f, params, J.N), - J.ECall (s_var "caml_call_gen", + J.ECall (runtime_fun ctx "caml_call_gen", [f; J.EArr (List.map (fun x -> Some x) params)], J.N)) -let generate_apply_fun n = +let generate_apply_fun ctx n = let f' = Var.fresh_n "f" in let f = J.V f' in let params = @@ -693,14 +700,14 @@ let generate_apply_fun n = J.EFun (None, f :: params, [J.Statement (J.Return_statement - (Some (apply_fun_raw f' params'))), J.N], + (Some (apply_fun_raw ctx f' params'))), J.N], J.N) let apply_fun ctx f params loc = if Option.Optim.inline_callgen () - then apply_fun_raw f params + then apply_fun_raw ctx f params else - let y = Share.get_apply generate_apply_fun (List.length params) ctx.Ctx.share in + let y = Share.get_apply (generate_apply_fun ctx) (List.length params) ctx.Ctx.share in J.ECall (y, f::params, loc) (****) @@ -831,7 +838,7 @@ let register_bin_math_prim name prim = let _ = register_un_prim_ctx "%caml_format_int_special" `Pure (fun ctx cx loc -> - let p = Share.get_prim s_var "caml_new_string" ctx.Ctx.share in + let p = Share.get_prim (runtime_fun ctx) "caml_new_string" ctx.Ctx.share in J.ECall (p, [J.EBin (J.Plus,str_js "",cx)], loc)); register_bin_prim "caml_array_unsafe_get" `Mutable (fun cx cy _ -> J.EAccess (cx, plus_int cy one)); @@ -1014,7 +1021,7 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list = 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 + let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in prim, const_p, queue | Extern "%caml_js_opt_call", Pv f :: Pv o :: l -> let ((pf, cf), queue) = access_queue queue f in @@ -1073,7 +1080,7 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list = let ((po, co), queue) = access_queue queue o in (J.EUn(J.Delete, J.EDot (co, f)), or_p po mutator_p, queue) | Extern "%overrideMod", [Pc (String m | IString m);Pc (String f | IString f)] -> - s_var (Printf.sprintf "caml_%s_%s" m f), const_p,queue + runtime_fun ctx (Printf.sprintf "caml_%s_%s" m f), const_p,queue | Extern "%overrideMod", _ -> assert false | Extern "%caml_js_opt_object", fields -> @@ -1112,7 +1119,7 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list = | None -> if name.[0] = '%' then failwith (Printf.sprintf "Unresolved internal primitive: %s" name); - let prim = Share.get_prim s_var name ctx.Ctx.share in + let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in let prim_kind = kind (Primitive.kind name) in let (args, prop, queue) = List.fold_right @@ -1164,12 +1171,23 @@ and translate_instr ctx expr_queue loc instr = | Let (x, e) -> 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 + | Some s -> + not (String.length s >= 5 + && s.[0] = 'j' + && s.[1] = 's' + && s.[2] = 'o' + && s.[3] = 'o' + && s.[4] = '_') + 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 () && (not ( Option.Optim.pretty ()) - || Code.Var.get_name x = None) -> + || not (keep_name x)) -> enqueue expr_queue prop x ce loc 1 instrs (* We could inline more. size_v : length of the variable after serialization @@ -1322,7 +1340,7 @@ else begin J.EBin( J.Eq, J.EVar (J.V x), - J.ECall (Share.get_prim s_var "caml_wrap_exception" st.ctx.Ctx.share, + J.ECall (Share.get_prim (runtime_fun st.ctx) "caml_wrap_exception" st.ctx.Ctx.share, [J.EVar (J.V x)], J.N))),J.N) ::handler else handler in @@ -1753,15 +1771,25 @@ let generate_shared_value ctx = let strings = J.Statement ( J.Variable_statement ( - List.map (fun (s,v) -> v, Some (str_js s,J.N)) (StringMap.bindings ctx.Ctx.share.Share.vars.Share.strings) - @ List.map (fun (s,v) -> v, Some (s_var s,J.N)) (StringMap.bindings ctx.Ctx.share.Share.vars.Share.prims))), + (match ctx.Ctx.exported_runtime with + | None -> [] + | Some v -> + [J.V v, + Some (J.EDot (s_var Option.global_object, "jsoo_runtime"),J.N)]) + @ List.map (fun (s,v) -> + v, + Some (str_js s,J.N)) + (StringMap.bindings ctx.Ctx.share.Share.vars.Share.strings) + @ List.map (fun (s,v) -> + v, + Some (runtime_fun ctx s,J.N)) + (StringMap.bindings ctx.Ctx.share.Share.vars.Share.prims))), J.U in - if not (Option.Optim.inline_callgen ()) then let applies = List.map (fun (n,v) -> - match generate_apply_fun n with + match generate_apply_fun ctx n with | J.EFun (_,param,body,nid) -> J.Function_declaration (v,param,body,nid), J.U | _ -> assert false) (IntMap.bindings ctx.Ctx.share.Share.vars.Share.applies) in @@ -1774,10 +1802,15 @@ let compile_program ctx pc = if debug () then Format.eprintf "@.@."; res -let f ((pc, blocks, _) as p) ?toplevel live_vars debug = +let f ((pc, blocks, _) as p) ~toplevel ~exported_runtime live_vars debug = let t' = Util.Timer.make () in - let share = Share.get ?alias_prims:toplevel p in - let ctx = Ctx.initial blocks live_vars share debug in + let share = Share.get ~alias_prims:(toplevel && Option.Optim.shortvar ()) p in + let exported_runtime = + if exported_runtime + then Some (Code.Var.fresh_n "runtime") + else None + in + let ctx = Ctx.initial ~exported_runtime 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.mli b/compiler/generate.mli index 651ebb2282..366b860c21 100644 --- a/compiler/generate.mli +++ b/compiler/generate.mli @@ -19,5 +19,6 @@ *) val f : - Code.program -> ?toplevel:bool -> int array -> Parse_bytecode.Debug.data -> + Code.program -> toplevel:bool -> exported_runtime:bool + -> int array -> Parse_bytecode.Debug.data -> Javascript.program diff --git a/compiler/jsoo_compile.ml b/compiler/jsoo_compile.ml index 6c21e5f455..5d3489bb90 100644 --- a/compiler/jsoo_compile.ml +++ b/compiler/jsoo_compile.ml @@ -91,9 +91,9 @@ let f { if source_map <> None && Parse_bytecode.Debug.is_empty d then Util.warn - "Warning: '--source-map' is enabled but the bytecode program \ - was compiled with no debugging information.\n\ - Warning: Consider passing '-g' option to ocamlc.\n%!" + "Warning: '--source-map' is enabled but the bytecode program \ + was compiled with no debugging information.\n\ + Warning: Consider passing '-g' option to ocamlc.\n%!" in let cmis = if nocmis then Util.StringSet.empty else cmis in let p = diff --git a/compiler/linker.ml b/compiler/linker.ml index 11885427ae..a090f64ecb 100644 --- a/compiler/linker.ml +++ b/compiler/linker.ml @@ -224,15 +224,16 @@ let find_named_value code = let add_file f = List.iter (fun (provide,req,versions,(code:Javascript.program)) -> - incr last_code_id; - let id = !last_code_id in let vmatch = match versions with | [] -> true | l -> List.exists version_match l in if vmatch then begin + incr last_code_id; + let id = !last_code_id in (match provide with - | None -> always_included := id :: !always_included + | None -> + always_included := id :: !always_included | Some (pi,name,kind,ka) -> let module J = Javascript in let rec find = function @@ -329,6 +330,7 @@ let resolve_deps ?(linkall = false) visited_rev used = then begin (* link all primitives *) + let prog,set = Hashtbl.fold (fun nm (_id,_) (visited,set) -> resolve_dep_name_rev visited [] nm, @@ -350,3 +352,12 @@ let resolve_deps ?(linkall = false) visited_rev used = visited_rev, missing let link program state = List.flatten (List.rev (program::state.codes)) + +let all state = + IntSet.fold (fun id acc -> + try + let name,_ = Hashtbl.find provided_rev id in + name :: acc + with Not_found -> + acc + ) state.ids [] diff --git a/compiler/linker.mli b/compiler/linker.mli index 6e5bcbbdce..2f34a9a3ec 100644 --- a/compiler/linker.mli +++ b/compiler/linker.mli @@ -31,3 +31,4 @@ val init : unit -> state val resolve_deps : ?linkall:bool -> state -> Util.StringSet.t -> state * Util.StringSet.t val link : Javascript.program -> state -> Javascript.program val get_provided : unit -> Util.StringSet.t +val all : state -> string list diff --git a/compiler/parse_bytecode.ml b/compiler/parse_bytecode.ml index aa59b38a27..bb0a3efc09 100644 --- a/compiler/parse_bytecode.ml +++ b/compiler/parse_bytecode.ml @@ -1915,7 +1915,9 @@ let exe_from_channel ~includes ?(toplevel=false) ~debug ~debug_data ic = if toplevel then begin (* export globals *) - Tbl.iter (fun _ n -> globals.is_exported.(n) <- true) symbols.num_tbl; + Tbl.iter (fun id n -> + globals.named_value.(n) <- Some id.Ident.name; + globals.is_exported.(n) <- true) symbols.num_tbl; (* @vouillon: *) (* we should then use the -linkall option to build the toplevel. *) (* The OCaml compiler can generate code using this primitive but *) diff --git a/doc/Makefile b/doc/Makefile index f4389b2ff5..5c24e9391f 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -45,7 +45,7 @@ api/wiki/index.wiki: ${MLIS} api/index -i $(shell ocamlfind query wikidoc) -g odoc_wiki.cma \ ${MLIS} -EX_TOPLEVEL:=index.html toplevel.js *.cmis.js +EX_TOPLEVEL:=index.html toplevel.js test_dynlink.js *.cmis.js EX_BOULDER:=index.html boulderdash.js sprites EX_WEBGL:=index.html webgldemo.js EX_GRAPH:=index.html jsviewer.js diff --git a/toplevel/Makefile b/toplevel/Makefile index cc17dbfa28..15d6148e82 100644 --- a/toplevel/Makefile +++ b/toplevel/Makefile @@ -68,7 +68,7 @@ MKTOP=jsoo_mktop -verbose $(SAFESTRING) \ TOPLEVEL_NAME=toplevel TOPLEVEL_OBJS=colorize.cmo indent.cmo toplevel.cmo -$(TOPLEVEL_NAME).js: $(TOPLEVEL_OBJS) examples.ml test_dynlink.cmo +$(TOPLEVEL_NAME).js: $(TOPLEVEL_OBJS) examples.ml test_dynlink.cmo test_dynlink.js $(MKTOP) \ $(BER) \ $(OCPINDENT) $(HIGLO) \ @@ -76,9 +76,13 @@ $(TOPLEVEL_NAME).js: $(TOPLEVEL_OBJS) examples.ml test_dynlink.cmo ${addprefix -jsopt , ${JSFILES}} \ ${addprefix -jsopt , -I ./ --file examples.ml} \ ${addprefix -jsopt , -I ./ --file test_dynlink.cmo} \ + ${addprefix -jsopt , -I ./ --file test_dynlink.js} \ -package base64 \ -o $(TOPLEVEL_NAME).byte +test_dynlink.js: test_dynlink.cmo + js_of_ocaml test_dynlink.cmo --pretty + EVAL_NAME=eval EVAL_OBJS=eval.cmo $(EVAL_NAME).js: $(EVAL_OBJS) diff --git a/toplevel/toplevel.cppo.ml b/toplevel/toplevel.cppo.ml index 2932876f3d..f464045809 100644 --- a/toplevel/toplevel.cppo.ml +++ b/toplevel/toplevel.cppo.ml @@ -76,6 +76,8 @@ let setup_toplevel () = exec' (Printf.sprintf "Format.printf \"%s@.@.\";;" header3)); exec' ("#enable \"pretty\";;"); exec' ("#enable \"shortvar\";;"); + Hashtbl.add Toploop.directive_table "load_js" (Toploop.Directive_string (fun name -> + Js.Unsafe.global##load_script_(name))); Sys.interactive := true; ()