addressed some feedback, cleaned some things up

backend/cmm_builtins.ml

@@ -512,7 +512,7 @@ let transl_builtin name args dbg typ_res =
   | "caml_unsigned_int64_mulh_unboxed" ->
     mulhi ~signed:false Unboxed_int64 args dbg
   | "caml_int32_unsigned_to_int_trunc_unboxed_to_untagged" ->
-    Some (zero_extend_32 dbg (one_arg name args))
+    Some (zero_extend ~bits:32 (one_arg name args) dbg)
   | "caml_csel_value" | "caml_csel_int_untagged" | "caml_csel_int64_unboxed"
   | "caml_csel_int32_unboxed" | "caml_csel_nativeint_unboxed" ->
     (* Unboxed float variant of csel intrinsic is not currently supported. It

backend/cmm_helpers.ml

@@ -20,6 +20,8 @@ module VP = Backend_var.With_provenance
 open Cmm
 open Arch
 
+let arch_bits = 8 * Arch.size_int
+
 type arity =
   { function_kind : Lambda.function_kind;
     params_layout : Lambda.layout list;
@@ -763,10 +765,10 @@ let safe_divmod_bi mkop mkm1 ?(dividend_cannot_be_min_int = false) is_safe
       bind "dividend" dividend (fun dividend ->
           let dividend_cannot_be_min_int =
             dividend_cannot_be_min_int
-            || dividend |> is_different_from Nativeint.min_int
+            || is_different_from Nativeint.min_int dividend
           in
           let divisor_cannot_be_negative_one =
-            divisor |> is_different_from (-1n)
+            is_different_from (-1n) divisor
           in
           let c = mkop dividend divisor is_safe dbg in
           if Arch.division_crashes_on_overflow
@@ -1272,6 +1274,7 @@ let addr_array_initialize arr ofs newval dbg =
       [array_indexing log2_size_addr arr ofs dbg; newval],
       dbg )
 
+(** [get_const_bitmask x] returns [Some (y, mask)] if [x] is [y & mask] *)
 let get_const_bitmask = function
   | Cop (Cand, ([x; Cconst_natint (mask, _)] | [Cconst_natint (mask, _); x]), _)
     ->
@@ -1280,10 +1283,10 @@ let get_const_bitmask = function
     Some (x, Nativeint.of_int mask)
   | _ -> None
 
-(* [low_bits ~bits x] is a value which agrees with x on at least the low [bits]
-   bits *)
-let rec low_bits ~bits dbg x =
-  let arch_bits = Arch.size_int * 8 in
+(** [low_bits ~bits x] is a (hopefully simplified) value which agrees with x on at least
+    the low [bits] bits. E.g., [low_bits ~bits x & mask = x & mask], where [mask] is a
+    bitmask of the low [bits] bits . *)
+let rec low_bits ~bits x dbg =
   assert (0 < bits && bits <= arch_bits);
   let unused_bits = arch_bits - bits in
   let does_mask_ignore_low_bits test_mask =
@@ -1303,16 +1306,17 @@ let rec low_bits ~bits dbg x =
               [Cop (Clsl, [x; Cconst_int (left, _)], _); Cconst_int (right, _)],
               _ )
           when 0 <= right && right <= left && left <= unused_bits ->
-          low_bits ~bits dbg (lsl_const x (left - right) dbg)
+          low_bits ~bits (lsl_const x (left - right) dbg) dbg
         | x -> (
           match get_const_bitmask x with
           | Some (x, bitmask) when does_mask_ignore_low_bits bitmask ->
-            low_bits ~bits dbg x
+            low_bits ~bits x dbg
           | _ -> x))
       x
 
-let zero_extend ~bits dbg e =
-  let arch_bits = Arch.size_int * 8 in
+(** [zero_extend ~bits dbg e] returns [e] with the most significant [arch_bits - bits]
+    bits set to 0 *)
+let zero_extend ~bits e dbg =
   let mask = Nativeint.pred (Nativeint.shift_left 1n bits) in
   let zero_extend_via_mask e =
     Cop (Cand, [e; natint_const_untagged dbg mask], dbg)
@@ -1338,10 +1342,9 @@ let zero_extend ~bits dbg e =
           match get_const_bitmask e with
           | Some (_, bitmask) when is_zero_extension_mask bitmask -> e
           | _ -> zero_extend_via_mask e))
-      (low_bits ~bits dbg e)
+      (low_bits ~bits e dbg)
 
-let sign_extend ~bits dbg e =
-  let arch_bits = Arch.size_int * 8 in
+let sign_extend ~bits e dbg =
   let unused_bits = arch_bits - bits in
   let sign_extend_via_shift e =
     asr_const (lsl_const e unused_bits dbg) unused_bits dbg
@@ -1369,12 +1372,7 @@ let sign_extend ~bits dbg e =
           | (Thirtytwo_signed | Thirtytwo_unsigned), 32 -> load Thirtytwo_signed
           | _ -> sign_extend_via_shift e)
         | e -> sign_extend_via_shift e)
