Merge flambda-backend changes

asmcomp/cmm_helpers.ml

@@ -2002,7 +2002,7 @@ let send_function (arity, mode) =
   let cache = cache in
   let fun_name = send_function_name arity mode in
   let fun_args =
-    [obj, typ_val; tag, typ_int; cache, typ_val]
+    [obj, typ_val; tag, typ_int; cache, typ_addr]
     @ List.map (fun id -> (id, typ_val)) (List.tl args) in
   let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
   Cfunction

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,10 @@ 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 {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+    }
   | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape

middle_end/clambda_primitives.mli

@@ -138,7 +138,10 @@ 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 {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+    }
   | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape

middle_end/printclambda.ml

@@ -24,23 +24,33 @@ let mutable_flag = function
   | Lambda.Mutable-> "[mut]"
   | Lambda.Immutable | Lambda.Immutable_unique -> ""
 
-let value_kind =
+let rec value_kind0 ppf kind =
   let open Lambda in
-  function
-  | Pgenval -> ""
-  | Pintval -> ":int"
-  | Pfloatval -> ":float"
-  | Parrayval Pgenarray -> ":genarray"
-  | Parrayval Pintarray -> ":intarray"
-  | Parrayval Pfloatarray -> ":floatarray"
-  | Parrayval Paddrarray -> ":addrarray"
-  | 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
+  match kind with
+  | Pgenval -> Format.pp_print_string ppf ""
+  | Pintval -> Format.pp_print_string ppf ":int"
+  | Pfloatval -> Format.pp_print_string ppf ":float"
+  | Parrayval Pgenarray -> Format.pp_print_string ppf ":genarray"
+  | Parrayval Pintarray -> Format.pp_print_string ppf ":intarray"
+  | Parrayval Pfloatarray -> Format.pp_print_string ppf ":floatarray"
+  | Parrayval Paddrarray -> Format.pp_print_string ppf ":addrarray"
+  | Pboxedintval Pnativeint -> Format.pp_print_string ppf ":nativeint"
+  | Pboxedintval Pint32 -> Format.pp_print_string ppf ":int32"
+  | Pboxedintval Pint64 -> Format.pp_print_string ppf ":int64"
+  | Pvariant { consts; non_consts } ->
+    Format.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_kind0)
+              fields))
+      non_consts
+
+let value_kind kind = Format.asprintf "%a" value_kind0 kind
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x

runtime/bigarray.c

@@ -89,31 +89,31 @@ CAMLexport value
 caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
 {
   uintnat num_elts, asize, size;
-  int i, is_managed;
+  int i;
   value res;
   struct caml_ba_array * b;
   intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
 
   CAMLassert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
   CAMLassert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
   for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
-  num_elts = 1;
-  for (i = 0; i < num_dims; i++) {
-    if (caml_umul_overflow(num_elts, dimcopy[i], &num_elts))
-      caml_raise_out_of_memory();
-  }
-  if (caml_umul_overflow(num_elts,
-                         caml_ba_element_size[flags & CAML_BA_KIND_MASK],
-                         &size))
-    caml_raise_out_of_memory();
+  size = 0;
   if (data == NULL) {
+    num_elts = 1;
+    for (i = 0; i < num_dims; i++) {
+      if (caml_umul_overflow(num_elts, dimcopy[i], &num_elts))
+        caml_raise_out_of_memory();
+    }
+    if (caml_umul_overflow(num_elts,
+                           caml_ba_element_size[flags & CAML_BA_KIND_MASK],
+                           &size))
+      caml_raise_out_of_memory();
     data = malloc(size);
     if (data == NULL && size != 0) caml_raise_out_of_memory();
     flags |= CAML_BA_MANAGED;
   }
   asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
-  is_managed = ((flags & CAML_BA_MANAGED_MASK) == CAML_BA_MANAGED);
-  res = caml_alloc_custom_mem(&caml_ba_ops, asize, is_managed ? size : 0);
+  res = caml_alloc_custom_mem(&caml_ba_ops, asize, size);
   b = Caml_ba_array_val(res);
   b->data = data;
   b->num_dims = num_dims;

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
 |}];;