flambda-backend: Extend Pblock value kind to handle variants (#703)

Author: mshinwell

asmcomp/cmmgen.ml

@@ -711,7 +711,7 @@ and transl_catch env nfail ids body handler dbg =
          let strict =
            match kind with
            | Pfloatval | Pboxedintval _ -> false
-           | Pintval | Pgenval | Pblock _ | Parrayval _ -> true
+           | Pintval | Pgenval | Pvariant _ | Parrayval _ -> true
          in
          u := join_unboxed_number_kind ~strict !u
              (is_unboxed_number_cmm ~strict c)
@@ -1179,7 +1179,7 @@ and transl_let env str kind id exp transl_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 | Pblock _ | Parrayval _) ->
+    | _, (Pgenval | Pvariant _ | Parrayval _) ->
         (* 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

lambda/lambda.ml

@@ -220,7 +220,10 @@ and float_comparison =
 
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-  | Pblock of { tag : int; fields : value_kind list }
+  | Pvariant of {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+    }
   | Parrayval of array_kind
 
 and block_shape =
@@ -273,11 +276,20 @@ let rec equal_value_kind x y =
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
   | Pintval, Pintval -> true
   | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2
-  | 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 _
+  | Pvariant { consts = consts1; non_consts = non_consts1; },
+    Pvariant { consts = consts2; non_consts = non_consts2; } ->
+    let consts1 = List.sort Int.compare consts1 in
+    let consts2 = List.sort Int.compare consts2 in
+    let compare_by_tag (tag1, _) (tag2, _) = Int.compare tag1 tag2 in
+    let non_consts1 = List.sort compare_by_tag non_consts1 in
+    let non_consts2 = List.sort compare_by_tag non_consts2 in
+    List.equal Int.equal consts1 consts2
+      && List.equal (fun (tag1, fields1) (tag2, fields2) ->
+             Int.equal tag1 tag2
+             && List.length fields1 = List.length fields2
+             && List.for_all2 equal_value_kind fields1 fields2)
+           non_consts1 non_consts2
+  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _
       | Parrayval _), _ -> false
 
 

lambda/lambda.mli

@@ -193,7 +193,13 @@ and array_kind =
 
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-  | Pblock of { tag : int; fields : value_kind list }
+  | Pvariant of {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+      (** [non_consts] must be non-empty.  For constant variants [Pintval]
+          must be used.  This causes a small loss of precision but it is not
+          expected to be significant. *)
+    }
   | Parrayval of array_kind
 
 and block_shape =

lambda/printlambda.ml

@@ -63,27 +63,37 @@ let boxed_integer_name = function
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
+let variant_kind print_contents ppf ~consts ~non_consts =
+  fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
+    consts
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space
+      (fun ppf (tag, fields) ->
+        fprintf ppf "@[<hov 1>[%d:@ %a]@]"
+          tag
+          (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+            print_contents)
+          fields
+      ))
+    non_consts
+
 let rec value_kind ppf = function
   | Pgenval -> ()
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | 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
+  | Pvariant { consts; non_consts; } ->
+    variant_kind value_kind' ppf ~consts ~non_consts
 
 and value_kind' ppf = function
   | Pgenval -> fprintf ppf "*"
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | 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
+  | Pvariant { consts; non_consts; } ->
+    variant_kind value_kind' ppf ~consts ~non_consts
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -95,21 +105,27 @@ let return_kind ppf (mode, kind) =
   | Parrayval elt_kind ->
      fprintf ppf ": %s%sarray@ " smode (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf ": %s%s@ " smode (boxed_integer_name bi)
-  | Pblock { tag; fields } ->
-    fprintf ppf ": %s[%d: %a]@ " smode tag
-      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
-        value_kind') fields
+  | Pvariant { consts; non_consts; } ->
+    variant_kind value_kind' ppf ~consts ~non_consts
 
 let field_kind ppf = function
   | Pgenval -> pp_print_string ppf "*"
   | Pintval -> pp_print_string ppf "int"
   | Pfloatval -> pp_print_string ppf "float"
   | Parrayval elt_kind -> fprintf ppf "%s-array" (array_kind elt_kind)
   | 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
+  | Pvariant { consts; non_consts; } ->
+    fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
+      consts
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space
+        (fun ppf (tag, fields) ->
+          fprintf ppf "@[<hov 1>[%d:@ %a]@]"
+            tag
+            (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+              value_kind') fields
+        ))
+      non_consts
 
 let alloc_kind = function
   | Alloc_heap -> ""

lambda/printlambda.mli

@@ -24,6 +24,9 @@ val lambda: formatter -> lambda -> unit
 val program: formatter -> program -> unit
 val primitive: formatter -> primitive -> unit
 val name_of_primitive : primitive -> string
+val variant_kind : (formatter -> value_kind -> unit) ->
+  formatter -> consts:int list -> non_consts:(int * value_kind list) list ->
+  unit
 val value_kind : formatter -> value_kind -> unit
 val value_kind' : formatter -> value_kind -> unit
 val block_shape : formatter -> value_kind list option -> unit

middle_end/clambda_primitives.ml

@@ -135,7 +135,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 }
+  | Pvariant of { tag : int; fields : value_kind list }
   | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape

