Allow immediate64s in mixed records

backend/cmm_helpers.ml

@@ -1593,8 +1593,8 @@ let make_mixed_alloc ~mode dbg tag shape args =
     then addr_array_init arr ofs newval dbg
     else
       match flat_suffix.(idx - value_prefix_len) with
-      | Imm -> int_array_set arr ofs newval dbg
-      | Float | Float64 -> float_array_set arr ofs newval dbg
+      | Imm | Imm64 -> int_array_set arr ofs newval dbg
+      | Float_boxed | Float64 -> float_array_set arr ofs newval dbg
       | Float32 -> setfield_unboxed_float32 arr ofs newval dbg
       | Bits32 -> setfield_unboxed_int32 arr ofs newval dbg
       | Bits64 | Word -> setfield_unboxed_int64_or_nativeint arr ofs newval dbg

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -992,9 +992,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
         (fun i arg ->
           match Lambda.get_mixed_block_element shape i with
           | Value_prefix
-          | Flat_suffix (Float64 | Float32 | Imm | Bits32 | Bits64 | Word) ->
+          | Flat_suffix
+              (Float64 | Float32 | Imm | Bits32 | Bits64 | Word | Imm64) ->
             arg
-          | Flat_suffix Float -> unbox_float arg)
+          | Flat_suffix Float_boxed -> unbox_float arg)
         args
     in
     let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in
@@ -1463,7 +1464,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
             (match read with
             | Flat_read flat_element ->
               P.Mixed_block_flat_element.from_lambda flat_element
-            | Flat_read_float _ -> Float)
+            | Flat_read_float_boxed _ -> Float_boxed)
       in
       Mixed { tag = Unknown; field_kind; size = Unknown }
     in
@@ -1472,7 +1473,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     in
     match read with
     | Mread_value_prefix _ | Mread_flat_suffix (Flat_read _) -> [block_access]
-    | Mread_flat_suffix (Flat_read_float mode) ->
+    | Mread_flat_suffix (Flat_read_float_boxed mode) ->
       [box_float mode block_access ~current_region])
   | ( Psetfield (index, immediate_or_pointer, initialization_or_assignment),
       [[block]; [value]] ) ->
@@ -1533,9 +1534,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
     let value =
       match write with
       | Mwrite_value_prefix _
-      | Mwrite_flat_suffix (Imm | Float64 | Float32 | Bits32 | Bits64 | Word) ->
+      | Mwrite_flat_suffix
+          (Imm | Imm64 | Float64 | Float32 | Bits32 | Bits64 | Word) ->
         value
-      | Mwrite_flat_suffix Float -> unbox_float value
+      | Mwrite_flat_suffix Float_boxed -> unbox_float value
     in
     [ Ternary
         (Block_set (block_access, init_or_assign), block, Simple field, value)

middle_end/flambda2/terms/code_size.ml

@@ -163,7 +163,8 @@ let block_set (kind : Flambda_primitive.Block_access_kind.t)
         { field_kind =
             ( Value_prefix _
             | Flat_suffix
-                (Imm | Float | Float64 | Float32 | Bits32 | Bits64 | Word) );
+                ( Imm | Float_boxed | Float64 | Float32 | Bits32 | Bits64 | Word
+                | Imm64 ) );
           _
         },
       (Assignment _ | Initialization) ) ->

middle_end/flambda2/terms/flambda_primitive.ml

@@ -61,7 +61,8 @@ end
 module Mixed_block_flat_element = struct
   type t =
     | Imm
-    | Float
+    | Imm64
+    | Float_boxed
     | Float64
     | Float32
     | Bits32
@@ -70,7 +71,8 @@ module Mixed_block_flat_element = struct
 
   let from_lambda : Lambda.flat_element -> t = function
     | Imm -> Imm
-    | Float -> Float
+    | Imm64 -> Imm64
+    | Float_boxed -> Float_boxed
     | Float64 -> Float64
     | Float32 -> Float32
     | Bits32 -> Bits32
@@ -79,7 +81,8 @@ module Mixed_block_flat_element = struct
 
   let to_lambda : t -> Lambda.flat_element = function
     | Imm -> Imm
-    | Float -> Float
+    | Imm64 -> Imm64
+    | Float_boxed -> Float_boxed
     | Float64 -> Float64
     | Float32 -> Float32
     | Bits32 -> Bits32
