Compiler: dynlink javascript files

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 >>
 

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

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

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 =

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 []

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

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 *)

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

toplevel/Makefile

@@ -68,17 +68,21 @@ 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) \
 	$(TOPLEVEL_OBJS) \
 	${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)

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;
   ()