Make number representations compatible with Wasm

compiler/lib/code.ml

@@ -363,9 +363,11 @@ 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
   | Tuple of int * constant array * array_or_not
-  | Int of int32
 
 module Constant = struct
   type t = constant
@@ -386,26 +388,59 @@ module Constant = struct
             | Some s, Some c -> same := Some (s && c)
           done;
           !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)
     | Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b)
-    | Int a, Int b -> Some (Int32.equal a b)
     | Float a, Float b -> Some (Float.ieee_equal a b)
     | String _, NativeString _ | NativeString _, String _ -> None
     | Int _, Float _ | Float _, Int _ -> None
     | Tuple ((0 | 254), _, _), Float_array _ -> None
     | Float_array _, Tuple ((0 | 254), _, _) -> None
-    | Tuple _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
-        Some false
-    | Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
+    | ( Tuple _
+      , ( String _
+        | NativeString _
+        | Int64 _
+        | Int _
+        | Int32 _
+        | NativeInt _
+        | Float _
+        | Float_array _ ) ) -> Some false
+    | ( Float_array _
+      , ( String _
+        | NativeString _
+        | Int64 _
+        | Int _
+        | Int32 _
+        | NativeInt _
+        | Float _
+        | Tuple _ ) ) -> Some false
+    | ( String _
+      , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
         Some false
-    | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
-    | NativeString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
-    | Int64 _, (String _ | NativeString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
+    | ( NativeString _
+      , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) ->
         Some false
+    | ( Int64 _
+      , ( String _
+        | NativeString _
+        | Int _
+        | Int32 _
+        | NativeInt _
+        | Float _
+        | Tuple _
+        | Float_array _ ) ) -> Some false
     | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
         Some false
-    | Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
+    | ( (Int _ | Int32 _ | NativeInt _)
+      , (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
         Some false
+    (* Note: the following cases should not occur when compiling to Javascript *)
+    | Int _, (Int32 _ | NativeInt _)
+    | Int32 _, (Int _ | NativeInt _)
+    | NativeInt _, (Int _ | Int32 _)
+    | (Int32 _ | NativeInt _), Float _
+    | Float _, (Int32 _ | NativeInt _) -> None
 end
 
 type loc =
@@ -425,14 +460,18 @@ type mutability =
   | Immutable
   | Maybe_mutable
 
+type field_type =
+  | Non_float
+  | Float
+
 type expr =
   | Apply of
       { f : Var.t
       ; args : Var.t list
       ; exact : bool
       }
   | Block of int * Var.t array * array_or_not * mutability
-  | Field of Var.t * int
+  | Field of Var.t * int * field_type
   | Closure of Var.t list * cont
   | Constant of constant
   | Prim of prim * prim_arg list
@@ -441,7 +480,7 @@ type expr =
 type instr =
   | Let of Var.t * expr
   | Assign of Var.t * Var.t
-  | Set_field of Var.t * int * Var.t
+  | Set_field of Var.t * int * field_type * Var.t
   | Offset_ref of Var.t * int
   | Array_set of Var.t * Var.t * Var.t
 
@@ -496,7 +535,10 @@ module Print = struct
           Format.fprintf f "%.12g" a.(i)
         done;
         Format.fprintf f "|]"
+    | 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
     | Tuple (tag, a, _) -> (
         Format.fprintf f "<%d>" tag;
         match Array.length a with
@@ -513,7 +555,6 @@ module Print = struct
               constant f a.(i)
             done;
             Format.fprintf f ")")
-    | Int i -> Format.fprintf f "%ld" i
 
   let arg f a =
     match a with
@@ -583,7 +624,8 @@ module Print = struct
           Format.fprintf f "; %d = %a" i Var.print a.(i)
         done;
         Format.fprintf f "}"
-    | Field (x, i) -> Format.fprintf f "%a[%d]" Var.print x i
+    | Field (x, i, Non_float) -> Format.fprintf f "%a[%d]" Var.print x i
+    | Field (x, i, Float) -> Format.fprintf f "FLOAT{%a[%d]}" Var.print x i
     | Closure (l, c) -> Format.fprintf f "fun(%a){%a}" var_list l cont c
     | Constant c -> Format.fprintf f "CONST{%a}" constant c
     | Prim (p, l) -> prim f p l
@@ -593,7 +635,10 @@ module Print = struct
     match i with
     | Let (x, e) -> Format.fprintf f "%a = %a" Var.print x expr e
     | Assign (x, y) -> Format.fprintf f "(assign) %a = %a" Var.print x Var.print y
-    | Set_field (x, i, y) -> Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y
+    | Set_field (x, i, Non_float, y) ->
+        Format.fprintf f "%a[%d] = %a" Var.print x i Var.print y
+    | Set_field (x, i, Float, y) ->
+        Format.fprintf f "FLOAT{%a[%d]} = %a" Var.print x i Var.print y
     | Offset_ref (x, i) -> Format.fprintf f "%a[0] += %d" Var.print x i
     | Array_set (x, y, z) ->
         Format.fprintf f "%a[%a] = %a" Var.print x Var.print y Var.print z
@@ -867,7 +912,7 @@ let invariant { blocks; start; _ } =
     let check_expr = function
       | Apply _ -> ()
       | Block (_, _, _, _) -> ()
-      | Field (_, _) -> ()
+      | Field (_, _, _) -> ()
       | Closure (l, cont) ->
           List.iter l ~f:define;
           check_cont cont
@@ -881,7 +926,7 @@ let invariant { blocks; start; _ } =
           define x;
           check_expr e
       | Assign _ -> ()
-      | Set_field (_, _i, _) -> ()
+      | Set_field (_, _i, _, _) -> ()
       | Offset_ref (_x, _i) -> ()
       | Array_set (_x, _y, _z) -> ()
     in

compiler/lib/code.mli

@@ -183,9 +183,11 @@ 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. *)
   | Tuple of int * constant array * array_or_not
-  | Int of int32
 
 module Constant : sig
   type t = constant
@@ -216,14 +218,18 @@ type mutability =
   | Immutable
   | Maybe_mutable
 
+type field_type =
+  | Non_float
+  | Float
+
 type expr =
   | Apply of
       { f : Var.t
       ; args : Var.t list
       ; exact : bool (* if true, then # of arguments = # of parameters *)
       }
   | Block of int * Var.t array * array_or_not * mutability
-  | Field of Var.t * int
+  | Field of Var.t * int * field_type
   | Closure of Var.t list * cont
   | Constant of constant
   | Prim of prim * prim_arg list
@@ -232,7 +238,7 @@ type expr =
 type instr =
   | Let of Var.t * expr
   | Assign of Var.t * Var.t
-  | Set_field of Var.t * int * Var.t
+  | Set_field of Var.t * int * field_type * Var.t
   | Offset_ref of Var.t * int
   | Array_set of Var.t * Var.t * Var.t
 

compiler/lib/deadcode.ml

@@ -71,7 +71,7 @@ and mark_expr st e =
       mark_var st f;
       List.iter args ~f:(fun x -> mark_var st x)
   | Block (_, a, _, _) -> Array.iter a ~f:(fun x -> mark_var st x)
-  | Field (x, _) -> mark_var st x
+  | Field (x, _, _) -> mark_var st x
   | Closure (_, (pc, _)) -> mark_reachable st pc
   | Special _ -> ()
   | Prim (_, l) ->
@@ -91,7 +91,7 @@ and mark_reachable st pc =
         match i with
         | Let (_, e) -> if not (pure_expr st.pure_funs e) then mark_expr st e
         | Assign _ -> ()
-        | Set_field (x, _, y) -> (
+        | Set_field (x, _, _, y) -> (
             match st.defs.(Var.idx x) with
             | [ Expr (Block _) ] when st.live.(Var.idx x) = 0 ->
                 (* We will keep this instruction only if x is live *)
@@ -124,7 +124,7 @@ and mark_reachable st pc =
 let live_instr st i =
   match i with
   | Let (x, e) -> st.live.(Var.idx x) > 0 || not (pure_expr st.pure_funs e)
-  | Assign (x, _) | Set_field (x, _, _) -> st.live.(Var.idx x) > 0
+  | Assign (x, _) | Set_field (x, _, _, _) -> st.live.(Var.idx x) > 0
   | Offset_ref _ | Array_set _ -> true
 
 let rec filter_args st pl al =
@@ -201,7 +201,7 @@ let f ({ blocks; _ } as p : Code.program) =
           match i with
           | Let (x, e) -> add_def defs x (Expr e)
           | Assign (x, y) -> add_def defs x (Var y)
-          | Set_field (_, _, _) | Array_set (_, _, _) | Offset_ref (_, _) -> ());
+          | Set_field (_, _, _, _) | Array_set (_, _, _) | Offset_ref (_, _) -> ());
       match fst block.branch with
       | Return _ | Raise _ | Stop -> ()
       | Branch cont -> add_cont_dep blocks defs cont

compiler/lib/duplicate.ml

@@ -27,7 +27,7 @@ let expr s e =
   | Apply { f; args; exact } ->
       Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact }
   | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut)
-  | Field (x, n) -> Field (s x, n)
+  | Field (x, n, field_type) -> Field (s x, n, field_type)
   | Closure _ -> failwith "Inlining/Duplicating closure is currenly not supported"
   | Special x -> Special x
   | Prim (p, l) ->
@@ -41,7 +41,7 @@ let instr s i =
   match i with
   | Let (x, e) -> Let (s x, expr s e)
   | Assign (x, y) -> Assign (s x, s y)
-  | Set_field (x, n, y) -> Set_field (s x, n, s y)
+  | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y)
   | Offset_ref (x, n) -> Offset_ref (s x, n)
   | Array_set (x, y, z) -> Array_set (s x, s y, s z)
 

compiler/lib/eval.ml

@@ -41,7 +41,7 @@ let shift l f =
   | [ Int i; Int j ] -> Some (Int (f i (Int32.to_int j land 0x1f)))
   | _ -> None
 
-let float_binop_aux l f =
+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)
@@ -54,12 +54,12 @@ let float_binop_aux l f =
   | None -> None
   | Some (i, j) -> Some (f i j)
 