@@ -88,7 +91,8 @@ module Mixed_block_flat_element = struct
 
   let to_string = function
     | Imm -> "Imm"
-    | Float -> "Float"
+    | Imm64 -> "Imm64"
+    | Float_boxed -> "Float_boxed"
     | Float64 -> "Float64"
     | Float32 -> "Float32"
     | Bits32 -> "Bits32"
@@ -98,7 +102,8 @@ module Mixed_block_flat_element = struct
   let compare t1 t2 =
     match t1, t2 with
     | Imm, Imm
-    | Float, Float
+    | Imm64, Imm64
+    | Float_boxed, Float_boxed
     | Float64, Float64
     | Float32, Float32
     | Word, Word
@@ -107,8 +112,10 @@ module Mixed_block_flat_element = struct
       0
     | Imm, _ -> -1
     | _, Imm -> 1
-    | Float, _ -> -1
-    | _, Float -> 1
+    | Imm64, _ -> -1
+    | _, Imm64 -> 1
+    | Float_boxed, _ -> -1
+    | _, Float_boxed -> 1
     | Float64, _ -> -1
     | _, Float64 -> 1
     | Float32, _ -> -1
@@ -122,7 +129,8 @@ module Mixed_block_flat_element = struct
 
   let element_kind = function
     | Imm -> K.value
-    | Float | Float64 -> K.naked_float
+    | Imm64 -> K.value
+    | Float_boxed | Float64 -> K.naked_float
     | Float32 -> K.naked_float32
     | Bits32 -> K.naked_int32
     | Bits64 -> K.naked_int64
