Merge pull request #70 from OlivierNicole/converge-jsoo-merge-06

Integrate latest changes to number representation from js_of_ocaml

compiler/lib/code.ml

@@ -284,9 +284,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 int_kind * int32
 
 let rec constant_equal a b =
   match a, b with
@@ -304,26 +306,59 @@ let rec constant_equal a b =
           | 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.equal a b)
-  | Int (k, a), Int (k', b) -> if Poly.(k = k') then Some (Int32.equal a b) else None
   | Float a, Float b -> Some (Float.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 _) ->
+  | ( 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
-  | Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
-      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
 
 type loc =
   | No
@@ -342,14 +377,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
@@ -358,7 +397,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
 
@@ -413,7 +452,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
@@ -430,15 +472,6 @@ module Print = struct
               constant f a.(i)
             done;
             Format.fprintf f ")")
-    | Int (k, i) ->
-        Format.fprintf
-          f
-          "%ld%s"
-          i
-          (match k with
-          | Regular -> ""
-          | Int32 -> "l"
-          | Native -> "n")
 
   let arg f a =
     match a with
@@ -508,7 +541,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
@@ -518,7 +552,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
@@ -792,7 +829,7 @@ let invariant { blocks; start; _ } =
     let check_expr = function
       | Apply _ -> ()
       | Block (_, _, _, _) -> ()
-      | Field (_, _) -> ()
+      | Field (_, _, _) -> ()
       | Closure (l, cont) ->
           List.iter l ~f:define;
           check_cont cont
@@ -806,7 +843,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

@@ -162,9 +162,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 int_kind * int32
 
 val constant_equal : constant -> constant -> bool option
 
@@ -189,14 +191,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
@@ -205,7 +211,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

@@ -62,7 +62,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) ->
@@ -82,7 +82,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) ->
             mark_var st x;
             mark_var st y
         | Array_set (x, y, z) ->
@@ -190,7 +190,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/effects.ml

@@ -300,7 +300,7 @@ let cps_branch ~st ~src (pc, args) loc =
           (* We are jumping to a block that is also used as a continuation.
              We pass it a dummy argument. *)
           let x = Var.fresh () in
-          [ x ], [ Let (x, Constant (Int (Regular, 0l))), noloc ]
+          [ x ], [ Let (x, Constant (Int 0l)), noloc ]
         else args, []
       in
       (* We check the stack depth only for backward edges (so, at
@@ -402,7 +402,7 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k :
                         ( x'
                         , Prim
                             ( Extern "caml_maybe_attach_backtrace"
-                            , [ Pv x; Pc (Int (Regular, if force then 1l else 0l)) ] ) )
+                            , [ Pv x; Pc (Int (if force then 1l else 0l)) ] ) )
                     , noloc )
                   ]
                 in
@@ -480,12 +480,12 @@ let cps_instr ~st (instr : instr) : instr =
       Let (x, Closure (params @ [ k ], cont))
   | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> (
       match arity with
-      | Pc (Int (_, a)) ->
+      | Pc (Int a) ->
           Let
             ( x
             , Prim
                 ( Extern "caml_alloc_dummy_function"
-                , [ size; Pc (Int (Regular, Int32.succ a)) ] ) )
+                , [ size; Pc (Int (Int32.succ a)) ] ) )
       | _ -> assert false)
   | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) ->
       (* At the moment, we turn into CPS any function not called with
@@ -563,7 +563,7 @@ let cps_block ~st ~k pc block =
               [ arg; k' ]
               loc)
     | Prim (Extern "%perform", [ Pv effect ]) ->
-        perform_effect ~effect ~continuation:(Pc (Int (Regular, 0l))) loc
+        perform_effect ~effect ~continuation:(Pc (Int 0l)) loc
     | Prim (Extern "%reperform", [ Pv effect; continuation ]) ->
         perform_effect ~effect ~continuation loc
     | _ -> None