Add Float_block subkind and fix bug in Lambda_conversions.value_kind (o…

…caml-flambda#134)

middle_end/flambda2/from_lambda/lambda_conversions.ml

@@ -36,7 +36,12 @@ let rec value_kind (vk : L.value_kind) =
   | Pboxedintval Pnativeint -> KS.boxed_nativeint
   | Pintval -> KS.tagged_immediate
   | Pblock { tag; fields } ->
-    KS.block (Tag.create_exn tag) (List.map value_kind fields)
+    (* If we have [Obj.double_array_tag] here, this is always an
+       all-float block, not an array. *)
+    if tag = Obj.double_array_tag then
+      KS.float_block ~num_fields:(List.length fields)
+    else
+      KS.block (Tag.create_exn tag) (List.map value_kind fields)
 
 let inline_attribute (attr : L.inline_attribute) : Inline_attribute.t =
   match attr with

middle_end/flambda2/parser/fexpr.ml

@@ -99,6 +99,7 @@ type kind = (* can't alias because Flambda_kind.t is private *)
 type kind_with_subkind = (* can't alias for same reason as [kind] *)
   | Any_value
   | Block of { tag : Tag.t; fields : kind_with_subkind list }
+  | Float_block of { num_fields : int; }
   | Naked_number of naked_number_kind
   | Boxed_float
   | Boxed_int32

middle_end/flambda2/parser/fexpr_to_flambda.ml

@@ -237,6 +237,7 @@ let rec value_kind_with_subkind (k : Fexpr.kind_with_subkind)
   | Any_value -> KWS.any_value
   | Block { tag; fields; } ->
     KWS.block tag (List.map value_kind_with_subkind fields)
+  | Float_block { num_fields; } -> KWS.float_block ~num_fields
   | Naked_number naked_number_kind ->
     begin
       match naked_number_kind with

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -377,6 +377,7 @@ let kind_with_subkind (k : Flambda_kind.With_subkind.t) =
     | Block { tag; fields; } ->
       let fields = List.map convert fields in
       Block { tag; fields; }
+    | Float_block { num_fields; } -> Float_block { num_fields; }
     | Naked_number nnk -> Naked_number nnk
     | Boxed_float -> Boxed_float
     | Boxed_int32 -> Boxed_int32

middle_end/flambda2/parser/print_fexpr.ml

@@ -144,6 +144,7 @@ let kind_with_subkind ppf (k : kind_with_subkind) =
   match k with
   | Any_value -> str "val"
   | Block _ -> str "block" (* CR mshinwell: improve this *)
+  | Float_block _ -> str "float_block"
   | Naked_number nnk -> naked_number_kind ppf nnk
   | Boxed_float -> str "float boxed"
   | Boxed_int32 -> str "int32 boxed"

middle_end/flambda2/types/kinds/flambda_kind.ml

@@ -376,6 +376,7 @@ module With_subkind = struct
       | Boxed_nativeint
       | Tagged_immediate
       | Block of { tag : Tag.t; fields : t list }
+      | Float_block of { num_fields : int; }
 
     include Container_types.Make (struct
       type nonrec t = t
@@ -402,11 +403,16 @@ module With_subkind = struct
           Format.fprintf ppf "@<0>%s=boxed_@<1>\u{2115}@<1>\u{2115}@<0>%s"
             colour (Flambda_colours.normal ())
         | Block { tag; fields } ->
-          Format.fprintf ppf "%s=Block{%a: %a}%s"
+          Format.fprintf ppf "@<0>%s=Block{%a: %a}@<0>%s"
             colour
             Tag.print tag
             (Format.pp_print_list ~pp_sep:Format.pp_print_space print) fields
             (Flambda_colours.normal ())
+        | Float_block { num_fields; } ->
+          Format.fprintf ppf "@<0>%s=Float_block(%d)@<0>%s"
+            colour
+            num_fields
+            (Flambda_colours.normal ())
 
       let compare = Stdlib.compare
 
@@ -436,7 +442,8 @@ module With_subkind = struct
       | Boxed_int64
       | Boxed_nativeint
       | Tagged_immediate
-      | Block _ ->
+      | Block _
+      | Float_block _ ->
         Misc.fatal_errorf "Only subkind %a is valid for kind %a"
           Subkind.print subkind
           print kind
@@ -458,12 +465,17 @@ module With_subkind = struct
   let boxed_nativeint = create value Boxed_nativeint
   let tagged_immediate = create value Tagged_immediate
   let rec_info = create rec_info Anything
+
   let block tag fields =
-    if List.exists (fun t -> not (equal t.kind Value)) fields then
-      Misc.fatal_error "Block with fields of kind not value";
+    if List.exists (fun t -> not (equal t.kind Value)) fields then begin
+      Misc.fatal_error "Block with fields of non-Value kind \
+        (use [Flambda_kind.With_subkind.float_block] for float records)"
+    end;
     let fields = List.map (fun t -> t.subkind) fields in
     create value (Block { tag; fields })
 
+  let float_block ~num_fields = create value (Float_block { num_fields; })
+
   let of_naked_number_kind (naked_number_kind : Naked_number_kind.t) =
     match naked_number_kind with
     | Naked_immediate -> naked_immediate
@@ -484,7 +496,7 @@ module With_subkind = struct
           Subkind.print subkind
       | (Naked_number _ | Fabricated | Rec_info),
         (Boxed_float | Boxed_int32 | Boxed_int64 | Boxed_nativeint
-          | Tagged_immediate | Block _) ->
+          | Tagged_immediate | Block _ | Float_block _) ->
         assert false  (* see [create] *)
 
     let compare
@@ -512,6 +524,7 @@ module With_subkind = struct
     | Tagged_immediate
     | Rec_info
     | Block of { tag : Tag.t; fields : descr list }
+    | Float_block of { num_fields : int; }
 
   let rec subkind_descr (t : Subkind.t) : descr =
     match t with
@@ -523,6 +536,7 @@ module With_subkind = struct
     | Boxed_nativeint -> Boxed_nativeint
     | Block { tag; fields } ->
       Block { tag; fields = List.map subkind_descr fields }
+    | Float_block { num_fields; } -> Float_block { num_fields; }
 
   let descr t : descr =
     match t.kind with
@@ -548,17 +562,21 @@ module With_subkind = struct
       List.length fields1 = List.length fields2 &&
       List.for_all2 (fun d when_used_at -> compatible_descr d ~when_used_at)
         fields1 fields2
+    | Float_block { num_fields = num_fields1; },
+      Float_block { num_fields = num_fields2; } ->
+      num_fields1 = num_fields2
     (* Subkinds of [Value] may always be used at [Value], but not the
        converse: *)
-    | Block _, Any_value
+    | (Block _ | Float_block _), Any_value
     | Boxed_float, Any_value
     | Boxed_int32, Any_value
     | Boxed_int64, Any_value
     | Boxed_nativeint, Any_value
     | Tagged_immediate, Any_value -> true
     (* All other combinations are incompatible. *)
     | (Any_value | Naked_number _ | Boxed_float | Boxed_int32 | Boxed_int64
-      | Boxed_nativeint | Tagged_immediate | Block _ | Rec_info), _ -> false
+      | Boxed_nativeint | Tagged_immediate | Block _ | Float_block _
+      | Rec_info), _ -> false
 
   let compatible t ~when_used_at =
     compatible_descr (descr t) ~when_used_at:(descr when_used_at)
@@ -571,5 +589,6 @@ module With_subkind = struct
     | Boxed_int64
     | Boxed_nativeint
     | Tagged_immediate
-    | Block _ -> true
+    | Block _
+    | Float_block _ -> true
 end

middle_end/flambda2/types/kinds/flambda_kind.mli

@@ -167,6 +167,7 @@ module With_subkind : sig
       | Boxed_nativeint
       | Tagged_immediate
       | Block of { tag : Tag.t; fields : t list }
+      | Float_block of { num_fields : int; }
 
     include Container_types.S with type t := t
   end
@@ -194,6 +195,7 @@ module With_subkind : sig
   val tagged_immediate : t
   val rec_info : t
   val block : Tag.t -> t list -> t
+  val float_block : num_fields:int -> t
 
   val of_naked_number_kind : Naked_number_kind.t -> t
 
@@ -207,6 +209,7 @@ module With_subkind : sig
     | Tagged_immediate
     | Rec_info
     | Block of { tag : Tag.t; fields : descr list }
+    | Float_block of { num_fields : int; }
 
   val descr : t -> descr
 

middle_end/flambda2/types/template/flambda_type.templ.ml

@@ -80,15 +80,14 @@ let rec unknown_with_descr (descr : Flambda_kind.With_subkind.descr) =
   | Tagged_immediate -> any_tagged_immediate ()
   | Rec_info -> any_rec_info ()
   | Block { tag; fields } ->
-    let field_kind, fields =
-      if Tag.equal Tag.double_array_tag tag then
-        Flambda_kind.naked_float,
-        List.map (fun _ -> any_naked_float ()) fields
-      else
-        Flambda_kind.value,
-        List.map unknown_with_descr fields
-    in
-    immutable_block ~is_unique:false tag ~field_kind ~fields
+    assert (not (Tag.equal tag Tag.double_array_tag));
+    immutable_block ~is_unique:false tag
+      ~field_kind:Flambda_kind.value
+      ~fields:(List.map unknown_with_descr fields)
+  | Float_block { num_fields; } ->
+    immutable_block ~is_unique:false Tag.double_array_tag
+      ~field_kind:Flambda_kind.naked_float
+      ~fields:(List.init num_fields (fun _ -> any_naked_float ()))
 
 let unknown_with_subkind kind =
   unknown_with_descr (Flambda_kind.With_subkind.descr kind)