@@ -538,8 +546,8 @@ module Block_access_kind = struct
     | Naked_floats _ -> K.With_subkind.naked_float
     | Mixed { field_kind = Flat_suffix field_kind; _ } -> (
       match field_kind with
-      | Imm -> K.With_subkind.tagged_immediate
-      | Float | Float64 -> K.With_subkind.naked_float
+      | Imm | Imm64 -> K.With_subkind.tagged_immediate
+      | Float_boxed | Float64 -> K.With_subkind.naked_float
       | Float32 -> K.With_subkind.naked_float32
       | Bits32 -> K.With_subkind.naked_int32
       | Bits64 -> K.With_subkind.naked_int64

middle_end/flambda2/terms/flambda_primitive.mli

@@ -65,7 +65,8 @@ end
 module Mixed_block_flat_element : sig
   type t =
     | Imm
-    | Float
+    | Imm64
+    | Float_boxed
     | Float64
     | Float32
     | Bits32

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -106,8 +106,8 @@ let block_load ~dbg (kind : P.Block_access_kind.t) (mutability : Mutability.t)
   | Naked_floats _ -> C.unboxed_float_array_ref block index dbg
   | Mixed { field_kind = Flat_suffix field_kind; _ } -> (
     match field_kind with
-    | Imm -> C.get_field_computed Immediate mutability ~block ~index dbg
-    | Float | Float64 ->
+    | Imm | Imm64 -> C.get_field_computed Immediate mutability ~block ~index dbg
+    | Float_boxed | Float64 ->
       (* CR layouts v5.1: We should use the mutability here to generate better
          code if the load is immutable. *)
       C.unboxed_float_array_ref block index dbg
@@ -130,9 +130,9 @@ let block_set ~dbg (kind : P.Block_access_kind.t) (init : P.Init_or_assign.t)
     | Naked_floats _ -> C.float_array_set block index new_value dbg
     | Mixed { field_kind = Flat_suffix field_kind; _ } -> (
       match field_kind with
-      | Imm ->
+      | Imm | Imm64 ->
         C.setfield_computed Immediate init_or_assign block index new_value dbg
-      | Float | Float64 -> C.float_array_set block index new_value dbg
+      | Float_boxed | Float64 -> C.float_array_set block index new_value dbg
       | Float32 -> C.setfield_unboxed_float32 block index new_value dbg
       | Bits32 -> C.setfield_unboxed_int32 block index new_value dbg
       | Bits64 | Word ->

ocaml/lambda/lambda.ml

@@ -343,10 +343,10 @@ and block_shape =
   value_kind list option
 
 and flat_element = Types.flat_element =
-    Imm | Float | Float64 | Float32 | Bits32 | Bits64 | Word
+    Imm | Imm64 | Float_boxed | Float64 | Float32 | Bits32 | Bits64 | Word
 and flat_element_read =
-  | Flat_read of flat_element (* invariant: not [Float] *)
-  | Flat_read_float of alloc_mode
+  | Flat_read of flat_element (* invariant: not [Float_boxed] *)
+  | Flat_read_float_boxed of alloc_mode
 and mixed_block_read =
   | Mread_value_prefix of immediate_or_pointer
   | Mread_flat_suffix of flat_element_read
@@ -534,6 +534,9 @@ let rec compatible_layout x y =
      Punboxed_product _), _ ->
       false
 
+let value_kind_of_immediate64 () =
+  if !Clflags.native_code && Sys.word_size = 64 then Pintval else Pgenval
+
 let must_be_value layout =
   match layout with
   | Pvalue v -> v
@@ -1262,13 +1265,13 @@ type mixed_block_element = Types.mixed_product_element =
 
 let get_mixed_block_element = Types.get_mixed_product_element
 
-let flat_read_non_float flat_element =
+let flat_read_non_float_boxed flat_element =
   match flat_element with
-  | Float -> Misc.fatal_error "flat_element_read_non_float Float"
-  | Imm | Float64 | Float32 | Bits32 | Bits64 | Word as flat_element ->
+  | Float_boxed -> Misc.fatal_error "flat_element_read_non_float Float_boxed"
+  | Imm64 | Imm | Float64 | Float32 | Bits32 | Bits64 | Word as flat_element ->
       Flat_read flat_element
 
-let flat_read_float alloc_mode = Flat_read_float alloc_mode
+let flat_read_float_boxed alloc_mode = Flat_read_float_boxed alloc_mode
 
 (* Compile a sequence of expressions *)
 
@@ -1674,7 +1677,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pmixedfield (_, read, _) -> begin
       match read with
       | Mread_value_prefix _ -> None
-      | Mread_flat_suffix (Flat_read_float m) -> Some m
+      | Mread_flat_suffix (Flat_read_float_boxed m) -> Some m
       | Mread_flat_suffix (Flat_read _) -> None
     end
   | Psetfloatfield _ -> None
@@ -1824,17 +1827,18 @@ let array_ref_kind_result_layout = function
 let layout_of_mixed_field (kind : mixed_block_read) =
   match kind with
   | Mread_value_prefix _ -> layout_value_field
-  | Mread_flat_suffix (Flat_read_float (_ : alloc_mode)) ->
+  | Mread_flat_suffix (Flat_read_float_boxed (_ : alloc_mode)) ->
       layout_boxed_float Pfloat64
   | Mread_flat_suffix (Flat_read proj) ->
       match proj with
       | Imm -> layout_int
+      | Imm64 -> Pvalue (value_kind_of_immediate64 ())
       | Float64 -> layout_unboxed_float Pfloat64
       | Float32 -> layout_unboxed_float Pfloat32
       | Bits32 -> layout_unboxed_int32
       | Bits64 -> layout_unboxed_int64
       | Word -> layout_unboxed_nativeint
-      | Float -> layout_boxed_float Pfloat64
+      | Float_boxed -> layout_boxed_float Pfloat64
 
 let primitive_result_layout (p : primitive) =
   assert !Clflags.native_code;

ocaml/lambda/lambda.mli

@@ -351,10 +351,10 @@ and block_shape =
   value_kind list option
 
 and flat_element = Types.flat_element =
-    Imm | Float | Float64 | Float32 | Bits32 | Bits64 | Word
+    Imm | Imm64 | Float_boxed | Float64 | Float32 | Bits32 | Bits64 | Word
 and flat_element_read = private
-  | Flat_read of flat_element (* invariant: not [Float] *)
-  | Flat_read_float of alloc_mode
+  | Flat_read of flat_element (* invariant: not [Float_boxed] *)
+  | Flat_read_float_boxed of alloc_mode
 and mixed_block_read =
   | Mread_value_prefix of immediate_or_pointer
   | Mread_flat_suffix of flat_element_read
@@ -606,7 +606,7 @@ type lambda =
      a subset of those open at the point of the [Lstaticraise] that jumps to it,
      as we can't reopen closed regions. All regions that were open at the point of
      the [Lstaticraise] but not in the handler will be closed just before the [Lstaticraise].
-   
+
      However, to be able to express the fact
      that the [Lstaticraise] might be under a [Lexclave], the [pop_region] flag
      is used to specify what regions are considered open in the handler. If it
@@ -838,9 +838,9 @@ type mixed_block_element =
 (** Raises if the int is out of bounds. *)
 val get_mixed_block_element : mixed_block_shape -> int -> mixed_block_element
 
-(** Raises if [flat_element] is float. *)
-val flat_read_non_float : flat_element -> flat_element_read
-val flat_read_float : alloc_mode -> flat_element_read
+(** Raises if [flat_element] is Float_boxed. *)
+val flat_read_non_float_boxed : flat_element -> flat_element_read
+val flat_read_float_boxed : alloc_mode -> flat_element_read
 
 val make_sequence: ('a -> lambda) -> 'a list -> lambda
 
@@ -979,3 +979,9 @@ val simple_prim_on_values
 -> arity:int
 -> alloc:bool
 -> external_call_description
+
+(** The value kind of an immediate64 value. It's an int on 64-bit platforms and
+    the top value kind otherwise. This binding is a function and not a constant
+    because making this decision relies on the setting of command-line flags.
+*)
+val value_kind_of_immediate64 : unit -> value_kind

ocaml/lambda/matching.ml

@@ -1811,11 +1811,11 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
             | Flat_suffix flat ->
                 let flat_read =
                   match flat with
-                  | Float ->
+                  | Float_boxed ->
                       Misc.fatal_error
                         "unexpected flat float of layout value in \
                          constructor field"
-                  | non_float -> flat_read_non_float non_float
+                  | non_float_boxed -> flat_read_non_float_boxed non_float_boxed
                 in
                 Mread_flat_suffix flat_read
           in
@@ -2183,11 +2183,12 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
               else
                 let read =
                   match flat_suffix.(pos - value_prefix_len) with
-                  | Imm | Float64 | Float32 | Bits32 | Bits64 | Word as non_float ->
-                      flat_read_non_float non_float
-                  | Float ->
+                  | Imm | Imm64 | Float64 | Float32 | Bits32 | Bits64 | Word
+                    as non_float_boxed ->
+                      flat_read_non_float_boxed non_float_boxed
+                  | Float_boxed ->
                       (* TODO: could optimise to Alloc_local sometimes *)
-                      flat_read_float alloc_heap
+                      flat_read_float_boxed alloc_heap
                 in
                 Mread_flat_suffix read
             in

ocaml/lambda/printlambda.ml

@@ -324,7 +324,7 @@ let flat_element ppf : flat_element -> unit = fun x ->
 let flat_element_read ppf : flat_element_read -> unit = function
   | Flat_read flat ->
       pp_print_string ppf (Types.flat_element_to_lowercase_string flat)
-  | Flat_read_float m -> fprintf ppf "float[%a]" alloc_mode m
+  | Flat_read_float_boxed m -> fprintf ppf "float_boxed[%a]" alloc_mode m
 
 let mixed_block_read ppf : mixed_block_read -> unit = function
   | Mread_value_prefix Immediate -> pp_print_string ppf "value_int"

ocaml/lambda/translcore.ml

@@ -611,15 +611,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
             else
               let flat_read =
                 match flat_suffix.(lbl.lbl_num - value_prefix_len) with
-                | Float ->
+                | Float_boxed ->
                   (match float with
                     | Boxing (mode, _) ->
-                        flat_read_float (transl_alloc_mode_r mode)
+                        flat_read_float_boxed (transl_alloc_mode_r mode)
                     | Non_boxing _ ->
                         Misc.fatal_error
                           "expected typechecking to make [float] boxing mode\
                           \ present for float field read")
-                | non_float -> flat_read_non_float non_float
+                | non_float_boxed -> flat_read_non_float_boxed non_float_boxed
               in
               Mread_flat_suffix flat_read
           in
@@ -1734,12 +1734,13 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
                     else
                       let read =
                         match flat_suffix.(lbl.lbl_num - value_prefix_len) with
-                        | Float ->
+                        | Float_boxed ->
                             (* See the handling of [Record_float] above for
                                 why we choose Alloc_heap.
                             *)
-                            flat_read_float alloc_heap
-                        | non_float -> flat_read_non_float non_float
+                            flat_read_float_boxed alloc_heap
+                        | non_float_boxed ->
+                            flat_read_non_float_boxed non_float_boxed
                       in
                       Mread_flat_suffix read
                    in