updated cmm_helpers interface to be more amenable to adding other integer sizes

Author: jvanburen

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 ~dbg (one_arg name args))
   | "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 = Arch.size_int * 8
+
 type arity =
   { function_kind : Lambda.function_kind;
     params_layout : Lambda.layout list;
@@ -749,35 +751,46 @@ let mod_int c1 c2 is_safe dbg =
 (* Division or modulo on boxed integers. The overflow case min_int / -1 can
    occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
 
-let is_different_from x = function
-  | Cconst_int (n, _) -> n <> x
-  | Cconst_natint (n, _) -> n <> Nativeint.of_int x
-  | _ -> false
+(* Division or modulo on boxed integers. The overflow case min_int / -1 can
+   occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
 
-let safe_divmod_bi mkop kind is_safe mkm1 c1 c2 bi dbg =
-  bind "divisor" c2 (fun c2 ->
-      bind "dividend" c1 (fun c1 ->
-          let c = mkop c1 c2 is_safe dbg in
-          if Arch.division_crashes_on_overflow
-             && bi <> Primitive.Unboxed_int32
-             && not (is_different_from (-1) c2)
-          then
-            Cifthenelse
-              ( Cop (Ccmpi Cne, [c2; Cconst_int (-1, dbg)], dbg),
-                dbg,
-                c,
-                dbg,
-                mkm1 c1 dbg,
-                dbg,
-                kind )
-          else c))
+let safe_divmod_bi mkop mkm1 ?(dividend_cannot_be_min_int = false) is_safe
+    dividend divisor dbg =
+  let is_different_from x = function
+    | Cconst_int (n, _) -> Nativeint.of_int n <> x
+    | Cconst_natint (n, _) -> n <> x
+    | _ -> false
+  in
+  bind "divisor" divisor (fun divisor ->
+      bind "dividend" dividend (fun dividend ->
+          let c = mkop dividend divisor is_safe dbg in
+          if not Arch.division_crashes_on_overflow
+          then c
+          else
+            let dividend_cannot_be_min_int =
+              dividend_cannot_be_min_int
+              || is_different_from Nativeint.min_int dividend
+            in
+            let divisor_cannot_be_negative_one =
+              is_different_from (-1n) divisor
+            in
+            if dividend_cannot_be_min_int || divisor_cannot_be_negative_one
+            then c
+            else
+              Cifthenelse
+                ( Cop (Ccmpi Cne, [divisor; Cconst_int (-1, dbg)], dbg),
+                  dbg,
+                  c,
+                  dbg,
+                  mkm1 dividend dbg,
+                  dbg,
+                  Any )))
 
-let safe_div_bi is_safe =
-  safe_divmod_bi div_int Any is_safe (fun c1 dbg ->
+let safe_div_bi =
+  safe_divmod_bi div_int (fun c1 dbg ->
       Cop (Csubi, [Cconst_int (0, dbg); c1], dbg))
 
-let safe_mod_bi is_safe =
-  safe_divmod_bi mod_int Any is_safe (fun _ dbg -> Cconst_int (0, dbg))
+let safe_mod_bi = safe_divmod_bi mod_int (fun _ dbg -> Cconst_int (0, dbg))
 
 (* Bool *)
 
@@ -1500,6 +1513,37 @@ let setfield_unboxed_vec128 arr ~index_in_words newval dbg =
          [field_address; newval],
          dbg ))
 
+let get_field_unboxed ~dbg memory_chunk mutability block ~index_in_words =
+  match (memory_chunk : memory_chunk) with
+  | Single { reg = Float32 } ->
+    get_field_unboxed_float32 mutability ~block ~index:index_in_words dbg
+  | Double ->
+    unboxed_float_array_ref mutability ~block ~index:index_in_words dbg
+  | Onetwentyeight_unaligned | Onetwentyeight_aligned ->
+    get_field_unboxed_vec128 mutability ~block ~index_in_words dbg
+  | Thirtytwo_signed ->
+    get_field_unboxed_int32 mutability ~block ~index:index_in_words dbg
+  | Word_int ->
+    get_field_unboxed_int64_or_nativeint mutability ~block ~index:index_in_words
+      dbg
+  | Word_val ->
+    Misc.fatal_error "cannot use get_field_unboxed with a heap block"
+  | _ -> Misc.fatal_error "get_field_unboxed: unexpected memory chunk"
+
+let set_field_unboxed ~dbg memory_chunk block ~index_in_words newval =
+  match (memory_chunk : memory_chunk) with
+  | Single { reg = Float32 } ->
+    setfield_unboxed_float32 block index_in_words newval dbg
+  | Double -> float_array_set block index_in_words newval dbg
+  | Onetwentyeight_unaligned | Onetwentyeight_aligned ->
+    setfield_unboxed_vec128 block ~index_in_words newval dbg
+  | Thirtytwo_signed -> setfield_unboxed_int32 block index_in_words newval dbg
+  | Word_int ->
+    setfield_unboxed_int64_or_nativeint block index_in_words newval dbg
+  | Word_val ->
+    Misc.fatal_error "cannot use set_field_unboxed with a heap block"
+  | _ -> Misc.fatal_error "set_field_unboxed : unexpected memory chunk"
+
 (* String length *)
 
 (* Length of string block *)
@@ -2010,6 +2054,40 @@ let zero_extend_63 dbg e =
   let e = low_63 dbg e in
   Cop (Cand, [e; natint_const_untagged dbg 0x7FFF_FFFF_FFFF_FFFFn], dbg)
 
+let zero_extend ~bits ~dbg e =
+  assert (0 < bits && bits <= arch_bits);
+  if bits = arch_bits
+  then e
+  else
+    match bits with
+    | 63 -> zero_extend_63 dbg e
+    | 32 -> zero_extend_32 dbg e
+    | bits -> Misc.fatal_errorf "zero_extend not implemented for %d bits" bits
+
+let sign_extend ~bits ~dbg e =
+  assert (0 < bits && bits <= arch_bits);
+  if bits = arch_bits
+  then e
+  else
+    match bits with
+    | 63 -> sign_extend_63 dbg e
+    | 32 -> sign_extend_32 dbg e
+    | bits -> Misc.fatal_errorf "sign_extend not implemented for %d bits" bits
+
+let low_bits ~bits ~(dbg : Debuginfo.t) e =
+  assert (0 < bits && bits <= arch_bits);
+  if bits = arch_bits
+  then e
+  else
+    match bits with
+    | 63 -> low_63 dbg e
+    | 32 -> low_32 dbg e
+    | bits -> Misc.fatal_errorf "low_bits not implemented for %d bits" bits
+
+let ignore_low_bits ~bits ~dbg:(_ : Debuginfo.t) e =
+  assert (0 <= bits && bits <= arch_bits);
+  if bits = 0 then e else ignore_low_bit_int e
+
 let and_int e1 e2 dbg =
   let is_mask32 = function
     | Cconst_natint (0xFFFF_FFFFn, _) -> true
@@ -3504,15 +3582,6 @@ let xor_int_caml arg1 arg2 dbg =
         Cconst_int (1, dbg) ],
       dbg )
 
