flambda-backend: Lambda block kinds (ocaml#86)

asmcomp/cmmgen.ml

@@ -690,7 +690,7 @@ and transl_catch env nfail ids body handler dbg =
          let strict =
            match kind with
            | Pfloatval | Pboxedintval _ -> false
-           | Pintval | Pgenval -> true
+           | Pintval | Pgenval | Pblock _ -> true
          in
          u := join_unboxed_number_kind ~strict !u
              (is_unboxed_number_cmm ~strict c)
@@ -1145,7 +1145,7 @@ and transl_let env str kind id exp body =
            we do it only if this indeed allows us to get rid of
            some allocations in the bound expression. *)
         is_unboxed_number_cmm ~strict:false cexp
-    | _, Pgenval ->
+    | _, (Pgenval | Pblock _) ->
         (* Here we don't know statically that the bound expression
            evaluates to an unboxable number type.  We need to be stricter
            and ensure that all possible branches in the expression

compilerlibs/Makefile.compilerlibs

@@ -62,15 +62,15 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/typedecl_properties.cmo typing/typedecl_variance.cmo \
   typing/typedecl_unboxed.cmo typing/typedecl_immediacy.cmo \
   typing/typedecl_separability.cmo \
+  lambda/debuginfo.cmo lambda/lambda.cmo \
   typing/typedecl.cmo typing/typeopt.cmo \
   typing/rec_check.cmo typing/typecore.cmo typing/typeclass.cmo \
   typing/typemod.cmo
 TYPING_CMI=\
   typing/annot.cmi \
   typing/outcometree.cmi
 
-LAMBDA=lambda/debuginfo.cmo \
-  lambda/lambda.cmo lambda/printlambda.cmo \
+LAMBDA=lambda/printlambda.cmo \
   lambda/switch.cmo lambda/matching.cmo \
   lambda/translobj.cmo lambda/translattribute.cmo \
   lambda/translprim.cmo lambda/translcore.cmo \

lambda/lambda.ml

@@ -155,6 +155,7 @@ and float_comparison =
 
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+  | Pblock of { tag : int; fields : value_kind list }
 
 and block_shape =
   value_kind list option
@@ -199,13 +200,17 @@ let equal_primitive =
      than 100 constructors... *)
   (=)
 
-let equal_value_kind x y =
+let rec equal_value_kind x y =
   match x, y with
   | Pgenval, Pgenval -> true
   | Pfloatval, Pfloatval -> true
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
   | Pintval, Pintval -> true
-  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false
+  | Pblock { tag = tag1; fields = fields1 },
+    Pblock { tag = tag2; fields = fields2 } ->
+    tag1 = tag2 && List.length fields1 = List.length fields2 &&
+    List.for_all2 equal_value_kind fields1 fields2
+  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pblock _), _ -> false
 
 
 type structured_constant =

lambda/lambda.mli

@@ -167,6 +167,7 @@ and array_kind =
 
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+  | Pblock of { tag : int; fields : value_kind list }
 
 and block_shape =
   value_kind list option

lambda/printlambda.ml

@@ -59,23 +59,45 @@ let boxed_integer_name = function
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
-let value_kind ppf = function
+let rec value_kind ppf = function
   | Pgenval -> ()
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
+  | Pblock { tag; fields } ->
+    fprintf ppf "[%d: %a]" tag
+      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+        value_kind') fields
+
+and value_kind' ppf = function
+  | Pgenval -> fprintf ppf "*"
+  | Pintval -> fprintf ppf "[int]"
+  | Pfloatval -> fprintf ppf "[float]"
+  | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
+  | Pblock { tag; fields } ->
+    fprintf ppf "[%d: %a]" tag
+      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+        value_kind') fields
 
 let return_kind ppf = function
   | Pgenval -> ()
   | Pintval -> fprintf ppf ": int@ "
   | Pfloatval -> fprintf ppf ": float@ "
   | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi)
+  | Pblock { tag; fields } ->
+    fprintf ppf ": [%d: %a]@ " tag
+      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+        value_kind') fields
 
-let field_kind = function
-  | Pgenval -> "*"
-  | Pintval -> "int"
-  | Pfloatval -> "float"
-  | Pboxedintval bi -> boxed_integer_name bi
+let field_kind ppf = function
+  | Pgenval -> pp_print_string ppf "*"
+  | Pintval -> pp_print_string ppf "int"
+  | Pfloatval -> pp_print_string ppf "float"
+  | Pboxedintval bi -> pp_print_string ppf (boxed_integer_name bi)
+  | Pblock { tag; fields } ->
+    fprintf ppf "[%d: %a]" tag
+      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+        value_kind') fields
 
 let print_boxed_integer_conversion ppf bi1 bi2 =
   fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
