Compiler/Toplevel: restore runtime aliases inside toplevel

Author: hhugo

compiler/bin-js_of_ocaml/compile.ml

@@ -336,10 +336,17 @@ let run
   in
   let output_partial_runtime ~standalone ~source_map ((_, fmt) as output_file) =
     assert (not standalone);
-    let uinfo =
-      Unit_info.of_primitives
-        (Linker.list_all ~from:runtime_files_from_cmdline () |> StringSet.elements)
+    let primitives, aliases =
+      let all = Linker.list_all_with_aliases ~from:runtime_files_from_cmdline () in
+      StringMap.fold
+        (fun n a (primitives, aliases) ->
+          let primitives = StringSet.add n primitives in
+          let aliases = List.map (StringSet.elements a) ~f:(fun a -> a, n) @ aliases in
+          primitives, aliases)
+        all
+        (StringSet.empty, [])
     in
+    let uinfo = Unit_info.of_primitives ~aliases (StringSet.elements primitives) in
     Pretty_print.string fmt "\n";
     Pretty_print.string fmt (Unit_info.to_string uinfo);
     let code =
@@ -358,10 +365,20 @@ let run
   in
   (match bytecode with
   | `None ->
-      let prims = Linker.list_all () |> StringSet.elements in
-      assert (List.length prims > 0);
+      let primitives, aliases =
+        let all = Linker.list_all_with_aliases () in
+        StringMap.fold
+          (fun n a (primitives, aliases) ->
+            let primitives = StringSet.add n primitives in
+            let aliases = List.map (StringSet.elements a) ~f:(fun a -> a, n) @ aliases in
+            primitives, aliases)
+          all
+          (StringSet.empty, [])
+      in
+      let primitives = StringSet.elements primitives in
+      assert (List.length primitives > 0);
       let code, uinfo = Parse_bytecode.predefined_exceptions () in
-      let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in
+      let uinfo = Unit_info.union uinfo (Unit_info.of_primitives ~aliases primitives) in
       let code : Parse_bytecode.one =
         { code
         ; cmis = StringSet.empty

compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml

@@ -12,6 +12,8 @@ type bytecode_sections =
 
 external get_bytecode_sections : unit -> bytecode_sections = "jsoo_get_bytecode_sections"
 
+external get_runtime_aliases : unit -> (string * string) list = "jsoo_get_runtime_aliases"
+
 external toplevel_init_compile :
   (string -> Instruct.debug_event list array -> unit -> J.t) -> unit
   = "jsoo_toplevel_init_compile"
@@ -37,10 +39,12 @@ let () =
   (match Sys.backend_type with
   | Sys.Other "js_of_ocaml" -> Config.set_target `JavaScript
   | Sys.(Native | Bytecode | Other _) -> failwith "Expected backend `js_of_ocaml`");
+  let aliases = get_runtime_aliases () in
   let global = J.pure_js_expr "globalThis" in
   Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ());
   Config.set_effects_backend (Jsoo_runtime.Sys.Config.effects ());
   Linker.reset ();
+  List.iter aliases ~f:(fun (a, b) -> Primitive.alias a b);
   (* this needs to stay synchronized with toplevel.js *)
   let toplevel_compile (s : string) (debug : Instruct.debug_event list array) :
       unit -> J.t =

compiler/lib-dynlink/stubs.c

@@ -5,6 +5,11 @@ void jsoo_get_bytecode_sections () {
   exit(1);
 }
 
