OxCaml: indexing by unboxed int

Author: vouillon

compiler/lib-wasm/generate.ml

@@ -317,6 +317,12 @@ module Generate (Target : Target_sig.S) = struct
         | [ x ] -> f (transl_prim_arg ctx ?typ x)
         | l -> invalid_arity name l ~expected:1)
 
+  let register_un_prim_ctx name ?typ ?ret_typ f =
+    register_prim name `Mutator ~unbox:(is_unboxed typ) ?ret_typ (fun ctx context l ->
+        match l with
+        | [ x ] -> f context (transl_prim_arg ctx ?typ x)
+        | l -> invalid_arity name l ~expected:1)
+
   let register_bin_prim name k ?tx ?ty ?ret_typ f =
     let unbox = is_unboxed tx || is_unboxed ty in
     register_prim name k ~unbox ?ret_typ (fun ctx _ l ->
@@ -415,12 +421,44 @@ module Generate (Target : Target_sig.S) = struct
       ~ty:int_n
       ~ret_typ:float_u
       Memory.float_array_get;
+    register_bin_prim
+      "caml_array_unsafe_get_indexed_by_int32"
+      `Mutable
+      ~ty:int32_u
+      (fun x y -> Memory.gen_array_get x y);
+    register_bin_prim
+      "caml_array_unsafe_get_indexed_by_int64"
+      `Mutable
+      ~ty:int64_u
+      (fun x y ->
+        let y =
+          let* y = y in
+          return (W.I32WrapI64 y)
+        in
+        Memory.gen_array_get x y);
+    register_bin_prim
+      "caml_array_unsafe_get_indexed_by_nativeint"
+      `Mutable
+      ~ty:nativeint_u
+      (fun x y -> Memory.gen_array_get x y);
     register_tern_prim "caml_array_unsafe_set" ~ty:int_n (fun x y z ->
         seq (Memory.gen_array_set x y z) Value.unit);
     register_tern_prim "caml_array_unsafe_set_addr" ~ty:int_n (fun x y z ->
         seq (Memory.array_set x y z) Value.unit);
     register_tern_prim "caml_floatarray_unsafe_set" ~ty:int_n ~tz:float_u (fun x y z ->
         seq (Memory.float_array_set x y z) Value.unit);
