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

Author: hhugo

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

@@ -49,9 +49,6 @@ let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option =
   let args =
     match l with
     | [ Float i; Float j ] -> Some (i, j)
-    | [ Int i; Int j ] -> Some (Targetint.to_float i, Targetint.to_float j)
-    | [ Int i; Float j ] -> Some (Targetint.to_float i, j)
-    | [ Float i; Int j ] -> Some (i, Targetint.to_float j)
     | _ -> None
   in
   match args with
@@ -66,7 +63,6 @@ let float_binop (l : constant list) (f : float -> float -> float) : constant opt
 let float_unop (l : constant list) (f : float -> float) : constant option =
   match l with
   | [ Float i ] -> Some (Float (f i))
-  | [ Int i ] -> Some (Float (f (Targetint.to_float i)))
   | _ -> None
 
 let bool' b = Int Targetint.(if b then one else zero)
@@ -76,18 +72,14 @@ let bool b = Some (bool' b)
 let float_unop_bool (l : constant list) (f : float -> bool) =
   match l with
   | [ Float i ] -> bool (f i)
-  | [ Int i ] -> bool (f (Targetint.to_float i))
   | _ -> None
 
 let float_binop_bool l f =
   match float_binop_aux l f with
   | Some b -> bool b
   | None -> None
 
-let int32 i =
-  match Config.target () with
-  | `JavaScript -> Some (Int (Targetint.of_int32_exn i))
-  | `Wasm -> Some (Int32 i)
+let int32 i = Some (Int32 i)
 
 let int32_unop (l : constant list) (f : int32 -> int32) : constant option =
   match l with
@@ -362,14 +354,14 @@ let eval_prim x =
       | _ -> None)
   | _ -> None
 
