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

compiler/lib/unit_info.ml

@@ -23,21 +23,24 @@ type t =
   { provides : StringSet.t
   ; requires : StringSet.t
   ; primitives : string list
+  ; aliases : (string * string) list
   ; force_link : bool
   ; effects_without_cps : bool
   }
 
 let empty =
   { provides = StringSet.empty
   ; requires = StringSet.empty
+  ; aliases = []
   ; primitives = []
   ; force_link = false
   ; effects_without_cps = false
   }
 
-let of_primitives l =
+let of_primitives ~aliases l =
   { provides = StringSet.empty
   ; requires = StringSet.empty
+  ; aliases
   ; primitives = l
   ; force_link = true
   ; effects_without_cps = false
@@ -58,16 +61,18 @@ let of_cmo (cmo : Cmo_format.compilation_unit) =
          | _ -> false)
   in
   let force_link = Cmo_format.force_link cmo in
-  { provides; requires; primitives = []; force_link; effects_without_cps }
+  { provides; requires; aliases = []; primitives = []; force_link; effects_without_cps }
 
 let union t1 t2 =
   let provides = StringSet.union t1.provides t2.provides in
   let requires = StringSet.union t1.requires t2.requires in
   let requires = StringSet.diff requires provides in
   let primitives = t1.primitives @ t2.primitives in
+  let aliases = t1.aliases @ t2.aliases in
   { provides
   ; requires
   ; primitives
+  ; aliases
   ; force_link = t1.force_link || t2.force_link
   ; effects_without_cps = t1.effects_without_cps || t2.effects_without_cps
   }
@@ -82,6 +87,15 @@ let to_string t =
   ; (if List.equal ~eq:String.equal empty.primitives t.primitives
      then []
      else [ prefix; "Primitives:"; String.concat ~sep:", " t.primitives ])
+  ; (if List.is_empty t.aliases
+     then []
+     else
+       [ prefix
+       ; "Aliases:"
+       ; String.concat
+           ~sep:", "
+           (List.map t.aliases ~f:(fun (a, b) -> String.concat ~sep:"=" [ a; b ]))
+       ])
   ; (if Bool.equal empty.force_link t.force_link
      then []
      else [ prefix; "Force_link:"; string_of_bool t.force_link ])
@@ -123,6 +137,15 @@ let parse acc s =
             }
       | Some ("Primitives", primitives) ->
           Some { acc with primitives = acc.primitives @ parse_stringlist primitives }
+      | Some ("Aliases", aliases) ->
+          let x =
+            parse_stringlist aliases
+            |> List.map ~f:(fun s ->
+                   match String.lsplit2 s ~on:'=' with
+                   | None -> assert false
+                   | Some (a, b) -> a, b)
+          in
+          Some { acc with aliases = acc.aliases @ x }
       | Some ("Force_link", flink) ->
           Some
             { acc with force_link = bool_of_string (String.trim flink) || acc.force_link }

compiler/lib/unit_info.mli

@@ -23,13 +23,14 @@ type t =
   { provides : StringSet.t
   ; requires : StringSet.t
   ; primitives : string list
+  ; aliases : (string * string) list
   ; force_link : bool
   ; effects_without_cps : bool
   }
 
 val of_cmo : Cmo_format.compilation_unit -> t
 
-val of_primitives : string list -> t
+val of_primitives : aliases:(string * string) list -> string list -> t
 
 val union : t -> t -> t
 

compiler/tests-check-prim/main.4.14.output

@@ -134,6 +134,7 @@ caml_set_static_env
 
 From +toplevel.js:
 caml_dynlink_get_bytecode_sections
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/main.5.2.output

@@ -130,6 +130,7 @@ caml_sys_const_naked_pointers_checked
 
 From +toplevel.js:
 caml_get_section_table
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/main.5.3.output

@@ -128,6 +128,7 @@ caml_set_static_env
 caml_sys_const_naked_pointers_checked
 
 From +toplevel.js:
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/unix-Unix.4.14.output

@@ -210,6 +210,7 @@ caml_set_static_env
 
 From +toplevel.js:
 caml_dynlink_get_bytecode_sections
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/unix-Unix.5.2.output

@@ -206,6 +206,7 @@ caml_sys_const_naked_pointers_checked
 
 From +toplevel.js:
 caml_get_section_table
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/unix-Unix.5.3.output

@@ -204,6 +204,7 @@ caml_set_static_env
 caml_sys_const_naked_pointers_checked
 
 From +toplevel.js:
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/unix-Win32.4.14.output

@@ -182,6 +182,7 @@ caml_set_static_env
 
 From +toplevel.js:
 caml_dynlink_get_bytecode_sections
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/unix-Win32.5.2.output

@@ -179,6 +179,7 @@ caml_sys_const_naked_pointers_checked
 
 From +toplevel.js:
 caml_get_section_table
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-check-prim/unix-Win32.5.3.output

@@ -177,6 +177,7 @@ caml_set_static_env
 caml_sys_const_naked_pointers_checked
 
 From +toplevel.js:
+jsoo_get_runtime_aliases
 jsoo_toplevel_init_compile
 jsoo_toplevel_init_reloc
 

compiler/tests-ocaml/dune

@@ -23,7 +23,7 @@
 (executable
  (name expect)
  (modules expect)
- (libraries toplevel_expect_test js_of_ocaml-toplevel)
+ (libraries toplevel_expect_test js_of_ocaml js_of_ocaml-toplevel)
  (flags
   (:standard -linkall))
  (js_of_ocaml

compiler/tests-ocaml/expect.ml

@@ -1,4 +1,10 @@
 
 let () = Js_of_ocaml_toplevel.JsooTop.initialize ()
 
+let () = Printexc.register_printer (fun x ->
+             match Js_of_ocaml.Js_error.of_exn x with
+             | None -> None
+             | Some e -> Some (Js_of_ocaml.Js_error.message e))
+
 let () = Toplevel_expect_test.run (fun _ -> Ast_mapper.default_mapper)
+