formatted

ocaml-flambda · Dec 12, 2024 · 7830039 · 7830039
1 parent a24610f
commit 7830039
Show file tree

Hide file tree

Showing 33 changed files with 493 additions and 424 deletions.
diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml
@@ -177,9 +177,8 @@ let rec declare_const acc dbg (const : Lambda.structured_constant) =
               match RWC.descr cst with
               | Tagged_immediate _ | Null -> ()
               | Naked_immediate _ | Naked_float32 _ | Naked_float _
-              | Naked_int8 _ | Naked_int16 _
-              | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _
-              | Naked_vec128 _ ->
+              | Naked_int8 _ | Naked_int16 _ | Naked_int32 _ | Naked_int64 _
+              | Naked_nativeint _ | Naked_vec128 _ ->
                 Misc.fatal_errorf
                   "Unboxed constants are not allowed inside of Const_block: %a"
                   Printlambda.structured_constant const);
@@ -215,7 +214,9 @@ let rec declare_const acc dbg (const : Lambda.structured_constant) =
           else
             match shape.flat_suffix.(i - shape.value_prefix_len) with
             | Float_boxed -> unbox_float_constant c
-            | Imm | Float64 | Float32 | Bits8 | Bits16 |Bits32 | Bits64 | Vec128 | Word -> c)
+            | Imm | Float64 | Float32 | Bits8 | Bits16 | Bits32 | Bits64
+            | Vec128 | Word ->
+              c)
         consts
     in
     let shape = K.Mixed_block_shape.from_lambda shape in
@@ -711,11 +712,15 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
     in
     match prim_native_name with
     | "caml_int64_float_of_bits_unboxed" ->
-      unboxed_int64_to_and_from_unboxed_float ~src_kind:(Unboxed_integer Boxed_int64)
-        ~dst_kind:(Unboxed_float Boxed_float64) ~op:Unboxed_int64_as_unboxed_float64
+      unboxed_int64_to_and_from_unboxed_float
+        ~src_kind:(Unboxed_integer Boxed_int64)
+        ~dst_kind:(Unboxed_float Boxed_float64)
+        ~op:Unboxed_int64_as_unboxed_float64
     | "caml_int64_bits_of_float_unboxed" ->
-      unboxed_int64_to_and_from_unboxed_float ~src_kind:(Unboxed_float Boxed_float64)
-        ~dst_kind:(Unboxed_integer Boxed_int64) ~op:Unboxed_float64_as_unboxed_int64
+      unboxed_int64_to_and_from_unboxed_float
+        ~src_kind:(Unboxed_float Boxed_float64)
+        ~dst_kind:(Unboxed_integer Boxed_int64)
+        ~op:Unboxed_float64_as_unboxed_int64
     | _ ->
       let callee = Simple.symbol call_symbol in
       let apply =
@@ -1294,8 +1299,8 @@ let close_let acc env let_bound_ids_with_kinds user_visible defining_expr
                           | Naked_float f -> Or_variable.Const f
                           | Tagged_immediate _ | Naked_immediate _
                           | Naked_float32 _ | Naked_int32 _ | Naked_int64 _
-                          | Naked_int8 _ | Naked_int16 _
-                          | Naked_nativeint _ | Naked_vec128 _ | Null ->
+                          | Naked_int8 _ | Naked_int16 _ | Naked_nativeint _
+                          | Naked_vec128 _ | Null ->
                             Misc.fatal_errorf
                               "Binding of %a to %a contains the constant %a \
                                inside a float record, whereas only naked \

diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml
@@ -1255,9 +1255,11 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents
               false)
           field_kinds);
       Some (Unboxed_float_record (List.length field_kinds))
-    | Pvalue { nullable = Non_nullable; raw_kind = Pboxedfloatval Boxed_float64 } ->
+    | Pvalue
+        { nullable = Non_nullable; raw_kind = Pboxedfloatval Boxed_float64 } ->
       Some (Unboxed_number Naked_float)