-let lsl_int_caml arg1 arg2 dbg =
-  incr_int (lsl_int (decr_int arg1 dbg) (untag_int arg2 dbg) dbg) dbg
-
-let lsr_int_caml arg1 arg2 dbg =
-  Cop (Cor, [lsr_int arg1 (untag_int arg2 dbg) dbg; Cconst_int (1, dbg)], dbg)
-
-let asr_int_caml arg1 arg2 dbg =
-  Cop (Cor, [asr_int arg1 (untag_int arg2 dbg) dbg; Cconst_int (1, dbg)], dbg)
-
 type ternary_primitive =
   expression -> expression -> expression -> Debuginfo.t -> expression
 

backend/cmm_helpers.mli

@@ -15,6 +15,8 @@
 
 open Cmm
 
+val arch_bits : int
+
 type arity =
   { function_kind : Lambda.function_kind;
     params_layout : Lambda.layout list;
@@ -65,9 +67,6 @@ val alloc_infix_header : int -> Debuginfo.t -> expression
 (** Make an integer constant from the given integer (tags the integer) *)
 val int_const : Debuginfo.t -> int -> expression
 
-(** Simplify the given expression knowing its last bit will be irrelevant *)
-val ignore_low_bit_int : expression -> expression
-
 (** Arithmetical operations on integers *)
 val add_int : expression -> expression -> Debuginfo.t -> expression
 
@@ -103,18 +102,18 @@ val untag_int : expression -> Debuginfo.t -> expression
 
 (** Specific division operations for boxed integers *)
 val safe_div_bi :
+  ?dividend_cannot_be_min_int:bool ->
   Lambda.is_safe ->
   expression ->
   expression ->
-  Primitive.unboxed_integer ->
   Debuginfo.t ->
   expression
 
 val safe_mod_bi :
+  ?dividend_cannot_be_min_int:bool ->
   Lambda.is_safe ->
   expression ->
   expression ->
-  Primitive.unboxed_integer ->
   Debuginfo.t ->
   expression
 
@@ -381,28 +380,18 @@ val bigarray_elt_size_in_bytes : Lambda.bigarray_kind -> int
     bigarray. *)
 val bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk
 
-(** Operations on 32-bit integers *)
-
-(** [low_32 _ x] is a value which agrees with x on at least the low 32 bits *)
-val low_32 : Debuginfo.t -> expression -> expression
+(** Operations on n-bit integers *)
 
-(** Sign extend from 32 bits to the word size *)
-val sign_extend_32 : Debuginfo.t -> expression -> expression
+(** Simplify the given expression knowing low [bits] bits will be irrelevant *)
+val ignore_low_bits : bits:int -> dbg:Debuginfo.t -> expression -> expression
 