+    register_tern_prim "caml_array_unsafe_set_indexed_by_int32" ~ty:int32_u (fun x y z ->
+        seq (Memory.gen_array_set x y z) Value.unit);
+    register_tern_prim "caml_array_unsafe_set_indexed_by_int64" ~ty:int64_u (fun x y z ->
+        let y =
+          let* y = y in
+          return (W.I32WrapI64 y)
+        in
+        seq (Memory.gen_array_set x y z) Value.unit);
+    register_tern_prim
+      "caml_array_unsafe_set_indexed_by_nativeint"
+      ~ty:nativeint_u
+      (fun x y z -> seq (Memory.gen_array_set x y z) Value.unit);
     register_bin_prim
       "caml_string_unsafe_get"
       `Pure
@@ -514,6 +552,50 @@ module Generate (Target : Target_sig.S) = struct
            let* cond = Arith.uge y (Memory.float_array_length (load a)) in
            instr (W.Br_if (label, cond)))
           x);
+    register_un_prim_ctx
+      "caml_checked_int32_to_int"
+      ~typ:int32_u
+      ~ret_typ:int_n
+      (fun context x ->
+        let y = Code.Var.fresh () in
+        seq
+          (let* () = store y x in
+           let label = label_index context bound_error_pc in
+           let* cond = Arith.((load y lsl const 1l) asr const 1l <> load y) in
+           instr (W.Br_if (label, cond)))
+          (load y));
+    register_un_prim_ctx
+      "caml_checked_nativeint_to_int"
+      ~typ:nativeint_u
+      ~ret_typ:int_n
+      (fun context x ->
+        let y = Code.Var.fresh () in
+        seq
+          (let* () = store y x in
+           let label = label_index context bound_error_pc in
+           let* cond = Arith.((load y lsl const 1l) asr const 1l <> load y) in
+           instr (W.Br_if (label, cond)))
+          (load y));
+    register_un_prim_ctx
+      "caml_checked_int64_to_int"
+      ~typ:int64_u
+      ~ret_typ:int_n
+      (fun context x ->
+        let y = Code.Var.fresh () in
+        seq
+          (let* () = store y x in
+           let* y = load y in
+           let label = label_index context bound_error_pc in
+           let cond =
+             W.BinOp
+               ( I64 Ne
+               , y
+               , BinOp (I64 (Shr U), BinOp (I64 Shl, y, Const (I64 33L)), Const (I64 33L))
+               )
+           in
+           instr (W.Br_if (label, cond)))
+          (let* y = load y in
+           return (W.I32WrapI64 y)));
     register_arith_bin_prim "caml_add_float" `Pure ~typ:float_u (fun f g ->
         float_bin_op Add f g);
     register_arith_bin_prim "caml_sub_float" ~typ:float_u `Pure (fun f g ->
@@ -1883,6 +1965,9 @@ module Generate (Target : Target_sig.S) = struct
                         | "caml_check_bound"
                         | "caml_check_bound_gen"
                         | "caml_check_bound_float"
+                        | "caml_checked_int32_to_int"
+                        | "caml_checked_nativeint_to_int"
+                        | "caml_checked_int64_to_int"
                         | "caml_ba_get_1"
                         | "caml_ba_get_2"
                         | "caml_ba_get_3"

compiler/lib/eval.ml

@@ -298,6 +298,17 @@ let eval_prim ~target x =
       | "caml_nativeint_compare", [ NativeInt i; NativeInt j ] ->
           Some (Int (Targetint.of_int_exn (Int32.compare i j)))
       | "caml_nativeint_to_int", [ Int32 i ] -> Some (Int (Targetint.of_int32_truncate i))
+      | "caml_checked_int32_to_int", [ Int32 i ]
+        when Int32.equal i (Targetint.to_int32 (Targetint.of_int32_truncate i)) ->
+          Some (Int (Targetint.of_int32_truncate i))
+      | "caml_checked_nativeint_to_int", [ Int32 i ]
+        when Int32.equal i (Targetint.to_int32 (Targetint.of_int32_truncate i)) ->
+          Some (Int (Targetint.of_int32_truncate i))
+      | "caml_checked_int64_to_int", [ Int64 i ]
+        when let j = Int64.to_int32 i in
+             Int64.equal i (Int64.of_int32 j)
+             && Int32.equal j (Targetint.to_int32 (Targetint.of_int32_truncate j)) ->
+          Some (Int (Targetint.of_int32_truncate (Int64.to_int32 i)))
       | "caml_nativeint_of_int", [ Int i ] -> nativeint (Targetint.to_int32 i)
       (* int64 *)
       | "caml_int64_bits_of_float", [ Float f ] -> int64 f

compiler/lib/flow.ml

@@ -54,8 +54,9 @@ module Info = struct
   let possibly_mutable t x = Code.Var.ISet.mem t.info_possibly_mutable x
 
   let update_def { info_defs; _ } x exp =
+    (* [Specialize_js] can introduce fresh variables *)
     let idx = Code.Var.idx x in
-    info_defs.(idx) <- Expr exp
+    if idx < Array.length info_defs then info_defs.(idx) <- Expr exp
 end
 
 let undefined = Phi Var.Set.empty
@@ -338,10 +339,11 @@ let get_approx
     top
     join
     x =
-  let s = Var.Tbl.get info_known_origins x in
-  if Var.Tbl.get info_maybe_unknown x
+  (* [Specialize_js] can introduce fresh variables *)
+  if Var.idx x >= Var.Tbl.length info_known_origins || Var.Tbl.get info_maybe_unknown x
   then top
   else
+    let s = Var.Tbl.get info_known_origins x in
     match Var.Set.cardinal s with
     | 0 -> top
     | 1 -> f (Var.Set.choose s)

compiler/lib/generate.ml

@@ -1259,6 +1259,8 @@ let _ =
     [ "caml_array_unsafe_get"
     ; "caml_array_unsafe_get_float"
     ; "caml_floatarray_unsafe_get"
+    ; "caml_array_unsafe_get_indexed_by_int32"
+    ; "caml_array_unsafe_get_indexed_by_nativeint"
     ]
     `Mutable
     (fun cx cy _ -> Mlvalue.Array.field cx cy);
@@ -1275,6 +1277,10 @@ let _ =
     ]
     `Pure
     (fun cx _ -> cx);
+  register_un_prims
+    [ "caml_checked_nativeint_to_int"; "caml_checked_int32_to_int" ]
+    `Mutator
+    (fun cx _ -> cx);
   register_bin_prims
     [ "%int_add"; "caml_int32_add"; "caml_nativeint_add" ]
     `Pure
@@ -1355,6 +1361,8 @@ let _ =
     ; "caml_array_unsafe_set_float"
     ; "caml_floatarray_unsafe_set"
     ; "caml_array_unsafe_set_addr"
+    ; "caml_array_unsafe_set_indexed_by_int32"
+    ; "caml_array_unsafe_set_indexed_by_nativeint"
     ]
     `Mutator
     (fun cx cy cz _ -> J.EBin (J.Eq, Mlvalue.Array.field cx cy, cz));

compiler/lib/specialize_js.ml