-    | Pvalue { nullable = Non_nullable; raw_kind = Pboxedfloatval Boxed_float32 } ->
+    | Pvalue
+        { nullable = Non_nullable; raw_kind = Pboxedfloatval Boxed_float32 } ->
       Some (Unboxed_number Naked_float32)
     | Pvalue { nullable = Non_nullable; raw_kind = Pboxedintval bi } ->
       let bn : Flambda_kind.Boxable_number.t =

diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml
@@ -60,10 +60,14 @@ let convert_unboxed_integer_comparison_prim (kind : L.unboxed_integer)
   | Unboxed_int64, Cge -> Int_comp (Naked_int64, Yielding_bool (Ge Signed))
   | Unboxed_nativeint, Ceq -> Int_comp (Naked_nativeint, Yielding_bool Eq)
   | Unboxed_nativeint, Cne -> Int_comp (Naked_nativeint, Yielding_bool Neq)
-  | Unboxed_nativeint, Clt -> Int_comp (Naked_nativeint, Yielding_bool (Lt Signed))
-  | Unboxed_nativeint, Cgt -> Int_comp (Naked_nativeint, Yielding_bool (Gt Signed))
-  | Unboxed_nativeint, Cle -> Int_comp (Naked_nativeint, Yielding_bool (Le Signed))
-  | Unboxed_nativeint, Cge -> Int_comp (Naked_nativeint, Yielding_bool (Ge Signed))
+  | Unboxed_nativeint, Clt ->
+    Int_comp (Naked_nativeint, Yielding_bool (Lt Signed))
+  | Unboxed_nativeint, Cgt ->
+    Int_comp (Naked_nativeint, Yielding_bool (Gt Signed))
+  | Unboxed_nativeint, Cle ->
+    Int_comp (Naked_nativeint, Yielding_bool (Le Signed))
+  | Unboxed_nativeint, Cge ->
+    Int_comp (Naked_nativeint, Yielding_bool (Ge Signed))
 
 let convert_float_comparison (comp : L.float_comparison) : unit P.comparison =
   match comp with
@@ -85,13 +89,15 @@ let boxable_number_of_boxed_integer (bint : L.boxed_integer) :
   | Boxed_int32 -> Naked_int32
   | Boxed_int64 -> Naked_int64
 
-let standard_int_of_boxed_integer (bint : Primitive.boxed_integer) : K.Standard_int.t =
+let standard_int_of_boxed_integer (bint : Primitive.boxed_integer) :
+    K.Standard_int.t =
   match bint with
   | Boxed_nativeint -> Naked_nativeint
   | Boxed_int32 -> Naked_int32
   | Boxed_int64 -> Naked_int64
 
-let standard_int_of_unboxed_integer : L.unboxed_integer -> K.Standard_int.t = function
+let standard_int_of_unboxed_integer : L.unboxed_integer -> K.Standard_int.t =
+  function
   | Unboxed_int8 -> Naked_int8
   | Unboxed_int16 -> Naked_int16
   | Unboxed_int32 -> Naked_int32
@@ -941,8 +947,8 @@ let bigarray_box_or_tag_raw_value_to_read kind alloc_mode =
     fun arg -> H.Unary (Box_number (Naked_float32, alloc_mode), Prim arg)
   | Naked_number Naked_float ->
     fun arg -> H.Unary (Box_number (Naked_float, alloc_mode), Prim arg)
-  (* The following tagging operations for small integers are valid because they are always
-     loaded sign-extended into a machine register *)
+  (* The following tagging operations for small integers are valid because they
+     are always loaded sign-extended into a machine register *)
   | Naked_number (Naked_int8 | Naked_int16) ->
     fun arg -> H.Unary (Tag_immediate, Prim arg)
   | Naked_number Naked_int32 ->
@@ -1387,8 +1393,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
           match Lambda.get_mixed_block_element shape i with
           | Value_prefix
           | Flat_suffix
-              (Float64 | Float32 | Imm | Bits8 | Bits16 | Bits32 | Bits64 |
-               Vec128 | Word) ->
+              ( Float64 | Float32 | Imm | Bits8 | Bits16 | Bits32 | Bits64
+              | Vec128 | Word ) ->
             arg
           | Flat_suffix Float_boxed -> unbox_float arg)
         args
