Make compilation target a global parameter

Author: OlivierNicole

compiler/bin-js_of_ocaml/js_of_ocaml.ml

@@ -22,6 +22,7 @@ open! Js_of_ocaml_compiler.Stdlib
 open Js_of_ocaml_compiler
 
 let () =
+  Config.set_target `JavaScript;
   Sys.catch_break true;
   let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in
   let argv =

compiler/lib/config.ml

@@ -164,7 +164,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 *)
@@ -180,3 +180,11 @@ module Param = struct
       ~desc:"Set baseline for lifting deeply nested functions"
       (int 1)
 end
+
+(****)
+
+let target_ : [ `JavaScript | `Wasm ] ref = ref `JavaScript
+
+let target () = !target_
+
+let set_target t = target_ := t

compiler/lib/config.mli

@@ -80,6 +80,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
 
@@ -104,3 +105,12 @@ 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

compiler/lib/driver.ml

@@ -44,35 +44,35 @@ let deadcode p =
   let r, _ = deadcode' p in
   r
 
-let inline ~target p =
+let inline p =
   if Config.Flag.inline () && Config.Flag.deadcode ()
   then (
     let p, live_vars = deadcode' p in
     if debug () then Format.eprintf "Inlining...@.";
-    Inline.f ~target p live_vars)
+    Inline.f p live_vars)
   else p
 
 let specialize_1 (p, info) =
   if debug () then Format.eprintf "Specialize...@.";
   Specialize.f ~function_arity:(fun f -> Specialize.function_arity info f) p
 
-let specialize_js ~target (p, info) =
+let specialize_js (p, info) =
   if debug () then Format.eprintf "Specialize js...@.";
-  Specialize_js.f ~target info p
+  Specialize_js.f info p
 
 let specialize_js_once p =
   if debug () then Format.eprintf "Specialize js once...@.";
   Specialize_js.f_once p
 
-let specialize' ~target (p, info) =
+let specialize' (p, info) =
   let p = specialize_1 (p, info) in
-  let p = specialize_js ~target (p, info) in
+  let p = specialize_js (p, info) in
   p, info
 