-(** Zero extend from 32 bits to the word size *)
-val zero_extend_32 : Debuginfo.t -> expression -> expression
+(** Simplify the given expression knowing that bits other than the low [bits] bits will be
+    irrelevant *)
+val low_bits : bits:int -> dbg:Debuginfo.t -> expression -> expression
 
-(** Operations on 63-bit integers. These may only be used for compilation to
-    64-bit targets. *)
+val sign_extend : bits:int -> dbg:Debuginfo.t -> expression -> expression
 
-(** [low_63 _ x] is a value which agrees with x on at least the low 63 bits *)
-val low_63 : Debuginfo.t -> expression -> expression
-
-(** Sign extend from 63 bits to the word size *)
-val sign_extend_63 : Debuginfo.t -> expression -> expression
-
-(** Zero extend from 63 bits to the word size *)
-val zero_extend_63 : Debuginfo.t -> expression -> expression
+val zero_extend : bits:int -> dbg:Debuginfo.t -> expression -> expression
 
 (** Box a given integer, without sharing of constants *)
 val box_int_gen :
@@ -498,12 +487,6 @@ val or_int_caml : binary_primitive
 
 val xor_int_caml : binary_primitive
 
-val lsl_int_caml : binary_primitive
-
-val lsr_int_caml : binary_primitive
-
-val asr_int_caml : binary_primitive
-
 type ternary_primitive =
   expression -> expression -> expression -> Debuginfo.t -> expression
 
@@ -719,13 +702,14 @@ val create_ccatch :
   body:Cmm.expression ->
   Cmm.expression
 
+(** Shift operations. take as first argument a tagged caml integer, and as
+    second argument an untagged machine intger which is the amount to shift the
+    first argument by. *)
+
 val lsl_int_caml_raw : dbg:Debuginfo.t -> expression -> expression -> expression
 
 val lsr_int_caml_raw : dbg:Debuginfo.t -> expression -> expression -> expression
 
-(** Shift operations. take as first argument a tagged caml integer, and as
-    second argument an untagged machine intger which is the amount to shift the
-    first argument by. *)
 val asr_int_caml_raw : dbg:Debuginfo.t -> expression -> expression -> expression
 
 (** Reinterpret cast functions *)
@@ -1198,57 +1182,26 @@ val unboxed_int64_or_nativeint_array_set :
   expression
 
 (** {2 Getters and setters for unboxed int and float32 fields of mixed
-    blocks} *)
-
-(** The argument structure for getters is parallel to [get_field_computed]. *)
-
-val get_field_unboxed_int32 :
-  Asttypes.mutable_flag ->
-  block:expression ->
-  index:expression ->
-  Debuginfo.t ->
-  expression
-
-val get_field_unboxed_float32 :
-  Asttypes.mutable_flag ->
-  block:expression ->
-  index:expression ->
-  Debuginfo.t ->
-  expression
+    blocks} [immediate_or_pointer] is not needed as the layout is implied from the name,
+    and [initialization_or_assignment] is not needed as unboxed ints can always be
+    assigned without caml_modify (etc.). *)
 
-val get_field_unboxed_vec128 :
+val get_field_unboxed :
+  dbg:Debuginfo.t ->
+  memory_chunk ->
   Asttypes.mutable_flag ->
-  block:expression ->
+  expression ->
   index_in_words:expression ->
-  Debuginfo.t ->
   expression
 
-val get_field_unboxed_int64_or_nativeint :
-  Asttypes.mutable_flag ->
-  block:expression ->
-  index:expression ->
-  Debuginfo.t ->
-  expression
-
-(** The argument structure for setters is parallel to [setfield_computed].
-   [immediate_or_pointer] is not needed as the layout is implied from the name,
-   and [initialization_or_assignment] is not needed as unboxed ints can always be
-   assigned without caml_modify (etc.).
- *)
-
-val setfield_unboxed_int32 : ternary_primitive
-
-val setfield_unboxed_float32 : ternary_primitive
-
-val setfield_unboxed_vec128 :
+val set_field_unboxed :
+  dbg:Debuginfo.t ->
+  memory_chunk ->
   expression ->
   index_in_words:expression ->
   expression ->
-  Debuginfo.t ->
   expression
 
-val setfield_unboxed_int64_or_nativeint : ternary_primitive
-
 val dls_get : dbg:Debuginfo.t -> expression
 
 val poll : dbg:Debuginfo.t -> expression

middle_end/flambda2/to_cmm/to_cmm_expr.ml

@@ -115,7 +115,7 @@ let translate_external_call env res ~free_vars apply ~callee_simple ~args
      not. There is no need to wrap other return arities. *)
   let maybe_sign_extend kind dbg cmm =
     match Flambda_kind.With_subkind.kind kind with
-    | Naked_number Naked_int32 -> C.sign_extend_32 dbg cmm
+    | Naked_number Naked_int32 -> C.sign_extend ~bits:32 ~dbg cmm
     | Naked_number
         ( Naked_float | Naked_immediate | Naked_int64 | Naked_nativeint
         | Naked_vec128 | Naked_float32 )