@@ -1506,8 +1512,12 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     let arg1 = unbox_bint kind arg1 in
     let arg2 = unbox_bint kind arg2 in
     [ tag_int
-        (Binary (convert_unboxed_integer_comparison_prim (Primitive.unbox_integer kind) comp, arg1, arg2))
-    ]
+        (Binary
+           ( convert_unboxed_integer_comparison_prim
+               (Primitive.unbox_integer kind)
+               comp,
+             arg1,
+             arg2 )) ]
   | Punboxed_int_comp (kind, comp), [[arg1]; [arg2]] ->
     [ tag_int
         (Binary (convert_unboxed_integer_comparison_prim kind comp, arg1, arg2))
@@ -1568,7 +1578,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
            ( Float_comp (Float64, Yielding_bool (convert_float_comparison comp)),
              arg1,
              arg2 )) ]
-  | Punbox_float Boxed_float64, [[arg]] -> [Unary (Unbox_number Naked_float, arg)]
+  | Punbox_float Boxed_float64, [[arg]] ->
+    [Unary (Unbox_number Naked_float, arg)]
   | Pbox_float (Boxed_float64, mode), [[arg]] ->
     [ Unary
         ( Box_number
@@ -1623,14 +1634,16 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
            ( Float_comp (Float32, Yielding_bool (convert_float_comparison comp)),
              arg1,
              arg2 )) ]
-  | Punbox_float Boxed_float32, [[arg]] -> [Unary (Unbox_number Naked_float32, arg)]
+  | Punbox_float Boxed_float32, [[arg]] ->
+    [Unary (Unbox_number Naked_float32, arg)]
   | Pbox_float (Boxed_float32, mode), [[arg]] ->
     [ Unary
         ( Box_number
             ( Naked_float32,
               Alloc_mode.For_allocations.from_lambda mode ~current_region ),
           arg ) ]