+void jsoo_get_runtime_aliases () {
+  fprintf(stderr, "Unimplemented Javascript primitive jsoo_get_runtime_aliases!\n");
+  exit(1);
+}
+
 void jsoo_toplevel_init_compile () {
   fprintf(stderr, "Unimplemented Javascript primitive jsoo_toplevel_init_compile!\n");
   exit(1);

compiler/lib-wasm/link.ml

@@ -89,6 +89,7 @@ end = struct
     { provides = t |> member "provides" |> set empty.provides
     ; requires = t |> member "requires" |> set empty.requires
     ; primitives = t |> member "primitives" |> list empty.primitives
+    ; aliases = []
     ; force_link = t |> member "force_link" |> bool empty.force_link
     ; effects_without_cps =
         t |> member "effects_without_cps" |> bool empty.effects_without_cps

compiler/lib/link_js.ml

@@ -412,6 +412,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source
           Build_info.configure bi;
           let primitives =
             List.fold_left units ~init:StringSet.empty ~f:(fun acc (u : Unit_info.t) ->
+                List.iter u.aliases ~f:(fun (a, b) -> Primitive.alias a b);
                 StringSet.union acc (StringSet.of_list u.primitives))
           in
           let code = Parse_bytecode.link_info ~symbols:!sym ~primitives ~crcs:[] in

compiler/lib/linker.ml

@@ -426,6 +426,7 @@ type provided =
   ; filename : string
   ; weakdef : bool
   ; target_env : Target_env.t
+  ; aliases : StringSet.t
   }
 
 let always_included = ref []
@@ -455,6 +456,18 @@ let list_all ?from () =
     provided
     StringSet.empty
 
+let list_all_with_aliases ?from () =
+  let include_ =
+    match from with
+    | None -> fun _ _ -> true
+    | Some l -> fun fn _nm -> List.mem fn ~set:l
+  in
+  Hashtbl.fold
+    (fun nm p map ->
+      if include_ p.filename nm then StringMap.add nm p.aliases map else map)
+    provided
+    StringMap.empty
+
 let load_fragment ~target_env ~filename (f : Fragment.t) =
   match f with
   | Always_include code ->
@@ -559,7 +572,7 @@ let load_fragment ~target_env ~filename (f : Fragment.t) =
               Hashtbl.add
                 provided
                 name
-                { id; pi; filename; weakdef; target_env = fragment_target };
+                { id; pi; filename; weakdef; target_env = fragment_target; aliases };
               Hashtbl.add provided_rev id (name, pi);
               Hashtbl.add code_pieces id (code, has_macro, requires, deprecated);
               StringSet.iter (fun alias -> Primitive.alias alias name) aliases;

compiler/lib/linker.mli

@@ -57,6 +57,8 @@ type output =
 
 val list_all : ?from:string list -> unit -> StringSet.t
 
+val list_all_with_aliases : ?from:string list -> unit -> StringSet.t StringMap.t
+
 val init : ?from:string list -> unit -> state
 
 val resolve_deps : ?check_missing:bool -> state -> StringSet.t -> state * StringSet.t

compiler/lib/parse_bytecode.ml

@@ -2645,10 +2645,12 @@ let from_exe
       let sections = { symb = symbols; crcs; prim = primitives; dlpt = [] } in
       let gdata = Var.fresh () in
       let need_gdata = ref false in
+      let aliases = Primitive.aliases () in
       let infos =
         [ "sections", Constants.parse (Obj.repr sections)
         ; "symbols", Constants.parse (Obj.repr symbols_array)
         ; "prim_count", Int (Targetint.of_int_exn (Array.length globals.primitives))
+        ; "aliases", Constants.parse (Obj.repr aliases)
         ]
       in
       let body =
@@ -3052,6 +3054,7 @@ let predefined_exceptions () =
     ; force_link = true
     ; effects_without_cps = false
     ; primitives = []
+    ; aliases = []
     }
   in
   { start = 0; blocks = Addr.Map.singleton 0 block; free_pc = 1 }, unit_info
@@ -3073,10 +3076,12 @@ let link_info ~symbols ~primitives ~crcs =
   let body =
     (* Include linking information *)
     let sections = { symb = symbols; crcs; prim = primitives; dlpt = [] } in
+    let aliases = Primitive.aliases () in
     let infos =
       [ "sections", Constants.parse (Obj.repr sections)
       ; "symbols", Constants.parse (Obj.repr symbols_array)
       ; "prim_count", Int (Targetint.of_int_exn (List.length primitives))
+      ; "aliases", Constants.parse (Obj.repr aliases)
       ]
     in
     let body =

compiler/lib/primitive.ml

@@ -19,9 +19,9 @@
  *)
 open! Stdlib
 
-let aliases = Hashtbl.create 17
+let aliases_ = Hashtbl.create 17
 
-let rec resolve nm = try resolve (Hashtbl.find aliases nm) with Not_found -> nm
+let rec resolve nm = try resolve (Hashtbl.find aliases_ nm) with Not_found -> nm
 
 (****)
 
@@ -109,7 +109,9 @@ let register p k kargs arity =
 let alias nm nm' =
   add_external nm';
   add_external nm;
-  Hashtbl.replace aliases nm nm'
+  Hashtbl.replace aliases_ nm nm'
+
+let aliases () = Hashtbl.to_seq aliases_ |> List.of_seq
 
 let named_values = ref StringSet.empty
 
@@ -121,5 +123,5 @@ let reset () =
   Hashtbl.clear kinds;
   Hashtbl.clear kind_args_tbl;
   Hashtbl.clear arities;
-  Hashtbl.clear aliases;
+  Hashtbl.clear aliases_;
   named_values := StringSet.empty

compiler/lib/primitive.mli

@@ -64,6 +64,8 @@ val has_arity : string -> int -> bool
 
 val alias : string -> string -> unit
 
+val aliases : unit -> (string * string) list
+
 val resolve : string -> string
 
 val add_external : string -> unit