-      (low_bits ~bits dbg e)
-
-let low_32 dbg x = low_bits ~bits:32 dbg x
-
-(* sign_extend_32 sign-extends values from 32 bits to the word size. *)
-let sign_extend_32 dbg x = sign_extend ~bits:32 dbg x
+      (low_bits ~bits e dbg)
 
 let unboxed_packed_array_ref arr index dbg ~memory_chunk ~elements_per_word =
   bind "arr" arr (fun arr ->
@@ -1401,18 +1399,19 @@ let unboxed_int32_array_ref =
 let unboxed_mutable_int32_unboxed_product_array_ref arr ~array_index dbg =
   bind "arr" arr (fun arr ->
       bind "index" array_index (fun index ->
-          sign_extend_32 dbg
+          sign_extend ~bits:32
             (Cop
                ( mk_load_mut Thirtytwo_signed,
                  [array_indexing log2_size_addr arr index dbg],
-                 dbg ))))
+                 dbg ))
+            dbg))
 
 let unboxed_mutable_int32_unboxed_product_array_set arr ~array_index ~new_value
     dbg =
   bind "arr" arr (fun arr ->
       bind "index" array_index (fun index ->
           bind "new_value" new_value (fun new_value ->
-              let new_value = sign_extend_32 dbg new_value in
+              let new_value = sign_extend ~bits:32 new_value dbg in
               Cop
                 ( Cstore (Word_int, Assignment),
                   [array_indexing log2_size_addr arr index dbg; new_value],
@@ -1485,16 +1484,14 @@ let get_field_computed imm_or_ptr mutability ~block ~index dbg =
   Cop
     (Cload { memory_chunk; mutability; is_atomic = false }, [field_address], dbg)
 
-(* Getters for unboxed int fields *)
-
 let get_field_unboxed_int8 mutability ~block ~index dbg =
   let memory_chunk = Byte_signed in
   if Arch.big_endian
   then
     Misc.fatal_error
       "Unboxed int8 fields only supported on little-endian architectures";
-  (* CR layouts v5.1: We'll need to vary log2_size_addr to efficiently pack
-   * int8s *)
+  (* CR layouts v5.1: We'll need to vary log2_size_addr among other things to
+     efficiently pack int8s *)
   let field_address = array_indexing log2_size_addr block index dbg in
   Cop
     (Cload { memory_chunk; mutability; is_atomic = false }, [field_address], dbg)
@@ -1506,8 +1503,8 @@ let get_field_unboxed_int16 mutability ~block ~index dbg =
   then
     Misc.fatal_error
       "Unboxed int16 fields only supported on little-endian architectures";
-  (* CR layouts v5.1: We'll need to vary log2_size_addr to efficiently pack
-   * int16s *)
+  (* CR layouts v5.1: We'll need to vary log2_size_addr among other things to
+     efficiently pack int8s *)
   let field_address = array_indexing log2_size_addr block index dbg in
   Cop
     (Cload { memory_chunk; mutability; is_atomic = false }, [field_address], dbg)
@@ -2081,30 +2078,15 @@ let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function
   | Pbigarray_complex32 -> Single { reg = Float64 }
   | Pbigarray_complex64 -> Double
 
-(* the three functions below assume 64-bit words *)
-let () = assert (size_int = 8)
-
-(* Like [low_32] but for 63-bit integers held in 64-bit registers. *)
-let low_63 dbg e = low_bits ~bits:63 dbg e
-
-(* CR-someday mshinwell/gbury: sign_extend_63 then tag_int should simplify to
-   just tag_int. *)
-let sign_extend_63 dbg e = sign_extend ~bits:63 dbg e
-
-(* zero_extend_32 zero-extends values from 32 bits to the word size. *)
-let zero_extend_32 dbg e = zero_extend ~bits:32 dbg e
-
-let zero_extend_63 dbg e = zero_extend ~bits:63 dbg e
-
 let and_int e1 e2 dbg =
   let is_mask32 = function
     | Cconst_natint (0xFFFF_FFFFn, _) -> true
     | Cconst_int (n, _) -> Nativeint.of_int n = 0xFFFF_FFFFn
     | _ -> false
   in
   match e1, e2 with
-  | e, m when is_mask32 m -> zero_extend_32 dbg e
-  | m, e when is_mask32 m -> zero_extend_32 dbg e
+  | e, m when is_mask32 m -> zero_extend ~bits:32 e dbg
+  | m, e when is_mask32 m -> zero_extend ~bits:32 e dbg
   | e1, e2 -> Cop (Cand, [e1; e2], dbg)
 
 let or_int e1 e2 dbg = Cop (Cor, [e1; e2], dbg)
@@ -2132,9 +2114,7 @@ let box_int_gen dbg (bi : Primitive.boxed_integer) mode arg =
   let arg' =
     if bi = Primitive.Boxed_int32
     then
-      if big_endian
-      then Cop (Clsl, [arg; Cconst_int (32, dbg)], dbg)
-      else sign_extend_32 dbg arg
+      if big_endian then lsl_const arg 32 dbg else sign_extend ~bits:32 arg dbg
     else arg
   in
   Cop
@@ -2178,12 +2158,12 @@ let unbox_int dbg bi =
       when bi = Primitive.Boxed_int32 && big_endian
            && alloc_matches_boxed_int bi ~hdr ~ops ->
       (* Force sign-extension of low 32 bits *)
-      sign_extend_32 dbg contents
+      sign_extend ~bits:32 contents dbg
     | Cop (Calloc _, [hdr; ops; contents], _dbg)
       when bi = Primitive.Boxed_int32 && (not big_endian)
            && alloc_matches_boxed_int bi ~hdr ~ops ->
       (* Force sign-extension of low 32 bits *)
-      sign_extend_32 dbg contents
+      sign_extend ~bits:32 contents dbg
     | Cop (Calloc _, [hdr; ops; contents], _dbg)
       when alloc_matches_boxed_int bi ~hdr ~ops ->
       contents
@@ -2199,7 +2179,7 @@ let unbox_int dbg bi =
     | cmm -> default cmm)
 
 let make_unsigned_int bi arg dbg =
-  if bi = Primitive.Unboxed_int32 then zero_extend_32 dbg arg else arg
+  if bi = Primitive.Unboxed_int32 then zero_extend ~bits:32 arg dbg else arg
 
 let unaligned_load_16 ptr idx dbg =
   if Arch.allow_unaligned_access
@@ -4346,7 +4326,7 @@ let make_unboxed_int32_array_payload dbg unboxed_int32_list =
           ( Cor,
             [ (* [a] is sign-extended by default. We need to change it to be
                  zero-extended for the `or` operation to be correct. *)
-              zero_extend_32 dbg a;
+              zero_extend ~bits:32 a dbg;
               Cop (Clsl, [b; Cconst_int (32, dbg)], dbg) ],
             dbg )
       in
@@ -4490,3 +4470,80 @@ let reperform ~dbg ~eff ~cont ~last_fiber =
       dbg )
 
 let poll ~dbg = return_unit dbg (Cop (Cpoll, [], dbg))
+
+module Static_cast = struct
+  (** A signed integer of machine width *)
+  type word = [`Word]
+
+  type float =
+    [ `Float
+    | `Float32 ]
+
+  type machine =
+    [ word
+    | float ]
+
+  (** A signed integer of [n] bits, always stored sign-extended *)
+  type bits = [`Bits of int]
+
+  (** A tagged immediate *)
+  type tagged = [`Tagged of word]
+
+  type untagged_int =
+    [ word
+    | bits ]
+
+  type standard_int =
+    [ bits
+    | tagged ]
+
+  type untagged =
+    [ untagged_int
+    | float ]
+
+  type t =
+    [ tagged
+    | untagged ]
+
+  let equal x y = Stdlib.( = ) (x :> t) (y :> t)
+
+  let[@inline] static_cast dbg =
+    let ( >> ) f g arg = g (f arg) in
+    let conv_machine ~(src : [< machine]) ~(dst : [< machine]) =
+      match dst, src with
+      | `Float, `Float | `Float32, `Float32 | `Word, `Word -> fun arg -> arg
+      | `Word, `Float -> int_of_float ~dbg
+      | `Word, `Float32 -> int_of_float32 ~dbg
+      | `Float32, `Float -> float32_of_float ~dbg
+      | `Float32, `Word -> float32_of_int ~dbg
+      | `Float, `Float32 -> float_of_float32 ~dbg
+      | `Float, `Word -> float_of_int ~dbg
+    in
+    let conv_int ~src ~dst arg =
+      if src <= dst then arg else sign_extend ~bits:dst arg dbg
+    in
+    let conv_untagged ~(src : [< untagged]) ~(dst : [< untagged]) =
+      match src, dst with
+      | (#machine as src), (#machine as dst) -> conv_machine ~src ~dst
+      | `Bits src, (#machine as dst) ->
+        conv_int ~src ~dst:arch_bits >> conv_machine ~src:`Word ~dst
+      | (#machine as src), `Bits dst ->
+        conv_machine ~src ~dst:`Word >> conv_int ~src:arch_bits ~dst
+      | `Bits src, `Bits dst -> conv_int ~src ~dst
+    in
+    let tag_int arg = tag_int arg dbg in
+    let untag_int arg = untag_int arg dbg in
+    let id x = x in
+    fun (src : [< t]) (dst : [< t]) ->
+      if equal src dst
+      then id
+      else
+        match src, dst with
+        | `Tagged `Word, `Tagged `Word -> id
+        | (#untagged as src), `Tagged dst -> conv_untagged ~src ~dst >> tag_int
+        | `Tagged src, (#untagged as dst) ->
+          untag_int >> conv_untagged ~src ~dst
+        | (#untagged as src), (#untagged as dst) -> conv_untagged ~src ~dst
+end
+
+let[@inline] static_cast ~src ~dst e dbg = Static_cast.static_cast dbg src dst e