From 6f73bf95eefec000a546fd757a462f6e12ea9116 Mon Sep 17 00:00:00 2001 From: Jacob Van Buren Date: Fri, 27 Dec 2024 13:28:30 -0500 Subject: [PATCH] expanded cmm_helpers numeric types to handle more numeric types --- backend/cmm_helpers.ml | 215 +++++++++++----- backend/cmm_helpers.mli | 68 +++-- .../flambda2/to_cmm/to_cmm_primitive.ml | 238 +++++++++++------- tools/dune | 2 +- 4 files changed, 345 insertions(+), 178 deletions(-) diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 0a5971b1fbf..5cc3b7246a1 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -443,6 +443,9 @@ let tag_int i dbg = | Cop (Casr, [c; Cconst_int (n, _)], _) when n > 0 -> Cop (Cor, [asr_int c (Cconst_int (n - 1, dbg)) dbg; Cconst_int (1, dbg)], dbg) + | Cop (Clsr, [c; Cconst_int (n, _)], _) when n > 0 -> + Cop + (Cor, [lsr_int c (Cconst_int (n - 1, dbg)) dbg; Cconst_int (1, dbg)], dbg) | c -> incr_int (lsl_int c (Cconst_int (1, dbg)) dbg) dbg let untag_int i dbg = @@ -4345,73 +4348,133 @@ module Numeric = struct | Float64, Float32 -> float32_of_float ~dbg exp end - module Make_integer (I : sig - val max_bits : int - end) = - struct - (** An integer that fits into a general-purpose register. It is canonically stored in - twos-complement representation, in the lower [bits] bits of its container (whether - that be memory or a register), and is sign- or zero-extended as needed, according - to [signed]. *) + module Signedness = struct type t = - { bits : int; - signed : bool - } + | Signed + | Unsigned - let[@inline] create_exn ~bits ~signed = - assert (0 < bits && bits <= I.max_bits); - { bits; signed } + let equal (x : t) (y : t) = x = y - let[@inline] static_cast ~dbg ~src ~dst exp = - let is_promotable = - if src.signed - then dst.signed && src.bits <= dst.bits - else src.bits < dst.bits - in - if is_promotable - then exp - else if dst.signed - then sign_extend ~bits:dst.bits exp dbg - else zero_extend ~bits:dst.bits exp dbg + let print ppf t = + match t with + | Signed -> Format.pp_print_string ppf "signed" + | Unsigned -> Format.pp_print_string ppf "unsigned" + end + + module Bit_width_and_signedness : sig + (** An integer with signedness [signedness t] that fits into a general-purpose + register. It is canonically stored in twos-complement representation, in the lower + [bits] bits of its container (whether that be memory or a register), and is sign- + or zero-extended to fill the entire container. *) + type t [@@immediate] + + val create_exn : bit_width:int -> signedness:Signedness.t -> t + + val bit_width : t -> int + + val signedness : t -> Signedness.t - let[@inline] bits t = t.bits + val equal : t -> t -> bool + end = struct + (* [signedness t] is stored in the low bit of [t], and [bit_width t] is + stored in the remaining high bits of [t]. We use this encoding to fit [t] + into an immediate value *) + type t = { bit_width_and_signedness : int } [@@unboxed] - let[@inline] is_signed t = t.signed + let[@inline] equal { bit_width_and_signedness = x } + { bit_width_and_signedness = y } = + Int.equal x y - let[@inline] signed t = { t with signed = true } + let[@inline] bit_width { bit_width_and_signedness } = + bit_width_and_signedness lsr 1 - let[@inline] unsigned t = { t with signed = false } + let[@inline] signedness { bit_width_and_signedness } = + match (Obj.magic (bit_width_and_signedness land 1) : Signedness.t) with + | (Signed | Unsigned) as signedness -> + (* If [Signedness.t] ever changes, adjust the representation of [t] + accordingly *) + signedness - let[@inline] with_signedness t ~signed = { t with signed } + (** This type annotation proves that [int_of_signedness] is valid *) + type signedness_is_immediate = Signedness.t [@@immediate] + + external int_of_signedness : signedness_is_immediate -> int = "%identity" + + let[@inline] create_exn ~bit_width ~signedness = + assert (0 < bit_width && bit_width <= arch_bits); + { bit_width_and_signedness = + (bit_width lsl 1) lor int_of_signedness signedness + } + end + + module Integral_type = struct + include Bit_width_and_signedness + + (** Determines whether [dst] can represent every value of [src], preserving sign *) + let[@inline] is_promotable ~src ~dst = + match signedness src, signedness dst with + | Signed, Signed | Unsigned, Unsigned -> bit_width src <= bit_width dst + | Unsigned, Signed -> bit_width src < bit_width dst + | Signed, Unsigned -> false + + let[@inline] static_cast ~dbg ~src ~dst exp = + if is_promotable ~src ~dst + then + (* since the values are already stored sign- or zero-extended, this is a + no-op. *) + exp + else + match signedness dst with + | Signed -> sign_extend ~bits:(bit_width dst) exp dbg + | Unsigned -> zero_extend ~bits:(bit_width dst) exp dbg + + let[@inline] with_signedness t ~signedness = + create_exn ~bit_width:(bit_width t) ~signedness + + let[@inline] signed t = with_signedness t ~signedness:Signed + + let[@inline] unsigned t = with_signedness t ~signedness:Unsigned end - [@@inline] module Integer = struct - include Make_integer (struct - let max_bits = arch_bits - end) + include Integral_type - let nativeint = create_exn ~bits:arch_bits ~signed:true + let print ppf t = + Format.fprintf ppf "%a int%d" Signedness.print (signedness t) + (bit_width t) + + let nativeint = create_exn ~bit_width:arch_bits ~signedness:Signed end (** An {!Integer.t} but with the additional stipulation that its container must reserve its lowest bit to be 1. The [bits] field does not include this bit. *) module Tagged_integer = struct - include Make_integer (struct - let max_bits = arch_bits - 1 - end) + include Integral_type - let[@inline] create_exn ~bits_excluding_tag_bit:bits ~signed = - create_exn ~bits ~signed + let[@inline] create_exn ~bit_width_including_tag_bit:bit_width ~signedness = + assert (bit_width > 1); + create_exn ~bit_width ~signedness let immediate = - create_exn ~bits_excluding_tag_bit:(arch_bits - 1) ~signed:true + create_exn ~bit_width_including_tag_bit:arch_bits ~signedness:Signed + + let[@inline] bit_width_including_tag_bit t = bit_width t - let[@inline] untagged { bits; signed } : Integer.t = { bits; signed } + let[@inline] bit_width_excluding_tag_bit t = bit_width t - 1 - let[@inline] bits_excluding_tag_bit t = bits t + let[@inline] untagged t = + Integer.create_exn + ~bit_width:(bit_width_excluding_tag_bit t) + ~signedness:(signedness t) - let[@inline] bits_including_tag_bit t = bits t + 1 + let[@inline] untag ~dbg t exp = + match signedness t with + | Signed -> asr_const exp 1 dbg + | Unsigned -> lsr_const exp 1 dbg + + let print ppf t = + Format.fprintf ppf "tagged %a int%d" Signedness.print (signedness t) + (bit_width_excluding_tag_bit t) end module Integral = struct @@ -4421,7 +4484,14 @@ module Numeric = struct let nativeint = Untagged Integer.nativeint - let[@inline] static_cast ~dbg ~src ~dst exp = + let[@inline] is_promotable ~src ~dst = + let[@inline] untagged = function + | Untagged t -> t + | Tagged t -> Tagged_integer.untagged t + in + Integer.is_promotable ~src:(untagged src) ~dst:(untagged dst) + + let static_cast ~dbg ~src ~dst exp = match src, dst with | Untagged src, Untagged dst -> Integer.static_cast ~dbg ~src ~dst exp | Tagged src, Tagged dst -> Tagged_integer.static_cast ~dbg ~src ~dst exp @@ -4433,31 +4503,60 @@ module Numeric = struct Integer.static_cast ~dbg ~src:(Tagged_integer.untagged src) ~dst - (if src.signed then asr_const exp 1 dbg else lsr_const exp 1 dbg) + (Tagged_integer.untag ~dbg src exp) + + let signedness = function + | Untagged t -> Integer.signedness t + | Tagged t -> Tagged_integer.signedness t + + let with_signedness t ~signedness = + match t with + | Untagged t -> Untagged (Integer.with_signedness t ~signedness) + | Tagged t -> Tagged (Tagged_integer.with_signedness t ~signedness) - let signed = function - | Untagged untagged -> Untagged (Integer.signed untagged) - | Tagged tagged -> Tagged (Tagged_integer.signed tagged) + let[@inline] signed t = with_signedness t ~signedness:Signed - let unsigned = function - | Untagged untagged -> Untagged (Integer.unsigned untagged) - | Tagged tagged -> Tagged (Tagged_integer.unsigned tagged) + let[@inline] unsigned t = with_signedness t ~signedness:Signed + + let[@inline] equal x y = + match x, y with + | Untagged x, Untagged y -> Integer.equal x y + | Untagged _, _ -> false + | Tagged x, Tagged y -> Tagged_integer.equal x y + | Tagged _, _ -> false + + let print ppf t = + match t with + | Untagged untagged -> Integer.print ppf untagged + | Tagged tagged -> Tagged_integer.print ppf tagged end type t = | Integral of Integral.t | Float of Float_width.t - let[@inline] static_cast ~dbg ~src ~dst exp = + let static_cast ~dbg ~src ~dst exp = match src, dst with | Integral src, Integral dst -> Integral.static_cast ~dbg ~src ~dst exp | Float src, Float dst -> Float_width.static_cast ~dbg ~src ~dst exp - | Float src, Integral dst -> - unary (Cstatic_cast (Int_of_float src)) exp ~dbg - |> Integral.static_cast ~dbg ~src:Integral.nativeint ~dst | Integral src, Float dst -> - Integral.static_cast ~dbg ~src ~dst:Integral.nativeint exp - |> unary (Cstatic_cast (Int_of_float dst)) ~dbg + let float_of_int_arg = Integral.nativeint in + if not (Integral.is_promotable ~src ~dst:float_of_int_arg) + then + Misc.fatal_errorf "static_cast: casting %a to float is not implemented" + Integral.print src + else + unary (Cstatic_cast (Float_of_int dst)) ~dbg + (Integral.static_cast exp ~dbg ~src ~dst:float_of_int_arg) + | Float src, Integral dst -> ( + match Integral.signedness dst with + | Unsigned -> + Misc.fatal_errorf + "static_cast: casting floats to unsigned values is undefined" + | Signed -> + (* we can truncate, but we don't want to promote *) + Integral.static_cast ~dbg ~src:Integral.nativeint ~dst + (unary (Cstatic_cast (Int_of_float src)) exp ~dbg)) module Untagged = struct type numeric = t diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index bfca81ad2d3..2766eead5ae 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -1204,6 +1204,7 @@ module Numeric : sig type 'a static_cast := dbg:Debuginfo.t -> src:'a -> dst:'a -> expression -> expression + (** An IEEE 754 floating-point number *) module Float_width : sig type t = Cmm.float_width = | Float64 @@ -1212,46 +1213,69 @@ module Numeric : sig val static_cast : t static_cast end - module Integer : sig - type t + module Signedness : sig + type t = + | Signed + | Unsigned - val create_exn : bits:int -> signed:bool -> t + val equal : t -> t -> bool - val nativeint : t + val print : Format.formatter -> t -> unit + end - val static_cast : t static_cast + module type Integral_ops := sig + type t + + val print : Format.formatter -> t -> unit - val bits : t -> int + val equal : t -> t -> bool - val is_signed : t -> bool + val signedness : t -> Signedness.t + + val with_signedness : t -> signedness:Signedness.t -> t val signed : t -> t val unsigned : t -> t - val with_signedness : t -> signed:bool -> t + val is_promotable : src:t -> dst:t -> bool + + val static_cast : t static_cast end - module Tagged_integer : sig - type t + (** An integer that fits into a general-purpose register. It is canonically stored in + twos-complement representation, in the lower [bits] bits of its container (whether + that be memory or a register), and is sign- or zero-extended as needed, according + to [signed]. *) + module Integer : sig + type t [@@immediate] - val create_exn : bits_excluding_tag_bit:int -> signed:bool -> t + val nativeint : t - val immediate : t + val create_exn : bit_width:int -> signedness:Signedness.t -> t - val untagged : t -> Integer.t + val bit_width : t -> int - val static_cast : t static_cast + include Integral_ops with type t := t + end - val bits_excluding_tag_bit : t -> int + (** An {!Integer.t} but with the additional stipulation that its lowest bit is always + set to 1 and is not considered in mathematical operations on the numbers. *) + module Tagged_integer : sig + type t [@@immediate] - val bits_including_tag_bit : t -> int + val immediate : t - val signed : t -> t + val create_exn : + bit_width_including_tag_bit:int -> signedness:Signedness.t -> t - val unsigned : t -> t + val bit_width_excluding_tag_bit : t -> int + + val bit_width_including_tag_bit : t -> int + + val untagged : t -> Integer.t - val with_signedness : t -> signed:bool -> t + include Integral_ops with type t := t end module Integral : sig @@ -1263,14 +1287,12 @@ module Numeric : sig val static_cast : t static_cast - val signed : t -> t - - val unsigned : t -> t + include Integral_ops with type t := t end type t = | Integral of Integral.t - | Float of float_width + | Float of Float_width.t val static_cast : t static_cast diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 882d9b6a61e..78c08fb127b 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -529,23 +529,32 @@ let dead_slots_msg dbg function_slots value_slots = (* Arithmetic primitives *) let integral_of_standard_int : K.Standard_int.t -> C.Numeric.Integral.t - = function - | Naked_int8 -> Untagged (C.Numeric.Integer.create_exn ~bits:8 ~signed:true) - | Naked_int16 -> Untagged (C.Numeric.Integer.create_exn ~bits:16 ~signed:true) - | Naked_int32 -> Untagged (C.Numeric.Integer.create_exn ~bits:32 ~signed:true) - | Naked_int64 -> Untagged (C.Numeric.Integer.create_exn ~bits:64 ~signed:true) + = + let[@inline] untagged_int bit_width : C.Numeric.Integral.t = + Untagged (C.Numeric.Integer.create_exn ~bit_width ~signedness:Signed) + in + function + | Naked_int8 -> untagged_int 8 + | Naked_int16 -> untagged_int 16 + | Naked_int32 -> untagged_int 32 + | Naked_int64 -> untagged_int 64 | Naked_nativeint -> Untagged C.Numeric.Integer.nativeint | Naked_immediate -> Untagged (C.Numeric.Tagged_integer.(untagged immediate)) | Tagged_immediate -> Tagged C.Numeric.Tagged_integer.immediate -let numeric_of_standard_int_or_float : - K.Standard_int_or_float.t -> C.Numeric.t = function - | Naked_int8 -> Integral (Untagged (C.Numeric.Integer.create_exn ~bits:8 ~signed:true)) - | Naked_int16 -> Integral (Untagged (C.Numeric.Integer.create_exn ~bits:16 ~signed:true)) - | Naked_int32 -> Integral (Untagged (C.Numeric.Integer.create_exn ~bits:32 ~signed:true)) - | Naked_int64 -> Integral (Untagged (C.Numeric.Integer.create_exn ~bits:64 ~signed:true)) +let numeric_of_standard_int_or_float : K.Standard_int_or_float.t -> C.Numeric.t = + let[@inline] untagged_int bit_width : C.Numeric.t = + Integral (Untagged (C.Numeric.Integer.create_exn + ~bit_width ~signedness:Signed)) + in + function + | Naked_int8 -> untagged_int 8 + | Naked_int16 -> untagged_int 16 + | Naked_int32 -> untagged_int 32 + | Naked_int64 -> untagged_int 64 | Naked_nativeint -> Integral (Untagged C.Numeric.Integer.nativeint) - | Naked_immediate -> Integral (Untagged (C.Numeric.Tagged_integer.(untagged immediate))) + | Naked_immediate -> + Integral (Untagged (C.Numeric.Tagged_integer.(untagged immediate))) | Tagged_immediate -> Integral (Tagged C.Numeric.Tagged_integer.immediate) | Naked_float32 -> Float Float32 | Naked_float -> Float Float64 @@ -565,7 +574,7 @@ let unary_int_arith_primitive _env dbg kind op arg = C.Numeric.Integer.static_cast arg ~src ~dst:C.Numeric.Integer.nativeint ~dbg |> (fun arg -> - let bits = C.Numeric.Integer.bits src in + let bits = C.Numeric.Integer.bit_width src in (C.sub_int (C.int ~dbg 0) (C.low_bits ~bits arg dbg) dbg)) |> C.Numeric.Integer.static_cast ~src:C.Numeric.Integer.nativeint ~dst:src ~dbg) @@ -605,8 +614,8 @@ let arithmetic_conversion dbg src dst arg = let extra = match src, dst with | Integral (Tagged src), Integral (Untagged dst) - when C.Numeric.Tagged_integer.bits_excluding_tag_bit src - = C.Numeric.Integer.bits dst + when C.Numeric.Integer.equal (C.Numeric.Tagged_integer.untagged src) + dst -> Some (Env.Untag arg) | (Integral (Tagged _ | Untagged _) | Float (Float32 | Float64)), (Integral (Tagged _ | Untagged _) | Float (Float32 | Float64)) -> None @@ -620,104 +629,141 @@ let phys_equal _env dbg op x y = | Neq -> C.neq ~dbg x y let binary_int_arith_primitive _env dbg (kind : K.Standard_int.t) - (op : P.binary_int_arith_op) x y = + (op : P.binary_int_arith_op) x y = let kind = integral_of_standard_int kind in - let[@inline] wrap ~can_simplify_operands f = - (* We cast the operands to the width that the operator expects, apply the operator, - and cast the result back. *) - let native : C.Numeric.Integral.t = + let[@inline] wrap f = + (* We cast the operands to the width that the operator expects, apply the + operator, and cast the result back. *) + let operator_type : C.Numeric.Integral.t = match kind with | Untagged _ -> Untagged (C.Numeric.Integer.nativeint) | Tagged _ -> Tagged (C.Numeric.Tagged_integer.immediate) in + let requires_sign_extended_operands = + match op with + | Div | Mod -> + (* Note that it would be wrong to apply [C.low_bits] to operands + for div and mod. + + Some background: The problem arises in cases like: [(num1 * num2) / + num3]. If an overflow occurs in the multiplication, then we must deal + with it by sign-extending before the division. Whereas [ (num1 * + num2) * num3 ] can delay the sign-extension until the very end, even + in the case of overflow in the middle. So in a way, div and mod are + regular functions, while all the others are special as they can delay + overflow handling. + + Cmm only has [Arch.size_int]-width virtual registers, so we must + always do operations on values of that size. (If we had smaller + virtual registers, we could use them in Cmm without sign-extension + and let the backend insert sign-extensions if it doesn't support + operations on n-bit physical registers. There was a prototype + developed of this but it was quite complicated and didn't get + merged.) *) + true + | Add | Sub | Mul -> + (* https://en.wikipedia.org/wiki/Modular_arithmetic - these operations + are compatible with modular arithmetic *) + false + | And | Or | Xor -> + (* bitwise operations are clearly compatible *) + false + in let[@inline] prepare_operand operand = - let operand = C.Numeric.Integral.static_cast ~dbg ~src:kind ~dst:native operand in - if not can_simplify_operands then operand else + let operand = + C.Numeric.Integral.static_cast ~dbg ~src:kind ~dst:operator_type operand + in + if requires_sign_extended_operands + then operand + else let bits = match kind with - | Untagged untagged -> C.Numeric.Integer.bits untagged - | Tagged tagged -> C.Numeric.Tagged_integer.bits_including_tag_bit tagged + | Untagged untagged -> C.Numeric.Integer.bit_width untagged + | Tagged tagged -> + C.Numeric.Tagged_integer.bit_width_including_tag_bit tagged in C.low_bits ~bits operand dbg in let x = prepare_operand x in let y = prepare_operand y in let result = f x y dbg in - C.Numeric.Integral.static_cast ~dbg ~src:native ~dst:kind result + C.Numeric.Integral.static_cast ~dbg ~src:operator_type ~dst:kind result (* Operations on integer arguments must return something in the range of their values, hence the [static_cast] here. The [C.low_bits] operations (see above in [prepare_operand]) are used to avoid unnecessary sign-extensions, e.g. when chaining additions together. Also see comment below about [C.low_bits] in the [Div] and [Mod] cases. *) in - (* Note that it would be wrong to apply [C.low_bits] to [x] and/or [y] - for div and mod. [C.safe_div_bi] and [C.safe_mod_bi] require - sign-extended input for both the numerator and denominator. - - Some background: The problem arises in cases like: [(num1 * num2) / num3]. - If an overflow occurs in the multiplication, then we must deal with it by - sign-extending before the division. Whereas [ (num1 * num2) * num3 ] can - delay the sign-extension until the very end, even in the case of overflow - in the middle. So in a way, div and mod are regular functions, while all - the others are special as they can delay overflow handling. - - Cmm only has [Arch.size_int]-width virtual registers, so we must always - do operations on values of that size. (If we had smaller virtual registers, - we could use them in Cmm without sign-extension and let the backend insert - sign-extensions if it doesn't support operations on n-bit physical - registers. There was a prototype developed of this but it was quite - complicated and didn't get merged.) *) + match kind with | Tagged _ -> (match op with - | Add -> wrap C.add_int_caml ~can_simplify_operands:true - | Sub -> wrap C.sub_int_caml ~can_simplify_operands:true - | Mul -> wrap C.mul_int_caml ~can_simplify_operands:true - | Div -> wrap (C.div_int_caml Unsafe) ~can_simplify_operands:false - | Mod -> wrap (C.mod_int_caml Unsafe)~can_simplify_operands:false - | And -> wrap C.and_int_caml ~can_simplify_operands:true - | Or -> wrap C.or_int_caml ~can_simplify_operands:true - | Xor -> wrap C.xor_int_caml ~can_simplify_operands:true) + | Add -> wrap C.add_int_caml + | Sub -> wrap C.sub_int_caml + | Mul -> wrap C.mul_int_caml + | Div -> wrap (C.div_int_caml Unsafe) + | Mod -> wrap (C.mod_int_caml Unsafe) + | And -> wrap C.and_int_caml + | Or -> wrap C.or_int_caml + | Xor -> wrap C.xor_int_caml) | Untagged untagged -> - let dividend_cannot_be_min_int = C.Numeric.Integer.bits untagged < C.arch_bits in + let dividend_cannot_be_min_int = + C.Numeric.Integer.bit_width untagged < C.arch_bits + in (match op with - | Add -> wrap C.add_int ~can_simplify_operands:true - | Sub -> wrap C.sub_int ~can_simplify_operands:true - | Mul -> wrap C.mul_int ~can_simplify_operands:true - | Div -> - wrap (C.safe_div_bi Unsafe ~dividend_cannot_be_min_int) - ~can_simplify_operands:false - | Mod -> - wrap (C.safe_mod_bi Unsafe ~dividend_cannot_be_min_int) - ~can_simplify_operands:false - | And -> wrap C.and_int ~can_simplify_operands:true - | Or -> wrap C.or_int ~can_simplify_operands:true - | Xor -> wrap C.xor_int ~can_simplify_operands:true) - -let binary_int_shift_primitive _env dbg kind op x y = + | Add -> wrap C.add_int + | Sub -> wrap C.sub_int + | Mul -> wrap C.mul_int + | Div -> wrap (C.safe_div_bi Unsafe ~dividend_cannot_be_min_int) + | Mod -> wrap (C.safe_mod_bi Unsafe ~dividend_cannot_be_min_int) + | And -> wrap C.and_int + | Or -> wrap C.or_int + | Xor -> wrap C.xor_int) + +let binary_int_shift_primitive _env dbg kind (op : P.int_shift_op) x y = (* [kind] only applies to [x], the [y] argument is always a bare register-sized integer *) (* See comments on [binary_int_arity_primitive], above, about sign extension and use of [C.low_bits]. *) let kind = integral_of_standard_int kind in - let input, output = - match (op : P.int_shift_op) with - | Lsl -> kind, C.Numeric.Integral.nativeint - | Asr -> C.Numeric.Integral.signed kind, C.Numeric.Integral.signed kind - | Lsr -> C.Numeric.Integral.unsigned kind, C.Numeric.Integral.unsigned kind + let signedness : C.Numeric.Signedness.t = + match op with + | Lsl -> C.Numeric.Integral.signedness kind + | Asr -> C.Numeric.Signedness.Signed + | Lsr -> C.Numeric.Signedness.Unsigned in - let x = C.Numeric.Integral.static_cast x ~src:kind ~dst:input ~dbg in - let shifted = - match (op : P.int_shift_op) with - | Lsl -> C.lsl_int x y dbg - | Asr -> C.asr_int x y dbg - | Lsr -> C.lsr_int x y dbg + let kind_with_signedness_of_operator = + C.Numeric.Integral.with_signedness kind ~signedness + in + let operator_type = + C.Numeric.Integral.(with_signedness nativeint) ~signedness + in + let x = + C.Numeric.Integral.static_cast x ~dbg + ~src:kind + ~dst:kind_with_signedness_of_operator + in + let x = + C.Numeric.Integral.static_cast x ~dbg + ~src:kind_with_signedness_of_operator + ~dst:operator_type + in + let untagged_kind_with_signedness_of_operator : C.Numeric.Integral.t = + Untagged + (match kind_with_signedness_of_operator with + | Tagged x -> C.Numeric.Tagged_integer.untagged x + | Untagged x -> x) + in + let shifted, output = + match op with + | Lsl -> C.lsl_int x y dbg, operator_type + | Asr -> C.asr_int x y dbg, untagged_kind_with_signedness_of_operator + | Lsr -> C.lsr_int x y dbg, untagged_kind_with_signedness_of_operator in C.Numeric.Integral.static_cast shifted ~src:output ~dst:kind ~dbg - let binary_int_comp_primitive _env dbg kind cmp x y = match - static_cast_of_standard_int kind, (cmp : P.signed_or_unsigned P.comparison) + integral_of_standard_int kind, (cmp : P.signed_or_unsigned P.comparison) with (* [x] and [y] are expressions yielding well-formed tagged immediates, that is to say, their least significant bit (LSB) is 1. However when comparing @@ -729,25 +775,25 @@ let binary_int_comp_primitive _env dbg kind cmp x y = See middle_end/flambda2/z3/comparisons.smt2 for a Z3 script to prove this. *) - | `Tagged `Word, Lt Signed -> C.lt ~dbg x (C.ignore_low_bit_int y) - | `Tagged `Word, Le Signed -> C.le ~dbg (C.ignore_low_bit_int x) y - | `Tagged `Word, Gt Signed -> C.gt ~dbg (C.ignore_low_bit_int x) y - | `Tagged `Word, Ge Signed -> C.ge ~dbg x (C.ignore_low_bit_int y) - | `Tagged `Word, Lt Unsigned -> C.ult ~dbg x (C.ignore_low_bit_int y) - | `Tagged `Word, Le Unsigned -> C.ule ~dbg (C.ignore_low_bit_int x) y - | `Tagged `Word, Gt Unsigned -> C.ugt ~dbg (C.ignore_low_bit_int x) y - | `Tagged `Word, Ge Unsigned -> C.uge ~dbg x (C.ignore_low_bit_int y) + | Tagged _, Lt Signed -> C.lt ~dbg x (C.ignore_low_bit_int y) + | Tagged _, Le Signed -> C.le ~dbg (C.ignore_low_bit_int x) y + | Tagged _, Gt Signed -> C.gt ~dbg (C.ignore_low_bit_int x) y + | Tagged _, Ge Signed -> C.ge ~dbg x (C.ignore_low_bit_int y) + | Tagged _, Lt Unsigned -> C.ult ~dbg x (C.ignore_low_bit_int y) + | Tagged _, Le Unsigned -> C.ule ~dbg (C.ignore_low_bit_int x) y + | Tagged _, Gt Unsigned -> C.ugt ~dbg (C.ignore_low_bit_int x) y + | Tagged _, Ge Unsigned -> C.uge ~dbg x (C.ignore_low_bit_int y) (* Naked integers. *) - | `Bits (_ : int), Lt Signed -> C.lt ~dbg x y - | `Bits (_ : int), Le Signed -> C.le ~dbg x y - | `Bits (_ : int), Gt Signed -> C.gt ~dbg x y - | `Bits (_ : int), Ge Signed -> C.ge ~dbg x y - | `Bits (_ : int), Lt Unsigned -> C.ult ~dbg x y - | `Bits (_ : int), Le Unsigned -> C.ule ~dbg x y - | `Bits (_ : int), Gt Unsigned -> C.ugt ~dbg x y - | `Bits (_ : int), Ge Unsigned -> C.uge ~dbg x y - | #C.Static_cast.standard_int, Eq -> C.eq ~dbg x y - | #C.Static_cast.standard_int, Neq -> C.neq ~dbg x y + | Untagged _ , Lt Signed -> C.lt ~dbg x y + | Untagged _ , Le Signed -> C.le ~dbg x y + | Untagged _ , Gt Signed -> C.gt ~dbg x y + | Untagged _ , Ge Signed -> C.ge ~dbg x y + | Untagged _ , Lt Unsigned -> C.ult ~dbg x y + | Untagged _ , Le Unsigned -> C.ule ~dbg x y + | Untagged _ , Gt Unsigned -> C.ugt ~dbg x y + | Untagged _ , Ge Unsigned -> C.uge ~dbg x y + | (Tagged _ | Untagged _), Eq -> C.eq ~dbg x y + | (Tagged _ | Untagged _), Neq -> C.neq ~dbg x y let binary_int_comp_primitive_yielding_int _env dbg _kind (signed : P.signed_or_unsigned) x y = diff --git a/tools/dune b/tools/dune index 2acf28182da..27bd9ff173a 100644 --- a/tools/dune +++ b/tools/dune @@ -154,7 +154,7 @@ (executable (name merge_archives) - (modes native) + (modes native byte) (modules merge_archives) ; FIXME Fix warning 27 (flags