middle_end/clambda_primitives.mli

@@ -138,7 +138,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 }
+  | Pvariant of { tag : int; fields : value_kind list }
   | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape

middle_end/printclambda.ml

@@ -37,7 +37,7 @@ let value_kind =
   | Pboxedintval Pnativeint -> ":nativeint"
   | Pboxedintval Pint32 -> ":int32"
   | Pboxedintval Pint64 -> ":int64"
-  | Pblock { tag; fields } ->
+  | Pvariant { tag; fields } ->
     asprintf ":[%d: %a]" tag
       (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
          Printlambda.value_kind') fields

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

@@ -1,18 +1,25 @@
 (setglobal Anonymous!
-  (seq (ignore (let (x =[0: [int], [int]] [0: 13 37]) (makeblock 0 x)))
+  (seq
+    (ignore
+      (let (x =[(consts ()) (non_consts ([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: [int], [int]] [0: 4 2]) (makeblock 0 x)))
+      (seq
+        (ignore
+          (let (x =[(consts ()) (non_consts ([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: *, *] [0: "foo" "bar"]) (makeblock 0))))
+            (let (x =[(consts ()) (non_consts ([0: *, *]))] [0: "foo" "bar"])
+              (makeblock 0))))
         (let (f = (function param : int 0) s = (makemutable 0 ""))
           (seq
             (ignore

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

@@ -1,17 +1,24 @@
-(seq (ignore (let (x =[0: [int], [int]] [0: 13 37]) (makeblock 0 x)))
+(seq
+  (ignore
+    (let (x =[(consts ()) (non_consts ([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: [int], [int]] [0: 4 2]) (makeblock 0 x)))
+    (seq
+      (ignore
+        (let (x =[(consts ()) (non_consts ([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: *, *] [0: "foo" "bar"]) (makeblock 0))))
+          (let (x =[(consts ()) (non_consts ([0: *, *]))] [0: "foo" "bar"])
+            (makeblock 0))))
       (let (f = (function param : int 0) s = (makemutable 0 ""))
         (seq
           (ignore

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

@@ -1,15 +1,22 @@
-(seq (ignore (let (x =[0: [int], [int]] [0: 13 37]) (makeblock 0 x)))
+(seq
+  (ignore
+    (let (x =[(consts ()) (non_consts ([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: [int], [int]] [0: 4 2]) (makeblock 0 x)))
+    (seq
+      (ignore
+        (let (x =[(consts ()) (non_consts ([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: *, *] [0: "foo" "bar"]) (makeblock 0)))
+        (let (x =[(consts ()) (non_consts ([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 : int 0))

testsuite/tests/basic/patmatch_for_multiple.ml

@@ -55,6 +55,7 @@ match (3, 2, 1) with
                *match*/283 =a (field 1 *match*/279))
               (exit 5 *match*/279)))))
      with (6) 0)
-   with (5 x/274[0: [int], [int], [int]]) (seq (ignore x/274) 1)))
+   with (5 x/274[(consts ()) (non_consts ([0: [int], [int], [int]]))])
+    (seq (ignore x/274) 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[0: [int], [int]] : int
+     (function param/12[(consts ()) (non_consts ([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[0: [int], [int]] : int
+     (function param/21[(consts ()) (non_consts ([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,8 @@ 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[0: *, [int], [int]] : int
+     (function param/30[(consts ()) (non_consts ([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))