-let specialize ~target p = fst (specialize' ~target p)
+let specialize p = fst (specialize' p)
 
-let eval ~target (p, info) =
-  if Config.Flag.staticeval () then Eval.f ~target info p else p
+let eval (p, info) =
+  if Config.Flag.staticeval () then Eval.f info p else p
 
 let flow p =
   if debug () then Format.eprintf "Data flow...@.";
@@ -144,53 +144,53 @@ let identity x = x
 
 (* o1 *)
 
-let o1 ~target : 'a -> 'a =
+let o1 : 'a -> 'a =
   print
   +> tailcall
   +> flow_simple (* flow simple to keep information for future tailcall opt *)
-  +> specialize' ~target
-  +> eval ~target
-  +> inline ~target (* inlining may reveal new tailcall opt *)
+  +> specialize'
+  +> eval
+  +> inline (* inlining may reveal new tailcall opt *)
   +> deadcode
   +> tailcall
   +> phi
   +> flow
-  +> specialize' ~target
-  +> eval ~target
-  +> inline ~target
+  +> specialize'
+  +> eval
+  +> inline
   +> deadcode
   +> print
   +> flow
-  +> specialize' ~target
-  +> eval ~target
-  +> inline ~target
+  +> specialize'
+  +> eval
+  +> inline
   +> deadcode
   +> phi
   +> flow
-  +> specialize ~target
+  +> specialize
   +> identity
 
 (* o2 *)
 
-let o2 ~target : 'a -> 'a = loop 10 "o1" (o1 ~target) 1 +> print
+let o2 : 'a -> 'a = loop 10 "o1" o1 1 +> print
 
 (* o3 *)
 
-let round1 ~target : 'a -> 'a =
+let round1 : 'a -> 'a =
   print
   +> tailcall
-  +> inline ~target (* inlining may reveal new tailcall opt *)
+  +> inline (* inlining may reveal new tailcall opt *)
   +> deadcode (* deadcode required before flow simple -> provided by constant *)
   +> flow_simple (* flow simple to keep information for future tailcall opt *)
-  +> specialize' ~target
-  +> eval ~target
+  +> specialize'
+  +> eval
   +> identity
 
-let round2 ~target = flow +> specialize' ~target +> eval ~target +> deadcode +> o1 ~target
+let round2 = flow +> specialize' +> eval +> deadcode +> o1
 
-let o3 ~target =
-  loop 10 "tailcall+inline" (round1 ~target) 1
-  +> loop 10 "flow" (round2 ~target) 1
+let o3 =
+  loop 10 "tailcall+inline" round1 1
+  +> loop 10 "flow" round2 1
   +> print
 
 let generate
@@ -668,11 +668,6 @@ type 'a target =
       : (Deadcode.variable_uses * Effects.in_cps * Code.program * Parse_bytecode.Debug.t)
         target
 
-let target_flag (type a) (t : a target) =
-  match t with
-  | JavaScript _ -> `JavaScript
-  | Wasm -> `Wasm
-
 let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p =
   let export_runtime =
     match link with
@@ -705,7 +700,6 @@ let full
        | O1 -> o1
        | O2 -> o2
        | O3 -> o3)
-         ~target:(target_flag target)
     +> exact_calls ~deadcode_sentinal profile
     +> effects ~deadcode_sentinal
     +> map_fst

compiler/lib/eval.ml

@@ -108,7 +108,7 @@ module type Int = sig
   val shift_op : (constant list) -> (t -> int -> t) -> constant option
 end
 
-let eval_prim ~target x =
+let eval_prim x =
   match x with
   | Not, [ Int i ] -> bool Int32.(i = 0l)
   | Lt, [ Int i; Int j ] -> bool Int32.(i < j)
@@ -119,7 +119,7 @@ let eval_prim ~target x =
   | Extern name, l -> (
       let name = Primitive.resolve name in
       let (module Int : Int) =
-        match target with
+        match Config.target () with
         | `JavaScript -> (module Int32)
         | `Wasm -> (module Int31)
       in
@@ -185,7 +185,7 @@ let eval_prim ~target x =
       | "caml_sys_const_int_size", [ _ ] ->
           Some
             (Int
-               (match target with
+               (match Config.target () with
                | `JavaScript -> 32l
                | `Wasm -> 31l))
       | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l)
@@ -214,7 +214,7 @@ type is_int =
   | N
   | Unknown
 
-let is_int ~target info x =
+let is_int info x =
   match x with
   | Pv x ->
       get_approx
@@ -223,7 +223,7 @@ let is_int ~target info x =
           match Flow.Info.def info x with
           | Some (Constant (Int _)) -> Y
           | Some (Constant (NativeInt _ | Int32 _)) ->
-              assert (Poly.equal target `Wasm);
+              assert (Poly.equal (Config.target ()) `Wasm);
               N
           | Some (Block (_, _, _, _) | Constant _) -> N
           | None | Some _ -> Unknown)
@@ -236,7 +236,7 @@ let is_int ~target info x =
         x
   | Pc (Int _) -> Y
   | Pc (NativeInt _ | Int32 _) ->
-      assert (Poly.equal target `Wasm);
+      assert (Poly.equal (Config.target ()) `Wasm);
       N
   | Pc _ -> N
 
@@ -308,7 +308,7 @@ let constant_js_equal a b =
   | Tuple _, _
   | _, Tuple _ -> None
 
-let eval_instr info ~target ((x, loc) as i) =
+let eval_instr info ((x, loc) as i) =
   match x with
   | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> (
       match the_const_of info y, the_const_of info z with
@@ -365,7 +365,7 @@ let eval_instr info ~target ((x, loc) as i) =
            below fail. *)
       [ i ]
   | Let (x, Prim (IsInt, [ y ])) -> (
-      match is_int ~target info y with
+      match is_int info y with
       | Unknown -> [ i ]
       | (Y | N) as b ->
           let c = Constant (bool' Poly.(b = Y)) in
@@ -381,7 +381,7 @@ let eval_instr info ~target ((x, loc) as i) =
   | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) ->
       let jsoo = Code.Var.fresh () in
       let backend_name =
-        match target with
+        match Config.target () with
         | `JavaScript -> "js_of_ocaml"
         | `Wasm -> "wasm_of_ocaml"
       in
@@ -398,7 +398,6 @@ let eval_instr info ~target ((x, loc) as i) =
                | _ -> false)
         then
           eval_prim
-            ~target
             ( prim
             , List.map prim_args' ~f:(function
                   | Some c -> c
@@ -416,7 +415,7 @@ let eval_instr info ~target ((x, loc) as i) =
                 , Prim
                     ( prim
                     , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) ->
-                          match c, target with
+                          match c, Config.target () with
                           | ( Some ((Int _ | Int32 _ | NativeInt _ | NativeString _) as c)
                             , _ ) -> Pc c
                           | Some (Float _ as c), `JavaScript -> Pc c
@@ -547,15 +546,15 @@ let drop_exception_handler blocks =
     blocks
     blocks
 
-let eval ~target info blocks =
+let eval info blocks =
   Addr.Map.map
     (fun block ->
-      let body = List.concat_map block.body ~f:(eval_instr ~target info) in
+      let body = List.concat_map block.body ~f:(eval_instr info) in
       let branch = eval_branch info block.branch in
       { block with Code.body; Code.branch })
     blocks
 
-let f ~target info p =
-  let blocks = eval ~target info p.blocks in
+let f info p =
+  let blocks = eval info p.blocks in
   let blocks = drop_exception_handler blocks in
   { p with blocks }

compiler/lib/eval.mli

@@ -21,4 +21,4 @@ val clear_static_env : unit -> unit
 
 val set_static_env : string -> string -> unit
 
-val f : target:[ `JavaScript | `Wasm ] -> Flow.Info.t -> Code.program -> Code.program
+val f : Flow.Info.t -> Code.program -> Code.program

compiler/lib/inline.ml

@@ -322,9 +322,9 @@ let inline ~first_class_primitives live_vars closures name pc (outer, p) =
 
 let times = Debug.find "times"
 
-let f ~target p live_vars =
+let f p live_vars =
   let first_class_primitives =
-    match target with
+    match Config.target () with
     | `JavaScript -> not (Config.Flag.effects ())
     | `Wasm -> false
   in

compiler/lib/inline.mli

@@ -18,5 +18,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val f :
-  target:[ `JavaScript | `Wasm ] -> Code.program -> Deadcode.variable_uses -> Code.program
+val f : Code.program -> Deadcode.variable_uses -> Code.program

compiler/lib/specialize_js.ml

@@ -22,8 +22,8 @@ open! Stdlib
 open Code
 open Flow
 
-let specialize_instr ~target info i =
-  match i, target with
+let specialize_instr info i =
+  match i, Config.target () with
   | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> (
       match the_string_of info y with
       | Some "%d" -> (
@@ -156,7 +156,7 @@ let equal3 a b c = Code.Var.equal a b && Code.Var.equal b c
 
 let equal4 a b c d = Code.Var.equal a b && Code.Var.equal b c && Code.Var.equal c d
 
-let specialize_instrs ~target info l =
+let specialize_instrs info l =
   let rec aux info checks l acc =
     match l with
     | [] -> List.rev acc
@@ -285,22 +285,22 @@ let specialize_instrs ~target info l =
               in
               aux info ((y, idx) :: checks) r acc
         | _ ->
-            let i = specialize_instr ~target info i in
+            let i = specialize_instr info i in
             aux info checks r ((i, loc) :: acc))
   in
   aux info [] l []
 
-let specialize_all_instrs ~target info p =
+let specialize_all_instrs info p =
   let blocks =
     Addr.Map.map
-      (fun block -> { block with Code.body = specialize_instrs ~target info block.body })
+      (fun block -> { block with Code.body = specialize_instrs info block.body })
       p.blocks
   in
   { p with blocks }
 
 (****)
 
-let f ~target info p = specialize_all_instrs ~target info p
+let f info p = specialize_all_instrs info p
 
 let f_once p =
   let rec loop acc l =

compiler/lib/specialize_js.mli

@@ -18,6 +18,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val f : target:[ `JavaScript | `Wasm ] -> Flow.Info.t -> Code.program -> Code.program
+val f : Flow.Info.t -> Code.program -> Code.program
 
 val f_once : Code.program -> Code.program