Merge pull request #85 from OlivierNicole/converge-jsoo-merge-08

Integrate "Target-specific code" (ocsigen/js_of_ocaml#1655)

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

@@ -53,7 +53,7 @@ let output_gen ~standalone ~custom_header ~build_info ~source_map output_file f
               let data = Source_map.to_string sm in
               "data:application/json;base64," ^ Base64.encode_exn data
           | Some output_file ->
-              Source_map.to_file sm ~file:output_file;
+              Source_map.to_file sm output_file;
               Filename.basename output_file
         in
         Pretty_print.newline fmt;
@@ -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
@@ -194,15 +195,15 @@ let run
           in
           let code = Code.prepend one.code instr in
           Driver.f
-            ~target:(JavaScript fmt)
             ~standalone
             ?profile
             ~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, []
@@ -218,12 +219,12 @@ let run
           let code = Code.prepend one.code instr in
           let res =
             Driver.f
-              ~target:(JavaScript fmt)
               ~standalone
               ?profile
               ~link
               ~wrap_with_fun
               ?source_map
+              ~formatter
               one.debug
               code
           in
@@ -282,7 +283,7 @@ let run
    then (
      let prims = Linker.list_all () |> StringSet.elements in
      assert (List.length prims > 0);
-     let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`JavaScript in
+     let code, uinfo = Parse_bytecode.predefined_exceptions () in
      let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in
      let code : Parse_bytecode.one =
        { code
@@ -322,7 +323,6 @@ let run
          let linkall = linkall || toplevel || dynlink in
          let code =
            Parse_bytecode.from_exe
-             ~target:`JavaScript
              ~includes:include_dirs
              ~include_cmis
              ~link_info:(toplevel || dynlink)
@@ -355,7 +355,6 @@ let run
          let t1 = Timer.make () in
          let code =
            Parse_bytecode.from_cmo
-             ~target:`JavaScript
              ~includes:include_dirs
              ~include_cmis
              ~debug:need_debug
@@ -412,7 +411,6 @@ let run
              let t1 = Timer.make () in
              let code =
                Parse_bytecode.from_cmo
-                 ~target:`JavaScript
                  ~includes:include_dirs
                  ~include_cmis
                  ~debug:need_debug
@@ -444,7 +442,6 @@ let run
                let t1 = Timer.make () in
                let code =
                  Parse_bytecode.from_cmo
-                   ~target:`JavaScript
                    ~includes:include_dirs
                    ~include_cmis
                    ~debug:need_debug

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/bin-wasm_of_ocaml/compile.ml

@@ -30,7 +30,7 @@ let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_f
   if Option.is_some sourcemap_root || not sourcemap_don't_inline_content
   then (
     let open Source_map in
-    let source_map, mappings = Source_map.of_file_no_mappings sourcemap_file in
+    let source_map = Source_map.of_file sourcemap_file in
     assert (List.is_empty (Option.value source_map.sources_content ~default:[]));
     (* Add source file contents to source map *)
     let sources_content =
@@ -50,7 +50,7 @@ let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_f
           (if Option.is_some sourcemap_root then sourcemap_root else source_map.sourceroot)
       }
     in
-    Source_map.to_file ?mappings source_map ~file:sourcemap_file)
+    Source_map.to_file source_map sourcemap_file)
 
 let opt_with action x f =
   match x with
@@ -140,17 +140,23 @@ let link_runtime ~profile runtime_wasm_files output_file =
 let generate_prelude ~out_file =
   Filename.gen_file out_file
   @@ fun ch ->
-  let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`Wasm in
-  let live_vars, in_cps, p, debug =
-    Driver.f
-      ~target:Wasm
-      ~link:`Needed
-      (Parse_bytecode.Debug.create ~include_cmis:false false)
-      code
+  let code, uinfo = Parse_bytecode.predefined_exceptions () in
+  let profile =
+    match Driver.profile 1 with
+    | Some p -> p
+    | None -> assert false
   in
+  let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ~profile code in
   let context = Wa_generate.start () in
+  let debug = Parse_bytecode.Debug.create ~include_cmis:false false in
   let _ =
-    Wa_generate.f ~context ~unit_name:(Some "prelude") ~live_vars ~in_cps ~debug p
+    Wa_generate.f
+      ~context
+      ~unit_name:(Some "prelude")
+      ~live_vars:variable_uses
+      ~in_cps
+      ~debug
+      program
   in
   Wa_generate.output ch ~context ~debug;
   uinfo.provides
@@ -244,6 +250,7 @@ let run
     ; sourcemap_root
     ; sourcemap_don't_inline_content
     } =
+  Config.set_target `Wasm;
   Jsoo_cmdline.Arg.eval common;
   Wa_generate.init ();
   let output_file = fst output_file in
@@ -270,15 +277,8 @@ let run
   List.iter builtin ~f:(fun t ->
       let filename = Builtins.File.name t in
       let runtimes = Linker.Fragment.parse_builtin t in
-      Linker.load_fragments
-        ~ignore_always_annotation:true
-        ~target_env:Target_env.Isomorphic
-        ~filename
-        runtimes);
-  Linker.load_files
-    ~ignore_always_annotation:true
-    ~target_env:Target_env.Isomorphic
-    runtime_js_files;
+      Linker.load_fragments ~target_env:Target_env.Isomorphic ~filename runtimes);
+  Linker.load_files ~target_env:Target_env.Isomorphic runtime_js_files;
   Linker.check_deps ();
   if times () then Format.eprintf "  parsing js: %a@." Timer.print t1;
   if times () then Format.eprintf "Start parsing...@.";
@@ -299,12 +299,17 @@ let run
     check_debug one;
     let code = one.code in
     let standalone = Option.is_none unit_name in
-    let live_vars, in_cps, p, debug =
-      Driver.f ~target:Wasm ~standalone ?profile ~link:`No one.debug code
+    let profile =
+      match profile, Driver.profile 1 with
+      | Some p, _ -> p
+      | None, Some p -> p
+      | None, None -> assert false
     in
+    let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ~profile code in
     let context = Wa_generate.start () in
+    let debug = one.debug in
     let toplevel_name, generated_js =
-      Wa_generate.f ~context ~unit_name ~live_vars ~in_cps ~debug p
+      Wa_generate.f ~context ~unit_name ~live_vars:variable_uses ~in_cps ~debug program
     in
     if standalone then Wa_generate.add_start_function ~context toplevel_name;
     Wa_generate.output ch ~context ~debug;
@@ -352,12 +357,7 @@ let run
      let compile_cmo cmo cont =
        let t1 = Timer.make () in
        let code =
-         Parse_bytecode.from_cmo
-           ~target:`Wasm
-           ~includes:include_dirs
-           ~debug:need_debug
-           cmo
-           ic
+         Parse_bytecode.from_cmo ~includes:include_dirs ~debug:need_debug cmo ic
        in
        let unit_info = Unit_info.of_cmo cmo in
        let unit_name = Ocaml_compiler.Cmo_format.name cmo in
@@ -391,7 +391,6 @@ let run
          let t1 = Timer.make () in
          let code =
            Parse_bytecode.from_exe
-             ~target:`Wasm
              ~includes:include_dirs
              ~include_cmis:false
              ~link_info:false

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

@@ -284,10 +284,10 @@ type constant =
   | NativeString of Native_string.t
   | Float of float
   | Float_array of float array
-  | Int of int32
-  | Int32 of int32
-  | Int64 of int64
-  | NativeInt of nativeint
+  | Int of Int32.t
+  | Int32 of Int32.t
+  | Int64 of Int64.t
+  | NativeInt of Int32.t (* Native int are 32bit on all known backend *)
   | Tuple of int * constant array * array_or_not
 
 module Constant = struct
@@ -311,7 +311,7 @@ module Constant = struct
           !same
     | Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b)
     | Int64 a, Int64 b -> Some (Int64.equal a b)
-    | NativeInt a, NativeInt b -> Some (Nativeint.equal a b)
+    | NativeInt a, NativeInt b -> Some (Int32.equal a b)
     | Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b)
     | Float a, Float b -> Some (Float.ieee_equal a b)
     | String _, NativeString _ | NativeString _, String _ -> None
@@ -459,7 +459,7 @@ module Print = struct
     | Int i -> Format.fprintf f "%ld" i
     | Int32 i -> Format.fprintf f "%ldl" i
     | Int64 i -> Format.fprintf f "%LdL" i
-    | NativeInt i -> Format.fprintf f "%ndn" i
+    | NativeInt i -> Format.fprintf f "%ldn" i
     | Tuple (tag, a, _) -> (
         Format.fprintf f "<%d>" tag;
         match Array.length a with
@@ -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/code.mli

@@ -164,10 +164,10 @@ type constant =
   | NativeString of Native_string.t
   | Float of float
   | Float_array of float array
-  | Int of int32
-  | Int32 of int32  (** Only produced when compiling to WebAssembly. *)
-  | Int64 of int64
-  | NativeInt of nativeint  (** Only produced when compiling to WebAssembly. *)
+  | Int of Int32.t
+  | Int32 of Int32.t  (** Only produced when compiling to WebAssembly. *)
+  | Int64 of Int64.t
+  | NativeInt of Int32.t  (** Only produced when compiling to WebAssembly. *)
   | Tuple of int * constant array * array_or_not
 
 module Constant : sig

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