-let float_binop l f =
+let float_binop (l : constant list) (f : float -> float -> float) : constant option =
   match float_binop_aux l f with
   | Some x -> Some (Float x)
   | None -> None
 
-let float_unop l f =
+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 (Int32.to_float i)))
@@ -251,6 +251,10 @@ let constant_js_equal a b =
   | _, Float_array _
   | Int64 _, _
   | _, Int64 _
+  | Int32 _, _
+  | _, Int32 _
+  | NativeInt _, _
+  | _, NativeInt _
   | Tuple _, _
   | _, Tuple _ -> None
 
@@ -295,7 +299,17 @@ let eval_instr info ((x, loc) as i) =
           let c = Constant (Int c) in
           Flow.Info.update_def info x c;
           [ Let (x, c), loc ])
-  | Let (_, Prim (Extern ("caml_array_unsafe_get" | "caml_array_unsafe_set"), _)) ->
+  | Let
+      ( _
+      , Prim
+          ( ( Extern
+                ( "caml_array_unsafe_get"
+                | "caml_array_unsafe_set"
+                | "caml_floatarray_unsafe_get"
+                | "caml_floatarray_unsafe_set"
+                | "caml_array_unsafe_set_addr" )
+            | Array_get )
+          , _ ) ) ->
       (* Fresh parameters can be introduced for these primitives
            in Specialize_js, which would make the call to [the_const_of]
            below fail. *)