-  | Punbox_vector Boxed_vec128, [[arg]] -> [Unary (Unbox_number Naked_vec128, arg)]
+  | Punbox_vector Boxed_vec128, [[arg]] ->
+    [Unary (Unbox_number Naked_vec128, arg)]
   | Pbox_vector (Boxed_vec128, mode), [[arg]] ->
     [ Unary
         ( Box_number
@@ -1957,7 +1970,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
       match write with
       | Mwrite_value_prefix _
       | Mwrite_flat_suffix
-          (Imm | Float64 | Float32 | Bits8 | Bits16 | Bits32 | Bits64 | Vec128 | Word) ->
+          ( Imm | Float64 | Float32 | Bits8 | Bits16 | Bits32 | Bits64 | Vec128
+          | Word ) ->
         value
       | Mwrite_flat_suffix Float_boxed -> unbox_float value
     in
@@ -1983,10 +1997,12 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
   | Pmodbint { size = Boxed_int64; is_safe = Safe; mode }, [[arg1]; [arg2]] ->
     [ checked_arith_op ~dbg (Some Boxed_int64) Mod (Some mode) arg1 arg2
         ~current_region ]
-  | Pdivbint { size = Boxed_nativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] ->
+  | Pdivbint { size = Boxed_nativeint; is_safe = Safe; mode }, [[arg1]; [arg2]]
+    ->
     [ checked_arith_op ~dbg (Some Boxed_nativeint) Div (Some mode) arg1 arg2
         ~current_region ]
-  | Pmodbint { size = Boxed_nativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] ->
+  | Pmodbint { size = Boxed_nativeint; is_safe = Safe; mode }, [[arg1]; [arg2]]
+    ->
     [ checked_arith_op ~dbg (Some Boxed_nativeint) Mod (Some mode) arg1 arg2
         ~current_region ]
   | Parrayrefu (array_ref_kind, index_kind, mut), [[array]; [index]] ->

diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml
@@ -200,8 +200,8 @@ module Flat_suffix_element0 = struct
   let equal = Stdlib.( = )
 
   let size_in_words = function
-    | Tagged_immediate | Naked_float | Naked_float32 | Naked_int8 | Naked_int16 | Naked_int32 | Naked_int64
-    | Naked_nativeint ->
+    | Tagged_immediate | Naked_float | Naked_float32 | Naked_int8 | Naked_int16
+    | Naked_int32 | Naked_int64 | Naked_nativeint ->
       1
     | Naked_vec128 -> 2
 
@@ -678,8 +678,7 @@ module With_subkind = struct
          converse): *)
       | ( ( Variant _ | Float_block _ | Float_array | Immediate_array
           | Value_array | Generic_array | Boxed_float | Boxed_float32
-          | Boxed_int32 | Boxed_int64
-          | Boxed_nativeint | Tagged_immediate ),
+          | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Tagged_immediate ),
           Anything ) ->
         true
       (* All specialised (boxed) array kinds may be used at kind
@@ -689,13 +688,12 @@ module With_subkind = struct
       | Immediate_array, Value_array ->
         true
       (* All other combinations are incompatible: *)
-      | ( ( Anything | Boxed_float | Boxed_float32
-          | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128
-          | Tagged_immediate | Variant _ | Float_block _ | Float_array
-          | Immediate_array | Value_array | Generic_array
-          | Unboxed_float32_array | Unboxed_int32_array | Unboxed_int64_array
-          | Unboxed_nativeint_array | Unboxed_product_array
-          | Unboxed_vec128_array ),
+      | ( ( Anything | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64
+          | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _
+          | Float_block _ | Float_array | Immediate_array | Value_array
+          | Generic_array | Unboxed_float32_array | Unboxed_int32_array
+          | Unboxed_int64_array | Unboxed_nativeint_array
+          | Unboxed_product_array | Unboxed_vec128_array ),
           _ ) ->
         false
 
@@ -788,12 +786,11 @@ module With_subkind = struct
     | Naked_number _ | Region | Rec_info -> (
       match value_subkind, nullable with
       | Anything, Non_nullable -> ()
-      | ( ( Boxed_float | Boxed_float32
-          | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128
-          | Tagged_immediate | Variant _ | Float_block _ | Float_array
-          | Immediate_array | Value_array | Generic_array
-          | Unboxed_float32_array | Unboxed_int32_array | Unboxed_int64_array
-          | Unboxed_nativeint_array | Unboxed_vec128_array
+      | ( ( Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64
+          | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _
+          | Float_block _ | Float_array | Immediate_array | Value_array
+          | Generic_array | Unboxed_float32_array | Unboxed_int32_array
+          | Unboxed_int64_array | Unboxed_nativeint_array | Unboxed_vec128_array
           | Unboxed_product_array ),
           _ ) ->
         Misc.fatal_errorf "Subkind %a is not valid for kind %a"
@@ -998,7 +995,8 @@ module With_subkind = struct
         Misc.unboxed_small_int_arrays_are_not_implemented ()
       | Parrayval (Punboxedintarray Unboxed_int32) -> Unboxed_int32_array
       | Parrayval (Punboxedintarray Unboxed_int64) -> Unboxed_int64_array
-      | Parrayval (Punboxedintarray Unboxed_nativeint) -> Unboxed_nativeint_array
+      | Parrayval (Punboxedintarray Unboxed_nativeint) ->
+        Unboxed_nativeint_array
       | Parrayval (Punboxedvectorarray Unboxed_vec128) -> Unboxed_vec128_array
       | Parrayval (Pgcscannableproductarray _ | Pgcignorableproductarray _) ->
         Unboxed_product_array
@@ -1037,13 +1035,11 @@ module With_subkind = struct
         Format.fprintf ppf "@[%a%a%a@]" print kind Non_null_value_subkind.print
           value_subkind Nullable.print nullable
       | ( (Naked_number _ | Region | Rec_info),
-          ( Boxed_float | Boxed_float32
-          | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128
-          | Tagged_immediate | Variant _ | Float_block _ | Float_array
-          | Immediate_array | Value_array | Generic_array
-          | Unboxed_float32_array
-          | Unboxed_int32_array | Unboxed_int64_array
-          | Unboxed_nativeint_array | Unboxed_vec128_array
+          ( Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64
+          | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _
+          | Float_block _ | Float_array | Immediate_array | Value_array
+          | Generic_array | Unboxed_float32_array | Unboxed_int32_array
+          | Unboxed_int64_array | Unboxed_nativeint_array | Unboxed_vec128_array
           | Unboxed_product_array ),
           Non_nullable )
       | (Naked_number _ | Region | Rec_info), _, Nullable ->
@@ -1077,12 +1073,12 @@ module With_subkind = struct
       match t.value_subkind with
       | Anything -> (
         match t.nullable with Nullable -> false | Non_nullable -> true)
-      | Boxed_float | Boxed_float32 | Boxed_int32
-      | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Tagged_immediate
-      | Variant _ | Float_block _ | Float_array | Immediate_array
-      | Value_array | Generic_array | Unboxed_float32_array
-      | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array
-      | Unboxed_vec128_array | Unboxed_product_array ->
+      | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64
+      | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _
+      | Float_block _ | Float_array | Immediate_array | Value_array
+      | Generic_array | Unboxed_float32_array | Unboxed_int32_array
+      | Unboxed_int64_array | Unboxed_nativeint_array | Unboxed_vec128_array
+      | Unboxed_product_array ->
         true)
     | Naked_number _ | Rec_info | Region -> false
 
@@ -1098,13 +1094,11 @@ module With_subkind = struct
     | Value -> (
       match non_null_value_subkind t with
       | Tagged_immediate -> false
-      | Anything | Boxed_float | Boxed_float32
-      | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Variant _
-      | Float_block _ | Float_array | Immediate_array | Value_array
-      | Generic_array | Unboxed_float32_array
-      | Unboxed_int32_array | Unboxed_int64_array
-      | Unboxed_nativeint_array | Unboxed_vec128_array
-      | Unboxed_product_array ->
+      | Anything | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64
+      | Boxed_nativeint | Boxed_vec128 | Variant _ | Float_block _ | Float_array
+      | Immediate_array | Value_array | Generic_array | Unboxed_float32_array
+      | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array
+      | Unboxed_vec128_array | Unboxed_product_array ->
         true)
     | Naked_number _ | Region | Rec_info -> false
 

diff --git a/middle_end/flambda2/kinds/flambda_kind.mli b/middle_end/flambda2/kinds/flambda_kind.mli
@@ -197,6 +197,7 @@ module Boxable_number : sig
     | Naked_int64
     | Naked_nativeint
     | Naked_vec128
+
   val unboxed_kind : t -> kind
 
   val print_lowercase : Format.formatter -> t -> unit

diff --git a/middle_end/flambda2/numbers/numeric_types.ml b/middle_end/flambda2/numbers/numeric_types.ml
@@ -38,18 +38,22 @@ module Int = struct
 end
 
 module Short_int (M : sig
-    val num_bits : int
-  end) = struct
+  val num_bits : int
+end) =
+struct
   let num_bits = M.num_bits
+
   let () = assert (0 < num_bits && num_bits < 31)
 
   module T0 = struct
     type t = int
 
     let zero = 0
+
     let one = 1
 
-    let min_int64 = (Int64.shift_left Int64.minus_one (num_bits - 1))
+    let min_int64 = Int64.shift_left Int64.minus_one (num_bits - 1)
+
     let max_int64 = Int64.lognot min_int64
 
     let of_int64_exn i =
@@ -64,25 +68,29 @@ module Short_int (M : sig
       (i lsl extra_bits) asr extra_bits
 
     let to_int i = i
+
     let to_float = Float.of_int
 
     let compare = Int.compare
+
     let equal = Int.equal
+
     let hash = (Hashtbl.hash : t -> int)
+
     let print = Format.pp_print_int
   end
 
   include T0
   include Container_types.Make (T0)
 end
 
-module Int8 = Short_int(struct
-    let num_bits = 8
+module Int8 = Short_int (struct
+  let num_bits = 8
 end)
 
-module Int16 = Short_int(struct
-    let num_bits = 16
-  end)
+module Int16 = Short_int (struct
+  let num_bits = 16
+end)
 
 module Int32 = struct
   include Int32