Target-specific code (#1655)

Co-authored-by: Olivier Nicole <[email protected]>
Co-authored-by: Jérôme Vouillon <[email protected]>
Co-authored-by: Hugo Heuzard <[email protected]>

Author: 3 people

compiler/bin-js_of_ocaml/build_fs.ml

@@ -75,10 +75,10 @@ function jsoo_create_file_extern(name,content){
       let pfs_fmt = Pretty_print.to_out_channel chan in
       let (_ : Source_map.t option) =
         Driver.f
-          ~target:(JavaScript pfs_fmt)
           ~standalone:true
           ~wrap_with_fun:`Iife
           ~link:`Needed
+          ~formatter:pfs_fmt
           (Parse_bytecode.Debug.create ~include_cmis:false false)
           code
       in

compiler/bin-js_of_ocaml/check_runtime.ml

@@ -43,7 +43,8 @@ let print_groups output l =
               output_string output (Printf.sprintf "%s\n" name)))
 
 let f (runtime_files, bytecode, target_env) =
-  Generate.init ();
+  Config.set_target `JavaScript;
+  Linker.reset ();
   let runtime_files, builtin =
     List.partition_map runtime_files ~f:(fun name ->
         match Builtins.find name with

compiler/bin-js_of_ocaml/compile.ml

@@ -91,6 +91,7 @@ let run
     } =
   let include_cmis = toplevel && not no_cmis in
   let custom_header = common.Jsoo_cmdline.Arg.custom_header in
+  Config.set_target `JavaScript;
   Jsoo_cmdline.Arg.eval common;
   Generate.init ();
   (match output_file with
@@ -184,7 +185,7 @@ let run
     let init_pseudo_fs = fs_external && standalone in
     let sm =
       match output_file with
-      | `Stdout, fmt ->
+      | `Stdout, formatter ->
           let instr =
             List.concat
               [ pseudo_fs_instr `create_file one.debug one.cmis
@@ -200,9 +201,10 @@ let run
             ~link
             ~wrap_with_fun
             ?source_map
+            ~formatter
             one.debug
             code
-      | `File, fmt ->
+      | `File, formatter ->
           let fs_instr1, fs_instr2 =
             match fs_output with
             | None -> pseudo_fs_instr `create_file one.debug one.cmis, []
@@ -224,6 +226,7 @@ let run
               ~link
               ~wrap_with_fun
               ?source_map
+              ~formatter
               one.debug
               code
           in

compiler/bin-js_of_ocaml/link.ml

@@ -150,6 +150,7 @@ let f
     ; mklib
     ; toplevel
     } =
+  Config.set_target `JavaScript;
   Jsoo_cmdline.Arg.eval common;
   let with_output f =
     match output_file with

compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml

@@ -16,6 +16,9 @@ let split_primitives p =
 external get_section_table : unit -> (string * Obj.t) list = "caml_get_section_table"
 
 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 global = J.pure_js_expr "globalThis" in
   Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ());
   Config.Flag.set "effects" (Jsoo_runtime.Sys.Config.effects ());

compiler/lib-runtime-files/gen/gen.ml

@@ -47,6 +47,7 @@ let rec list_product l =
 let bool = [ true; false ]
 
 let () =
+  Js_of_ocaml_compiler.Config.set_target `JavaScript;
   let () = set_binary_mode_out stdout true in
   match Array.to_list Sys.argv with
   | [] -> assert false

compiler/lib/code.ml

@@ -816,6 +816,7 @@ 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);
@@ -830,15 +831,28 @@ 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 _ -> ()
-      | Prim (_, _) -> ()
+      | Constant c -> check_constant c
+      | Prim (_, args) -> List.iter ~f:check_prim_arg args
       | Special _ -> ()
     in
     let check_instr (i, _loc) =

compiler/lib/config.ml

@@ -162,7 +162,7 @@ module Param = struct
     p
       ~name:"tc"
       ~desc:"Set tailcall optimisation"
-      (enum [ "trampoline", TcTrampoline; (* default *) "none", TcNone ])
+      (enum [ "trampoline", TcTrampoline (* default *); "none", TcNone ])
 
   let lambda_lifting_threshold =
     (* When we reach this depth, we start looking for functions to be lifted *)
@@ -178,3 +178,15 @@ module Param = struct
       ~desc:"Set baseline for lifting deeply nested functions"
       (int 1)
 end
+
+(****)
+
+let target_ : [ `JavaScript | `Wasm | `None ] ref = ref `None
+
+let target () =
+  match !target_ with
+  | `None -> failwith "target was not set"
+  | (`JavaScript | `Wasm) as t -> t
+
+let set_target (t : [ `JavaScript | `Wasm ]) =
+  target_ := (t :> [ `JavaScript | `Wasm | `None ])

compiler/lib/config.mli

@@ -78,6 +78,7 @@ module Flag : sig
   val disable : string -> unit
 end
 
+(** This module contains parameters that may be modified through command-line flags. *)
 module Param : sig
   val set : string -> string -> unit
 
@@ -102,3 +103,13 @@ module Param : sig
 
   val lambda_lifting_baseline : unit -> int
 end
+
+(****)
+
+(** {2 Parameters that are constant across a program run} *)
+
+(** These parameters should be set at most once at the beginning of the program. *)
+
+val target : unit -> [ `JavaScript | `Wasm ]
+
+val set_target : [ `JavaScript | `Wasm ] -> unit