@@ -283,6 +283,46 @@ let idx_equal (v1, c1) (v2, c2) =
   | `Var a, `Var b -> Code.Var.equal a b
   | `Cst _, `Var _ | `Var _, `Cst _ -> false
 
+let indexing_primitives l =
+  let h = String.Hashtbl.create 16 in
+  List.iter l ~f:(fun prim ->
+      List.iter [ "int32"; "nativeint"; "int64" ] ~f:(fun int ->
+          String.Hashtbl.add
+            h
+            (prim ^ "_indexed_by_" ^ int)
+            ("caml_checked_" ^ int ^ "_to_int", prim)));
+  h
+
+let getters =
+  indexing_primitives
+    [ "caml_array_get"
+    ; "caml_string_get16"
+    ; "caml_string_get32"
+    ; "caml_string_get64"
+    ; "caml_string_getf32"
+    ; "caml_bytes_get16"
+    ; "caml_bytes_get32"
+    ; "caml_bytes_get64"
+    ; "caml_bytes_getf32"
+    ; "caml_ba_uint8_get16"
+    ; "caml_ba_uint8_get32"
+    ; "caml_ba_uint8_get64"
+    ; "caml_ba_uint8_getf32"
+    ]
+
+let setters =
+  indexing_primitives
+    [ "caml_array_set"
+    ; "caml_bytes_set16"
+    ; "caml_bytes_set32"
+    ; "caml_bytes_set64"
+    ; "caml_bytes_setf32"
+    ; "caml_ba_uint8_set16"
+    ; "caml_ba_uint8_set32"
+    ; "caml_ba_uint8_set64"
+    ; "caml_ba_uint8_setf32"
+    ]
+
 let specialize_instrs ~target opt_count info l =
   let rec aux info checks l acc =
     match l with
@@ -293,6 +333,18 @@ let specialize_instrs ~target opt_count info l =
            the array access. The bound checking function returns the array,
            which allows to produce more compact code. *)
         match i with
+        | Let (x, Prim (Extern prim, [ y; z ])) when String.Hashtbl.mem getters prim ->
+            let conv, access = String.Hashtbl.find getters prim in
+            let z' = Code.Var.fresh () in
+            let r =
+              Let (z', Prim (Extern conv, [ z ]))
+              (* The recursive call to [aux] will optimize
+                 [caml_array_get] into a nominally "unsafe" (but
+                 guarded) access. *)
+              :: Let (x, Prim (Extern access, [ y; Pv z' ]))
+              :: r
+            in
+            aux info checks r acc
         | Let
             ( x
             , Prim
@@ -339,6 +391,18 @@ let specialize_instrs ~target opt_count info l =
               incr opt_count;
               let acc = instr y' :: Let (y', Prim (Extern check, [ Pv y; z ])) :: acc in
               aux info ((y, idx) :: checks) r acc
+        | Let (x, Prim (Extern prim, [ y; z; w ])) when String.Hashtbl.mem setters prim ->
+            let conv, setter = String.Hashtbl.find setters prim in
+            let z' = Code.Var.fresh () in
+            let r =
+              Let (z', Prim (Extern conv, [ z ]))
+              (* The recursive call to [aux] will optimize
+                 [caml_array_set] into a nominally "unsafe" (but
+                 guarded) access. *)
+              :: Let (x, Prim (Extern setter, [ y; Pv z'; w ]))
+              :: r
+            in
+            aux info checks r acc
         | Let
             ( x
             , Prim

runtime/js/int64.js

@@ -352,6 +352,31 @@ function caml_int64_to_int32(x) {
   return x.toInt();
 }
 
+//Provides: caml_checked_int64_to_int
+//Requires: caml_int64_of_int32, caml_array_bound_error
+//Version: >= 5.2, < 5.3
+//OxCaml
+function caml_checked_int64_to_int(x) {
+  var y = x.toInt();
+  if (x.compare(caml_int64_of_int32(y)) !== 0) caml_array_bound_error();
+  return y;
+}
+
+//Provides: caml_array_unsafe_get_indexed_by_int64 mutable (mutable, const)
+//Version: >= 5.2, < 5.3
+//OxCaml
+function caml_array_unsafe_get_indexed_by_int64(array, index) {
+  return array[index.toInt() + 1];
+}
+
+//Provides: caml_array_unsafe_set_indexed_by_int64 (mutable, const, mutable)
+//Version: >= 5.2, < 5.3
+//OxCaml
+function caml_array_unsafe_set_indexed_by_int64(array, index, newval) {
+  array[index.toInt() + 1] = newval;
+  return 0;
+}
+
 //Provides: caml_int64_to_float const
 function caml_int64_to_float(x) {
   return x.toFloat();