From c0bfcf8f3d7e82597e2ac9be20aa0cf4bae93c65 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 27 Sep 2024 12:23:11 +0200 Subject: [PATCH] separate module --- compiler/lib/flow.mli | 2 +- compiler/lib/stdlib.ml | 131 ------------------------------------- compiler/lib/targetint.ml | 56 ++++++++++++++++ compiler/lib/targetint.mli | 71 ++++++++++++++++++++ 4 files changed, 128 insertions(+), 132 deletions(-) create mode 100644 compiler/lib/targetint.ml create mode 100644 compiler/lib/targetint.mli diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index 09707f1b10..563885e664 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -58,6 +58,6 @@ val the_string_of : Info.t -> Code.prim_arg -> string option val the_native_string_of : Info.t -> Code.prim_arg -> Code.Native_string.t option -val the_int : Info.t -> Code.prim_arg -> Stdlib.Targetint.t option +val the_int : Info.t -> Code.prim_arg -> Targetint.t option val f : ?skip_param:bool -> Code.program -> Code.program * Info.t diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 6017bfd535..699ecf2b21 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -288,137 +288,6 @@ module Nativeint = struct external equal : nativeint -> nativeint -> bool = "%equal" end -module Targetint : sig - type t - - val equal : t -> t -> bool - - val compare : t -> t -> int - - val to_string : t -> string - - val to_int_exn : t -> int - - val to_float : t -> float - - val of_string : string -> t - - val of_float : float -> t - - val of_int_exn : int -> t - - val of_int32_warning_on_overflow : int32 -> t - - val of_nativeint_warning_on_overflow : nativeint -> t - - val of_int_warning_on_overflow : int -> t - - val succ : t -> t - - val add : t -> t -> t - - val sub : t -> t -> t - - val mul : t -> t -> t - - val div : t -> t -> t - - val rem : t -> t -> t - - val logand : t -> t -> t - - val logor : t -> t -> t - - val logxor : t -> t -> t - - val shift_left : t -> int -> t - - val shift_right : t -> int -> t - - val shift_right_logical : t -> int -> t - - val neg : t -> t - - val abs : t -> t - - val ( >= ) : t -> t -> bool - - val ( <= ) : t -> t -> bool - - val ( < ) : t -> t -> bool - - val ( > ) : t -> t -> bool - - val ( = ) : t -> t -> bool - - val ( <> ) : t -> t -> bool - - val is_zero : t -> bool - - val num_bits : int - - val zero : t - - val one : t -end = struct - include Int32 - - let num_bits = 32 - - let is_zero x = equal x 0l - - let of_int_exn x = of_int x - - let to_int_exn x = to_int x - - external ( < ) : int32 -> int32 -> bool = "%lessthan" - - external ( <= ) : int32 -> int32 -> bool = "%lessequal" - - external ( <> ) : int32 -> int32 -> bool = "%notequal" - - external ( = ) : int32 -> int32 -> bool = "%equal" - - external ( > ) : int32 -> int32 -> bool = "%greaterthan" - - external ( >= ) : int32 -> int32 -> bool = "%greaterequal" - - let warn_overflow ~to_dec ~to_hex i i32 = - warn - "Warning: integer overflow: integer 0x%s (%s) truncated to 0x%lx (%ld); the \ - generated code might be incorrect.@." - (to_hex i) - (to_dec i) - i32 - i32 - - let convert_warning_on_overflow ~to_int32 ~of_int32 ~equal ~to_dec ~to_hex x = - let i32 = to_int32 x in - let x' = of_int32 i32 in - if not (equal x' x) then warn_overflow ~to_dec ~to_hex x i32; - i32 - - let of_int_warning_on_overflow i = - convert_warning_on_overflow - ~to_int32:Int32.of_int - ~of_int32:Int32.to_int - ~equal:Int_replace_polymorphic_compare.( = ) - ~to_dec:(Printf.sprintf "%d") - ~to_hex:(Printf.sprintf "%x") - i - - let of_int32_warning_on_overflow i = i - - let of_nativeint_warning_on_overflow n = - convert_warning_on_overflow - ~to_int32:Nativeint.to_int32 - ~of_int32:Nativeint.of_int32 - ~equal:Nativeint.equal - ~to_dec:(Printf.sprintf "%nd") - ~to_hex:(Printf.sprintf "%nx") - n -end - module Option = struct let map ~f x = match x with diff --git a/compiler/lib/targetint.ml b/compiler/lib/targetint.ml new file mode 100644 index 0000000000..a531f4f272 --- /dev/null +++ b/compiler/lib/targetint.ml @@ -0,0 +1,56 @@ +include Int32 + +let num_bits = 32 + +let is_zero x = equal x 0l + +let of_int_exn x = of_int x + +let to_int_exn x = to_int x + +external ( < ) : int32 -> int32 -> bool = "%lessthan" + +external ( <= ) : int32 -> int32 -> bool = "%lessequal" + +external ( <> ) : int32 -> int32 -> bool = "%notequal" + +external ( = ) : int32 -> int32 -> bool = "%equal" + +external ( > ) : int32 -> int32 -> bool = "%greaterthan" + +external ( >= ) : int32 -> int32 -> bool = "%greaterequal" + +let warn_overflow ~to_dec ~to_hex i i32 = + Stdlib.warn + "Warning: integer overflow: integer 0x%s (%s) truncated to 0x%lx (%ld); the \ + generated code might be incorrect.@." + (to_hex i) + (to_dec i) + i32 + i32 + +let convert_warning_on_overflow ~to_int32 ~of_int32 ~equal ~to_dec ~to_hex x = + let i32 = to_int32 x in + let x' = of_int32 i32 in + if not (equal x' x) then warn_overflow ~to_dec ~to_hex x i32; + i32 + +let of_int_warning_on_overflow i = + convert_warning_on_overflow + ~to_int32:Int32.of_int + ~of_int32:Int32.to_int + ~equal:Int_replace_polymorphic_compare.( = ) + ~to_dec:(Printf.sprintf "%d") + ~to_hex:(Printf.sprintf "%x") + i + +let of_int32_warning_on_overflow i = i + +let of_nativeint_warning_on_overflow n = + convert_warning_on_overflow + ~to_int32:Nativeint.to_int32 + ~of_int32:Nativeint.of_int32 + ~equal:Nativeint.equal + ~to_dec:(Printf.sprintf "%nd") + ~to_hex:(Printf.sprintf "%nx") + n diff --git a/compiler/lib/targetint.mli b/compiler/lib/targetint.mli new file mode 100644 index 0000000000..8d5175f3ec --- /dev/null +++ b/compiler/lib/targetint.mli @@ -0,0 +1,71 @@ +type t + +val equal : t -> t -> bool + +val compare : t -> t -> int + +val to_string : t -> string + +val to_int_exn : t -> int + +val to_float : t -> float + +val of_string : string -> t + +val of_float : float -> t + +val of_int_exn : int -> t + +val of_int32_warning_on_overflow : int32 -> t + +val of_nativeint_warning_on_overflow : nativeint -> t + +val of_int_warning_on_overflow : int -> t + +val succ : t -> t + +val add : t -> t -> t + +val sub : t -> t -> t + +val mul : t -> t -> t + +val div : t -> t -> t + +val rem : t -> t -> t + +val logand : t -> t -> t + +val logor : t -> t -> t + +val logxor : t -> t -> t + +val shift_left : t -> int -> t + +val shift_right : t -> int -> t + +val shift_right_logical : t -> int -> t + +val neg : t -> t + +val abs : t -> t + +val ( >= ) : t -> t -> bool + +val ( <= ) : t -> t -> bool + +val ( < ) : t -> t -> bool + +val ( > ) : t -> t -> bool + +val ( = ) : t -> t -> bool + +val ( <> ) : t -> t -> bool + +val is_zero : t -> bool + +val num_bits : int + +val zero : t + +val one : t