-let the_length_of ~target info x =
+let the_length_of info x =
   get_approx
     info
     (fun x ->
       match Flow.Info.def info x with
       | Some (Constant (String s)) -> Some (Targetint.of_int_exn (String.length s))
       | Some (Prim (Extern "caml_create_string", [ arg ]))
-      | Some (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int ~target info arg
+      | Some (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int info arg
       | None | Some _ -> None)
     None
     (fun u v ->
@@ -391,9 +383,6 @@ let is_int info x =
         (fun x ->
           match Flow.Info.def info x with
           | Some (Constant (Int _)) -> Y
-          | Some (Constant (NativeInt _ | Int32 _)) ->
-              (* These Wasm-specific constants are boxed *)
-              N
           | Some (Block (_, _, _, _) | Constant _) -> N
           | None | Some _ -> Unknown)
         Unknown
@@ -404,9 +393,6 @@ let is_int info x =
           | _ -> Unknown)
         x
   | Pc (Int _) -> Y
-  | Pc (NativeInt _ | Int32 _) ->
-      (* These Wasm-specific constants are boxed *)
-      N
   | Pc _ -> N
 
 let the_tag_of info x get =
@@ -509,7 +495,7 @@ let eval_instr ~target info i =
       let c =
         match s with
         | Pc (String s) -> Some (Targetint.of_int_exn (String.length s))
-        | Pv v -> the_length_of ~target info v
+        | Pv v -> the_length_of info v
         | _ -> None
       in
       match c with
@@ -591,7 +577,7 @@ let eval_instr ~target info i =
                             (* Avoid duplicating the constant here as it would cause an
                                allocation *)
                             arg
-                        | Some (Int32 _ | NativeInt _), `JavaScript -> assert false
+                        | Some ((Int32 _ | NativeInt _) as c), `JavaScript -> Pc c
                         | Some ((Float _ | NativeString _) as c), `JavaScript -> Pc c
                         | Some (String _ as c), `JavaScript
                           when Config.Flag.use_js_string () -> Pc c

compiler/lib/flow.ml

@@ -344,6 +344,7 @@ let the_def_of info x =
         (fun x ->
           match info.info_defs.(Var.idx x) with
           | Expr (Constant (Float _ | Int _ | NativeString _) as e) -> Some e
+          | Expr (Constant (Int32 _ | NativeInt _) as e) -> Some e
           | Expr (Constant (String _) as e) when Config.Flag.safe_string () -> Some e
           | Expr e -> if Var.ISet.mem info.info_possibly_mutable x then None else Some e
           | _ -> None)
@@ -370,10 +371,10 @@ let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b =
       false (* Strings are boxed in Wasm and are possibly different objects *)
   | Int32 _, Int32 _, `Wasm ->
       false (* [Int32]s are boxed in Wasm and are possibly different objects *)
-  | Int32 _, Int32 _, `JavaScript -> assert false
+  | Int32 a, Int32 b, `JavaScript -> Int32.equal a b
   | NativeInt _, NativeInt _, `Wasm ->
       false (* [NativeInt]s are boxed in Wasm and are possibly different objects *)
-  | NativeInt _, NativeInt _, `JavaScript -> assert false
+  | NativeInt a, NativeInt b, `JavaScript -> Int32.equal a b
   (* All other values may be distinct objects and thus different by [caml_js_equals]. *)
   | Int64 _, Int64 _, _ -> false
   | Tuple _, Tuple _, _ -> false
@@ -388,10 +389,11 @@ let the_const_of ~target info x =
       get_approx
         info
         (fun x ->
-          match info.info_defs.(Var.idx x) with
-          | Expr (Constant ((Float _ | Int _ | NativeString _) as c)) -> Some c
-          | Expr (Constant (String _ as c)) when Config.Flag.safe_string () -> Some c
-          | Expr (Constant c) ->
+          match info.info_defs.(Var.idx x), target with
+          | Expr (Constant ((Float _ | Int _ | NativeString _) as c)), _ -> Some c
+          | Expr (Constant ((Int32 _ | NativeInt _) as c)), `JavaScript -> Some c
+          | Expr (Constant (String _ as c)), _ when Config.Flag.safe_string () -> Some c
+          | Expr (Constant c), _ ->
               if Var.ISet.mem info.info_possibly_mutable x then None else Some c
           | _ -> None)
         None
@@ -402,10 +404,23 @@ let the_const_of ~target info x =
         x
   | Pc c -> Some c
 
-let the_int ~target info x =
-  match the_const_of ~target info x with
-  | Some (Int i) -> Some i
-  | _ -> None
+let the_int info x =
+  match x with
+  | Pv x ->
+      get_approx
+        info
+        (fun x ->
+          match info.info_defs.(Var.idx x) with
+          | Expr (Constant (Int c)) -> Some c
+          | _ -> None)
+        None
+        (fun u v ->
+          match u, v with
+          | Some i, Some j when Targetint.equal i j -> u
+          | _ -> None)
+        x
+  | Pc (Int c) -> Some c
+  | Pc _ -> None
 
 let the_string_of ~target info x =
   match the_const_of info ~target x with

compiler/lib/flow.mli

@@ -63,7 +63,6 @@ val the_native_string_of :
 
 val the_block_contents_of : Info.t -> Code.prim_arg -> Code.Var.t array option
 
-val the_int :
-  target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Targetint.t option
+val the_int : Info.t -> Code.prim_arg -> Targetint.t option
 
 val f : ?skip_param:bool -> Code.program -> Code.program * Info.t

compiler/lib/generate.ml

@@ -515,8 +515,7 @@ let rec constant_rec ~ctx x level instrs =
           in
           Mlvalue.Block.make ~tag ~args:l, instrs)
   | Int i -> targetint i, instrs
-  | Int32 _ | NativeInt _ ->
-      assert false (* Should not be produced when compiling to Javascript *)
+  | Int32 i | NativeInt i -> targetint (Targetint.of_int32_exn i), instrs
 
 let constant ~ctx x level =
   let expr, instr = constant_rec ~ctx x level [] in
@@ -1606,7 +1605,8 @@ and translate_instr ctx expr_queue loc instr =
       | 1, _
         when Config.Flag.compact () && ((not (Config.Flag.pretty ())) || not (keep_name x))
         -> enqueue expr_queue x loc e'
-      | 1, Constant (Int _ | Float _) -> enqueue expr_queue x loc e'
+      | 1, Constant (Int _ | Int32 _ | NativeInt _ | Float _) ->
+          enqueue expr_queue x loc e'
       | _ ->
           flush_queue
             expr_queue

compiler/lib/ocaml_compiler.ml

@@ -26,15 +26,9 @@ let rec constant_of_const c : Code.constant =
   | Const_base (Const_char c) -> Int (Targetint.of_int_exn (Char.code c))
   | Const_base (Const_string (s, _, _)) -> String s
   | Const_base (Const_float s) -> Float (float_of_string s)
-  | Const_base (Const_int32 i) -> (
-      match Config.target () with
-      | `JavaScript -> Int (Targetint.of_int32_warning_on_overflow i)
-      | `Wasm -> Int32 i)
+  | Const_base (Const_int32 i) -> Int32 i
   | Const_base (Const_int64 i) -> Int64 i
-  | Const_base (Const_nativeint i) -> (
-      match Config.target () with
-      | `JavaScript -> Int (Targetint.of_nativeint_warning_on_overflow i)
-      | `Wasm -> NativeInt (Int32.of_nativeint_warning_on_overflow i))
+  | Const_base (Const_nativeint i) -> NativeInt (Int32.of_nativeint_warning_on_overflow i)
   | Const_immstring s -> String s
   | Const_float_array sl ->
       let l = List.map ~f:(fun f -> float_of_string f) sl in

compiler/lib/parse_bytecode.ml

@@ -403,7 +403,7 @@ end
 module Constants : sig
   val parse : Obj.t -> Code.constant
 
-  val inlined : Code.constant -> bool
+  val inlined : target:[ `JavaScript | `Wasm ] -> Code.constant -> bool
 end = struct
   (* In order to check that two custom objects share the same kind, we
      compare their identifier.  The identifier is currently extracted
@@ -448,16 +448,12 @@ end = struct
       else if tag = Obj.custom_tag
       then
         match ident_of_custom x with
-        | Some name when same_ident name ident_32 -> (
+        | Some name when same_ident name ident_32 ->
             let i : int32 = Obj.magic x in
-            match Config.target () with
-            | `JavaScript -> Int (Targetint.of_int32_warning_on_overflow i)
-            | `Wasm -> Int32 i)
-        | Some name when same_ident name ident_native -> (
+            Int32 i
+        | Some name when same_ident name ident_native ->
             let i : nativeint = Obj.magic x in
-            match Config.target () with
-            | `JavaScript -> Int (Targetint.of_nativeint_warning_on_overflow i)
-            | `Wasm -> NativeInt (Int32.of_nativeint_warning_on_overflow i))
+            NativeInt (Int32.of_nativeint_warning_on_overflow i)
         | Some name when same_ident name ident_64 -> Int64 (Obj.magic x : int64)
         | Some name ->
             failwith
@@ -473,14 +469,18 @@ end = struct
       let i : int = Obj.magic x in
       Int (Targetint.of_int_warning_on_overflow i)
 
-  let inlined = function
+  let inlined ~target c =
+    match c with
     | String _ | NativeString _ -> false
     | Float _ -> true
     | Float_array _ -> false
     | Int64 _ -> false
     | Tuple _ -> false
     | Int _ -> true
-    | Int32 _ | NativeInt _ -> false
+    | Int32 _ | NativeInt _ -> (
+        match target with
+        | `JavaScript -> true
+        | `Wasm -> false)
 end
 
 let const32 i = Constant (Int (Targetint.of_int32_exn i))
@@ -740,14 +740,15 @@ let get_global state instrs i =
       if debug_parser () then Format.printf "(global access %a)@." Var.print x;
       x, State.set_accu state x, instrs
   | None -> (
-      if i < Array.length g.constants && Constants.inlined g.constants.(i)
+      let target = Config.target () in
+      if i < Array.length g.constants && Constants.inlined ~target g.constants.(i)
       then
         (* Inlined constant *)
         let x, state = State.fresh_var state in
         let cst = g.constants.(i) in
         x, state, Let (x, Constant cst) :: instrs
       else
-        match i < Array.length g.constants, Config.target () with
+        match i < Array.length g.constants, target with
         | true, _ | false, `JavaScript ->
             (* Non-inlined constant, and reference to another compilation
                units in case of separate compilation (JavaScript).

compiler/lib/specialize_js.ml

@@ -30,12 +30,12 @@ let specialize_instr ~target info i =
          Wasm to have a special case for this. *)
       match the_string_of ~target info y with
       | Some "%d" -> (
-          match the_int ~target info z with
+          match the_int info z with
           | Some i -> Let (x, Constant (String (Targetint.to_string i)))
           | None -> Let (x, Prim (Extern "%caml_format_int_special", [ z ])))
       | _ -> i)
   | Let (x, Prim (Extern "%caml_format_int_special", [ z ])), `JavaScript -> (
-      match the_int ~target info z with
+      match the_int info z with
       | Some i -> Let (x, Constant (String (Targetint.to_string i)))
       | None -> i)
   (* inline the String constant argument so that generate.ml can attempt to parse it *)
@@ -139,19 +139,19 @@ let specialize_instr ~target info i =
       (* Using * to multiply integers in JavaScript yields a float; and if the
            float is large enough, some bits can be lost. So, in the general case,
            we have to use Math.imul. There is no such issue in Wasm. *)
-      match the_int ~target info y, the_int ~target info z with
+      match the_int info y, the_int info z with
       | Some j, _ when Targetint.(abs j < limit) ->
           Let (x, Prim (Extern "%direct_int_mul", [ y; z ]))
       | _, Some j when Targetint.(abs j < limit) ->
           Let (x, Prim (Extern "%direct_int_mul", [ y; z ]))
       | _ -> i)
   | Let (x, Prim (Extern "%int_div", [ y; z ])), _ -> (
-      match the_int ~target info z with
+      match the_int info z with
       | Some j when not (Targetint.is_zero j) ->
           Let (x, Prim (Extern "%direct_int_div", [ y; z ]))
       | _ -> i)
   | Let (x, Prim (Extern "%int_mod", [ y; z ])), _ -> (
-      match the_int ~target info z with
+      match the_int info z with
       | Some j when not (Targetint.is_zero j) ->
           Let (x, Prim (Extern "%direct_int_mod", [ y; z ]))
       | _ -> i)
@@ -261,7 +261,7 @@ let specialize_instrs ~target info l =
                      | "caml_array_get_addr" ) as prim)
                 , [ y; z ] ) ) ->
             let idx =
-              match the_int ~target info z with
+              match the_int info z with
               | Some idx -> `Cst idx
               | None -> `Var z
             in
@@ -302,7 +302,7 @@ let specialize_instrs ~target info l =
                      | "caml_array_set_addr" ) as prim)
                 , [ y; z; t ] ) ) ->
             let idx =
-              match the_int ~target info z with
+              match the_int info z with
               | Some idx -> `Cst idx
               | None -> `Var z
             in