Don't noop conversion between ints/float with the same runtime repr.

Previously, primitives taking float arguments
could receive Int/Int32/NativeInt/Float arg

Author: hhugo

compiler/lib/code.ml

@@ -843,7 +843,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);
@@ -859,11 +858,7 @@ let invariant { blocks; start; _ } =
         Var.ISet.add defs x)
     in
     let check_constant = function
-      | NativeInt _ | Int32 _ ->
-          assert (
-            match target with
-            | `Wasm -> true
-            | _ -> false)
+      | NativeInt _ | Int32 _ -> ()
       | String _ | NativeString _ | Float _ | Float_array _ | Int _ | Int64 _
       | Tuple (_, _, _) -> ()
     in

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)
@@ -155,14 +151,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 ->
@@ -184,9 +180,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
@@ -197,9 +190,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 =
@@ -302,7 +292,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
@@ -384,7 +374,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

@@ -370,10 +370,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 +388,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 +403,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

@@ -511,8 +511,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
@@ -1457,15 +1456,21 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t
             return (add ca cb)
         | Extern name, l -> (
             let name = Primitive.resolve name in
-            match internal_prim name with
-            | Some f -> f l ctx loc
-            | None ->
-                if String.is_prefix name ~prefix:"%"
-                then failwith (Printf.sprintf "Unresolved internal primitive: %s" name);
-                let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
-                let* () = info ~need_loc:true (kind (Primitive.kind name)) in
-                let* args = list_map (fun x -> access' ~ctx x) l in
-                return (J.call prim args loc))
+            match name, l with
+            | "%identity-ints-repr", [ x ] ->
+                let* cx = access' ~ctx x in
+                return cx
+            | _ -> (
+                match internal_prim name with
+                | Some f -> f l ctx loc
+                | None ->
+                    if String.is_prefix name ~prefix:"%"
+                    then
+                      failwith (Printf.sprintf "Unresolved internal primitive: %s" name);
+                    let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
+                    let* () = info ~need_loc:true (kind (Primitive.kind name)) in
+                    let* args = list_map (fun x -> access' ~ctx x) l in
+                    return (J.call prim args loc)))
         | Not, [ x ] ->
             let* cx = access' ~ctx x in
             return (J.EBin (J.Minus, one, cx))
@@ -1532,7 +1537,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
@@ -2211,6 +2217,8 @@ let f
   p
 
 let init () =
+  let identity_ints_repr = "%identity-ints-repr" in
+  assert (Primitive.is_pure identity_ints_repr);
   List.iter
     ~f:(fun (nm, nm') -> Primitive.alias nm nm')
     [ "%int_mul", "caml_mul"
@@ -2228,10 +2236,10 @@ let init () =
     ; "caml_int32_shift_left", "%int_lsl"
     ; "caml_int32_shift_right", "%int_asr"
     ; "caml_int32_shift_right_unsigned", "%int_lsr"
-    ; "caml_int32_of_int", "%identity"
-    ; "caml_int32_to_int", "%identity"
+    ; "caml_int32_of_int", identity_ints_repr
+    ; "caml_int32_to_int", identity_ints_repr
     ; "caml_int32_of_float", "caml_int_of_float"
-    ; "caml_int32_to_float", "%identity"
+    ; "caml_int32_to_float", identity_ints_repr
     ; "caml_int32_format", "caml_format_int"
     ; "caml_int32_of_string", "caml_int_of_string"
     ; "caml_int32_compare", "caml_int_compare"
@@ -2247,12 +2255,12 @@ let init () =
     ; "caml_nativeint_shift_left", "%int_lsl"
     ; "caml_nativeint_shift_right", "%int_asr"
     ; "caml_nativeint_shift_right_unsigned", "%int_lsr"
-    ; "caml_nativeint_of_int", "%identity"
-    ; "caml_nativeint_to_int", "%identity"
+    ; "caml_nativeint_of_int", identity_ints_repr
+    ; "caml_nativeint_to_int", identity_ints_repr
     ; "caml_nativeint_of_float", "caml_int_of_float"
-    ; "caml_nativeint_to_float", "%identity"
-    ; "caml_nativeint_of_int32", "%identity"
-    ; "caml_nativeint_to_int32", "%identity"
+    ; "caml_nativeint_to_float", identity_ints_repr
+    ; "caml_nativeint_of_int32", identity_ints_repr
+    ; "caml_nativeint_to_int32", identity_ints_repr
     ; "caml_nativeint_format", "caml_format_int"
     ; "caml_nativeint_of_string", "caml_int_of_string"
     ; "caml_nativeint_compare", "caml_int_compare"
@@ -2261,7 +2269,7 @@ let init () =
     ; "caml_int64_to_int", "caml_int64_to_int32"
     ; "caml_int64_of_nativeint", "caml_int64_of_int32"
     ; "caml_int64_to_nativeint", "caml_int64_to_int32"
-    ; "caml_float_of_int", "%identity"
+    ; "caml_float_of_int", identity_ints_repr
     ; "caml_array_get_float", "caml_array_get"
     ; "caml_floatarray_get", "caml_array_get"
     ; "caml_array_get_addr", "caml_array_get"

compiler/lib/ocaml_compiler.ml

@@ -27,15 +27,9 @@ let rec constant_of_const c : Code.constant =
   | ((Const_base (Const_string (s, _))) [@if ocaml_version < (4, 11, 0)])
   | ((Const_base (Const_string (s, _, _))) [@if ocaml_version >= (4, 11, 0)]) -> 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

@@ -453,16 +453,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

compiler/lib/primitive.ml

@@ -76,7 +76,11 @@ let has_arity nm a = try Hashtbl.find arities (resolve nm) = a with Not_found ->
 
 let is_pure nm =
   match nm with
-  | "%identity" | "%direct_int_div" | "%direct_int_mod" | "%direct_int_mul" -> true
+  | "%identity"
+  | "%identity-ints-repr"
+  | "%direct_int_div"
+  | "%direct_int_mod"
+  | "%direct_int_mul" -> true
   | _ -> Poly.(kind nm <> `Mutator)
 
 let exists p = Hashtbl.mem kinds p

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