@@ -124,11 +146,11 @@ let block_shape ppf shape = match shape with
   | None | Some [] -> ()
   | Some l when List.for_all ((=) Pgenval) l -> ()
   | Some [elt] ->
-      Format.fprintf ppf " (%s)" (field_kind elt)
+      Format.fprintf ppf " (%a)" field_kind elt
   | Some (h :: t) ->
-      Format.fprintf ppf " (%s" (field_kind h);
+      Format.fprintf ppf " (%a" field_kind h;
       List.iter (fun elt ->
-          Format.fprintf ppf ",%s" (field_kind elt))
+          Format.fprintf ppf ",%a" field_kind elt)
         t;
       Format.fprintf ppf ")"
 

lambda/printlambda.mli

@@ -25,6 +25,7 @@ val program: formatter -> program -> unit
 val primitive: formatter -> primitive -> unit
 val name_of_primitive : primitive -> string
 val value_kind : formatter -> value_kind -> unit
+val value_kind' : formatter -> value_kind -> unit
 val block_shape : formatter -> value_kind list option -> unit
 val record_rep : formatter -> Types.record_representation -> unit
 val print_bigarray :

middle_end/clambda_primitives.ml

@@ -131,6 +131,7 @@ and array_kind = Lambda.array_kind =
 and value_kind = Lambda.value_kind =
   (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+  | Pblock of { tag : int; fields : value_kind list }
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =

middle_end/clambda_primitives.mli

@@ -134,6 +134,7 @@ and array_kind = Lambda.array_kind =
 and value_kind = Lambda.value_kind =
   (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+  | Pblock of { tag : int; fields : value_kind list }
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =

middle_end/printclambda.ml

@@ -34,6 +34,10 @@ let value_kind =
   | Pboxedintval Pnativeint -> ":nativeint"
   | Pboxedintval Pint32 -> ":int32"
   | Pboxedintval Pint64 -> ":int64"
+  | Pblock { tag; fields } ->
+    asprintf ":[%d: %a]" tag
+      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+         Printlambda.value_kind') fields
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x

testsuite/tests/basic-modules/anonymous.ocamlc.reference

@@ -1,23 +1,24 @@
 (setglobal Anonymous!
-  (seq (ignore (let (x = [0: 13 37]) (makeblock 0 x)))
+  (seq (ignore (let (x =[0: [int], [int]] [0: 13 37]) (makeblock 0 x)))
     (let
       (A =
          (apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 25 6]
            [0: [0]])
        B =
          (apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 35 6]
            [0: [0]]))
-      (seq (ignore (let (x = [0: 4 2]) (makeblock 0 x)))
+      (seq (ignore (let (x =[0: [int], [int]] [0: 4 2]) (makeblock 0 x)))
         (apply (field 1 (global CamlinternalMod!)) [0: [0]] A
           (module-defn(A) Anonymous anonymous.ml(23):567-608 A))
         (apply (field 1 (global CamlinternalMod!)) [0: [0]] B
           (module-defn(B) Anonymous anonymous.ml(33):703-773
-            (let (x = [0: "foo" "bar"]) (makeblock 0))))
-        (let (f = (function param 0) s = (makemutable 0 ""))
+            (let (x =[0: *, *] [0: "foo" "bar"]) (makeblock 0))))
+        (let (f = (function param : int 0) s = (makemutable 0 ""))
           (seq
             (ignore
               (let (*match* = (setfield_ptr 0 s "Hello World!"))
                 (makeblock 0)))
             (let
-              (drop = (function param 0) *match* = (apply drop (field 0 s)))
+              (drop = (function param : int 0)
+               *match* = (apply drop (field 0 s)))
               (makeblock 0 A B f s drop))))))))

testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference

@@ -1,20 +1,22 @@
-(seq (ignore (let (x = [0: 13 37]) (makeblock 0 x)))
+(seq (ignore (let (x =[0: [int], [int]] [0: 13 37]) (makeblock 0 x)))
   (let
     (A =
        (apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 25 6]
          [0: [0]])
      B =
        (apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 35 6]
          [0: [0]]))
-    (seq (ignore (let (x = [0: 4 2]) (makeblock 0 x)))
+    (seq (ignore (let (x =[0: [int], [int]] [0: 4 2]) (makeblock 0 x)))
       (apply (field 1 (global CamlinternalMod!)) [0: [0]] A
         (module-defn(A) Anonymous anonymous.ml(23):567-608 A))
       (apply (field 1 (global CamlinternalMod!)) [0: [0]] B
         (module-defn(B) Anonymous anonymous.ml(33):703-773
-          (let (x = [0: "foo" "bar"]) (makeblock 0))))
-      (let (f = (function param 0) s = (makemutable 0 ""))
+          (let (x =[0: *, *] [0: "foo" "bar"]) (makeblock 0))))
+      (let (f = (function param : int 0) s = (makemutable 0 ""))
         (seq
           (ignore
             (let (*match* = (setfield_ptr 0 s "Hello World!")) (makeblock 0)))
-          (let (drop = (function param 0) *match* = (apply drop (field 0 s)))
+          (let
+            (drop = (function param : int 0)
+             *match* = (apply drop (field 0 s)))
             (makeblock 0 A B f s drop)))))))

testsuite/tests/basic-modules/anonymous.ocamlopt.reference

@@ -1,18 +1,18 @@
-(seq (ignore (let (x = [0: 13 37]) (makeblock 0 x)))
+(seq (ignore (let (x =[0: [int], [int]] [0: 13 37]) (makeblock 0 x)))
   (let
     (A =
        (apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 25 6]
          [0: [0]])
      B =
        (apply (field 0 (global CamlinternalMod!)) [0: "anonymous.ml" 35 6]
          [0: [0]]))
-    (seq (ignore (let (x = [0: 4 2]) (makeblock 0 x)))
+    (seq (ignore (let (x =[0: [int], [int]] [0: 4 2]) (makeblock 0 x)))
       (apply (field 1 (global CamlinternalMod!)) [0: [0]] A A)
       (apply (field 1 (global CamlinternalMod!)) [0: [0]] B
-        (let (x = [0: "foo" "bar"]) (makeblock 0)))
+        (let (x =[0: *, *] [0: "foo" "bar"]) (makeblock 0)))
       (setfield_ptr(root-init) 0 (global Anonymous!) A)
       (setfield_ptr(root-init) 1 (global Anonymous!) B)
-      (let (f = (function param 0))
+      (let (f = (function param : int 0))
         (setfield_ptr(root-init) 2 (global Anonymous!) f))
       (let (s = (makemutable 0 ""))
         (setfield_ptr(root-init) 3 (global Anonymous!) s))
@@ -21,7 +21,7 @@
           (*match* =
              (setfield_ptr 0 (field 3 (global Anonymous!)) "Hello World!"))
           (makeblock 0)))
-      (let (drop = (function param 0))
+      (let (drop = (function param : int 0))
         (setfield_ptr(root-init) 4 (global Anonymous!) drop))
       (let
         (*match* =

testsuite/tests/basic/patmatch_for_multiple.ml

@@ -54,6 +54,6 @@ match (3, 2, 1) with
                *match*/103 =a (field 1 *match*/99))
               (exit 5 *match*/99)))))
      with (6) 0)
