Compiler: keep Int32 and Nativeint in the IR for the js backend

CHANGES.md

@@ -5,6 +5,7 @@
 * Compiler: use a Wasm text files preprocessor (#1822)
 * Compiler: support for OCaml 4.14.3+trunk (#1844)
 * Compiler: optimize compilation of switches
+* Compiler: evaluate statically more primitives (#1915)
 * Runtime: use es6 class (#1840)
 * Runtime: support more Unix functions (#1829)
 * Runtime: remove polyfill for Map to simplify MlObjectTable implementation (#1846)

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/generate.ml

@@ -663,7 +663,6 @@ module Generate (Target : Target_sig.S) = struct
                 in
                 Memory.allocate ~tag:0 ~deadcode_sentinal:ctx.deadcode_sentinal l
             | Extern name, l -> (
-                let name = Primitive.resolve name in
                 try
                   let typ = Hashtbl.find specialized_primitives name in
                   let* f = register_import ~name (Fun (specialized_func_type typ)) in
@@ -1196,13 +1195,8 @@ module Generate (Target : Target_sig.S) = struct
 end
 
 let init () =
-  let l =
-    [ "caml_callback", "caml_trampoline"
-    ; "caml_make_array", "caml_array_of_uniform_array"
-    ]
-  in
-  Primitive.register "caml_array_of_uniform_array" `Mutable None None;
-  List.iter ~f:(fun (nm, nm') -> Primitive.alias nm nm') l
+  Primitive.register "caml_make_array" `Mutable None None;
+  Primitive.register "caml_array_of_uniform_array" `Mutable None None
 
 (* Make sure we can use [br_table] for switches *)
 let fix_switch_branches p =

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/annot_lexer.mll

@@ -39,6 +39,9 @@ rule main = parse
   | ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''-''0'-'9']* {
       let x = Lexing.lexeme lexbuf in
       TIdent x}
+  | '%' ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''-''0'-'9']* {
+      let x = Lexing.lexeme lexbuf in
+      TIdent_percent x}
   | ['0'-'9']+ ('.' (['0'-'9']+)) * {
       let x = Lexing.lexeme lexbuf in
       TVNum x}

compiler/lib/annot_parser.mly

@@ -19,7 +19,7 @@
 
 %token TProvides TRequires TVersion TWeakdef TIf TAlways TAlias
 %token TA_Pure TA_Const TA_Mutable TA_Mutator TA_Shallow TA_Object_literal
-%token<string> TIdent TVNum
+%token<string> TIdent TIdent_percent TVNum
 %token TComma TColon EOF EOL LE LT GE GT EQ LPARENT RPARENT
 %token<string> TOTHER
 %token<string> TDeprecated
@@ -43,6 +43,7 @@ annot:
   | TAlways endline { `Always   }
   | TDeprecated endline { `Deprecated $1 }
   | TAlias TColon name=TIdent endline { `Alias (name) }
+  | TAlias TColon name=TIdent_percent endline { `Alias (name) }
   | TIf TColon name=TIdent endline { `If (name) }
   | TIf TColon TBang name=TIdent endline { `Ifnot (name) }
 prim_annot:

compiler/lib/code.ml

@@ -801,7 +801,6 @@ let with_invariant = Debug.find "invariant"
 let check_defs = false
 
 let invariant { blocks; start; _ } =
-  let target = Config.target () in
   if with_invariant ()
   then (
     assert (Addr.Map.mem start blocks);
@@ -816,28 +815,15 @@ let invariant { blocks; start; _ } =
         assert (not (Var.ISet.mem defs x));
         Var.ISet.add defs x)
     in
-    let check_constant = function
-      | NativeInt _ | Int32 _ ->
-          assert (
-            match target with
-            | `Wasm -> true
-            | _ -> false)
-      | String _ | NativeString _ | Float _ | Float_array _ | Int _ | Int64 _
-      | Tuple (_, _, _) -> ()
-    in
-    let check_prim_arg = function
-      | Pc c -> check_constant c
-      | Pv _ -> ()
-    in
     let check_expr = function
       | Apply _ -> ()
       | Block (_, _, _, _) -> ()
       | Field (_, _, _) -> ()
       | Closure (l, cont) ->
           List.iter l ~f:define;
           check_cont cont
-      | Constant c -> check_constant c
-      | Prim (_, args) -> List.iter ~f:check_prim_arg args
+      | Constant _ -> ()
+      | Prim (_, _) -> ()
       | Special _ -> ()
     in
     let check_instr i =

compiler/lib/effects.ml

@@ -847,7 +847,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p =
               (* Toplevel code: if we double-translate, no need to handle it
                  specially: CPS calls in it are like all other CPS calls from
                  direct code. Otherwise, it needs to wrapped within a
-                 [caml_callback], but only if it performs CPS calls. *)
+                 [caml_cps_trampoline], but only if it performs CPS calls. *)
               not (double_translate () || Addr.Set.is_empty blocks_to_transform)
         in
         if debug ()
@@ -957,7 +957,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p =
       match Hashtbl.find_opt closure_info p.start with
       | None -> p
       | Some (cps_params, cps_cont) ->
-          (* Call [caml_callback] to set up the execution context. *)
+          (* Call [caml_cps_trampoline] to set up the execution context. *)
           let new_start = p.free_pc in
           let blocks =
             let main = Var.fresh () in
@@ -969,7 +969,7 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p =
               ; body =
                   [ Let (main, Closure (cps_params, cps_cont))
                   ; Let (args, Prim (Extern "%js_array", []))
-                  ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ]))
+                  ; Let (res, Prim (Extern "caml_cps_trampoline", [ Pv main; Pv args ]))
                   ]
               ; branch = Return res
               }
@@ -994,7 +994,7 @@ let wrap_call ~cps_needed p x f args accu =
   ( p
   , Var.Set.remove x cps_needed
   , [ Let (arg_array, Prim (Extern "%js_array", List.map ~f:(fun y -> Pv y) args))
-    ; Let (x, Prim (Extern "caml_callback", [ Pv f; Pv arg_array ]))
+    ; Let (x, Prim (Extern "caml_cps_trampoline", [ Pv f; Pv arg_array ]))
     ]
     :: accu )
 
@@ -1014,7 +1014,7 @@ let wrap_primitive ~cps_needed (p : program) x e accu =
   , let args = Var.fresh () in
     [ Let (f, Closure ([], (closure_pc, [])))
     ; Let (args, Prim (Extern "%js_array", []))
-    ; Let (x, Prim (Extern "caml_callback", [ Pv f; Pv args ]))
+    ; Let (x, Prim (Extern "caml_cps_trampoline", [ Pv f; Pv args ]))
     ]
     :: accu )
 
@@ -1026,9 +1026,9 @@ let rewrite_toplevel_instr (p, cps_needed, accu) instr =
       wrap_primitive ~cps_needed p x e accu
   | _ -> p, cps_needed, [ instr ] :: accu
 
-(* Wrap function calls inside [caml_callback] at toplevel to avoid
+(* Wrap function calls inside [caml_cps_trampoline] at toplevel to avoid
    unncessary function nestings. This is not done inside loops since
-   using repeatedly [caml_callback] can be costly. *)
+   using repeatedly [caml_cps_trampoline] can be costly. *)
 let rewrite_toplevel ~cps_needed p =
   let { start; blocks; _ } = p in
   let cfg = build_graph blocks start in