@@ -371,6 +385,8 @@ let the_cond_of info x =
       | Some
           (Constant
             ( Int _
+            | Int32 _
+            | NativeInt _
             | Float _
             | Tuple _
             | String _
@@ -417,10 +433,11 @@ let rec do_not_raise pc visited blocks =
     let b = Addr.Map.find pc blocks in
     List.iter b.body ~f:(fun (i, _loc) ->
         match i with
-        | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _) | Assign _ -> ()
+        | Array_set (_, _, _) | Offset_ref (_, _) | Set_field (_, _, _, _) | Assign _ ->
+            ()
         | Let (_, e) -> (
             match e with
-            | Block (_, _, _, _) | Field (_, _) | Constant _ | Closure _ -> ()
+            | Block (_, _, _, _) | Field (_, _, _) | Constant _ | Closure _ -> ()
             | Apply _ -> raise May_raise
             | Special _ -> ()
             | Prim (Extern name, _) when Primitive.is_pure name -> ()

compiler/lib/flow.ml

@@ -104,7 +104,7 @@ let expr_deps blocks vars deps defs x e =
       List.iter l ~f:(fun x -> add_param_def vars defs x);
       cont_deps blocks vars deps defs cont
   | Block (_, a, _, _) -> Array.iter a ~f:(fun y -> add_dep deps x y)
-  | Field (y, _) -> add_dep deps x y
+  | Field (y, _, _) -> add_dep deps x y
 
 let program_deps { blocks; _ } =
   let nv = Var.count () in
@@ -148,7 +148,7 @@ let propagate1 deps defs st x =
       match e with
       | Constant _ | Apply _ | Prim _ | Special _ | Closure _ | Block _ ->
           Var.Set.singleton x
-      | Field (y, n) ->
+      | Field (y, n, _) ->
           var_set_lift
             (fun z ->
               match defs.(Var.idx z) with
@@ -254,7 +254,7 @@ let program_escape defs known_origins { blocks; _ } =
           match i with
           | Let (x, e) -> expr_escape st x e
           | Assign _ -> ()
-          | Set_field (x, _, y) | Array_set (x, _, y) ->
+          | Set_field (x, _, _, y) | Array_set (x, _, y) ->
               Var.Set.iter
                 (fun y -> Var.ISet.add possibly_mutable y)
                 (Var.Tbl.get known_origins x);
@@ -278,7 +278,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x =
   | Expr e -> (
       match e with
       | Constant _ | Closure _ | Apply _ | Prim _ | Block _ | Special _ -> false
-      | Field (y, n) ->
+      | Field (y, n, _) ->
           Var.Tbl.get st y
           || Var.Set.exists
                (fun z ->
@@ -356,6 +356,10 @@ let constant_identical a b =
   | _, Float_array _
   | Int64 _, _
   | _, Int64 _
+  | Int32 _, _
+  | _, Int32 _
+  | NativeInt _, _
+  | _, NativeInt _
   | Tuple _, _
   | _, Tuple _ -> false
 
@@ -397,7 +401,7 @@ let the_native_string_of info x =
 (*XXX Maybe we could iterate? *)
 let direct_approx (info : Info.t) x =
   match info.info_defs.(Var.idx x) with
-  | Expr (Field (y, n)) ->
+  | Expr (Field (y, n, _)) ->
       get_approx
         info
         (fun z ->