-   with (5 x/94) (seq (ignore x/94) 1)))
+   with (5 x/94[0: [int], [int], [int]]) (seq (ignore x/94) 1)))
 - : bool = false
 |}];;

testsuite/tests/basic/patmatch_split_no_or.ml

@@ -16,7 +16,7 @@ let last_is_anys = function
 [%%expect{|
 (let
   (last_is_anys/10 =
-     (function param/12 : int
+     (function param/12[0: [int], [int]] : int
        (catch
          (if (field 0 param/12) (if (field 1 param/12) (exit 1) 1)
            (if (field 1 param/12) (exit 1) 2))
@@ -33,7 +33,7 @@ let last_is_vars = function
 [%%expect{|
 (let
   (last_is_vars/17 =
-     (function param/21 : int
+     (function param/21[0: [int], [int]] : int
        (catch
          (if (field 0 param/21) (if (field 1 param/21) (exit 3) 1)
            (if (field 1 param/21) (exit 3) 2))
@@ -75,7 +75,7 @@ let f = function
    B/26 = (apply (field 0 (global Toploop!)) "B/26")
    A/25 = (apply (field 0 (global Toploop!)) "A/25")
    f/28 =
-     (function param/30 : int
+     (function param/30[0: *, [int], [int]] : int
        (let (*match*/31 =a (field 0 param/30))
          (catch
            (if (== *match*/31 A/25) (if (field 1 param/30) 1 (exit 8))

testsuite/tests/translprim/array_spec.compilers.flat.reference

@@ -11,10 +11,11 @@
       (array.unsafe_get[addr] addr_a 0)
       (function a (array.unsafe_get[gen] a 0)) (array.set[int] int_a 0 1)
       (array.set[float] float_a 0 1.) (array.set[addr] addr_a 0 "a")
-      (function a x (array.set[gen] a 0 x)) (array.unsafe_set[int] int_a 0 1)
+      (function a x : int (array.set[gen] a 0 x))
+      (array.unsafe_set[int] int_a 0 1)
       (array.unsafe_set[float] float_a 0 1.)
       (array.unsafe_set[addr] addr_a 0 "a")
-      (function a x (array.unsafe_set[gen] a 0 x))
+      (function a x : int (array.unsafe_set[gen] a 0 x))
       (let
         (eta_gen_len = (function prim stub (array.length[gen] prim))
          eta_gen_safe_get =