flambda-backend: Use layout histories to produce better errors (#1340)

* Add layout histories

While disabled for now, these histories will allow
for us to include nice information in error messages.

This commit also includes code to common up layouts
when saving a cmi.

* bootstrap; fix errors

Author: goldfirere

boot/ocamlc

@@ -112,7 +112,7 @@ let match_printer_type desc typename =
         raise (Error(Unbound_identifier(Ldot(Lident "Topdirs", typename))))
   in
   Ctype.begin_def();
-  let ty_arg = Ctype.newvar Layout.any in
+  let ty_arg = Ctype.newvar Layout.(value ~why:Debug_printer_argument) in
   Ctype.unify Env.initial_safe_string
     (Ctype.newconstr printer_type [ty_arg])
     (Ctype.instance desc.val_type);

boot/ocamllex

@@ -100,7 +100,7 @@ open Printpat
 module Scoped_location = Debuginfo.Scoped_location
 
 type error =
-    Non_value_layout of Layout.Violation.violation
+    Non_value_layout of Layout.Violation.t
 
 exception Error of Location.t * error
 
@@ -109,8 +109,8 @@ let dbg = false
 (* CR layouts v2: When we're ready to allow non-values, these can be deleted or
    changed to check for void. *)
 let layout_must_be_value loc layout =
-  match Layout.(sub layout value) with
-  | Ok () -> ()
+  match Layout.(sub layout (value ~why:V1_safety_check)) with
+  | Ok _ -> ()
   | Error e -> raise (Error (loc, Non_value_layout e))
 
 (*

debugger/loadprinter.ml

@@ -31,22 +31,24 @@ type error =
     Free_super_var
   | Unreachable_reached
   | Bad_probe_layout of Ident.t
-  | Non_value_layout of Layout.Violation.violation
+  | Non_value_layout of Layout.Violation.t
 
 exception Error of Location.t * error
 
 let use_dup_for_constant_mutable_arrays_bigger_than = 4
 
 (* CR layouts v2: When we're ready to allow non-values, these can be deleted or
    changed to check for void. *)
-let sort_must_be_value loc sort =
+let sort_must_be_value ~why loc sort =
   if not Sort.(equate sort value) then
-    let violation = Layout.(Violation.not_a_sublayout (of_sort sort) value) in
+    let violation = Layout.(Violation.of_ (Not_a_sublayout
+                                             (of_sort ~why sort,
+                                              value ~why:V1_safety_check))) in
     raise (Error (loc, Non_value_layout violation))
 
 let layout_must_be_value loc layout =
-  match Layout.(sub layout value) with
-  | Ok () -> ()
+  match Layout.(sub layout (value ~why:V1_safety_check)) with
+  | Ok _ -> ()
   | Error e -> raise (Error (loc, Non_value_layout e))
 
 (* CR layouts v2: In the places where this is used, we want to allow any (the
@@ -61,9 +63,10 @@ let layout_must_be_value loc layout =
 *)
 let layout_must_not_be_void loc layout =
   Layout.default_to_value layout;
-  match Layout.(sub layout void) with
-  | Ok () ->
-    let violation = Layout.(Violation.not_a_sublayout layout value) in
+  match Layout.(sub layout (void ~why:V1_safety_check)) with
+  | Ok _ ->
+     let violation = Layout.(Violation.of_ (Not_a_sublayout
+                               (layout, value ~why:V1_safety_check))) in
     raise (Error (loc, Non_value_layout violation))
   | Error _ -> ()
 
@@ -907,8 +910,9 @@ and transl_exp0 ~in_new_scope ~scopes e =
         with
         | {val_type; _} -> begin
             match
-              Ctype.check_type_layout ~reason:(Fixed_layout Probe)
-                e.exp_env (Ctype.correct_levels val_type) Layout.value
+              Ctype.check_type_layout
+                e.exp_env (Ctype.correct_levels val_type)
+                (Layout.value ~why:Probe)
             with
             | Ok _ -> ()
             | Error _ -> raise (Error (e.exp_loc, Bad_probe_layout id))
@@ -1354,7 +1358,7 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false)
         :: rem ->
           (* CR layouts v2: allow non-values.  Either remove this or replace
              with void-specific sanity check. *)
-          sort_must_be_value expr.exp_loc sort;
+          sort_must_be_value ~why:Let_binding expr.exp_loc sort;
           let lam = transl_bound_exp ~scopes ~in_structure pat expr in
           let lam = Translattribute.add_function_attributes lam vb_loc attr in
           let lam = if add_regions then maybe_region_exp expr lam else lam in
@@ -1374,7 +1378,7 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false)
             {vb_expr=expr; vb_sort; vb_attributes; vb_loc; vb_pat} id =
         (* CR layouts v2: allow non-values.  Either remove this or replace
            with void-specific sanity check. *)
-        sort_must_be_value expr.exp_loc vb_sort;
+        sort_must_be_value ~why:Let_binding expr.exp_loc vb_sort;
         let lam = transl_bound_exp ~scopes ~in_structure vb_pat expr in
         let lam =
           Translattribute.add_function_attributes lam vb_loc vb_attributes

lambda/matching.ml

@@ -50,7 +50,7 @@ type error =
     Free_super_var
   | Unreachable_reached
   | Bad_probe_layout of Ident.t
-  | Non_value_layout of Layouts.Layout.Violation.violation
+  | Non_value_layout of Layouts.Layout.Violation.t
 
 exception Error of Location.t * error
 

lambda/translcore.ml

@@ -39,7 +39,7 @@ type unsafe_info =
 type error =
   Circular_dependency of (Ident.t * unsafe_info) list
 | Conflicting_inline_attributes
-| Non_value_layout of type_expr * Layout.Violation.violation
+| Non_value_layout of type_expr * Layout.Violation.t
 
 exception Error of Location.t * error
 
@@ -55,9 +55,13 @@ exception Error of Location.t * error
    When this sanity check is removed, consider whether it must be replaced with
    some defaulting. *)
 let sort_must_not_be_void loc ty sort =
-  let layout = Layout.of_sort sort in
-  if Layout.is_void layout then
-    let violation = Layout.(Violation.not_a_sublayout layout value) in
+  if Sort.is_void_defaulting sort then
+    let violation =
+      Layout.(Violation.of_
+                (Not_a_sublayout
+                   (Layout.of_sort ~why:V1_safety_check sort,
+                    value ~why:V1_safety_check)))
+    in
     raise (Error (loc, Non_value_layout (ty, violation)))
 
 let cons_opt x_opt xs =

lambda/translcore.mli

@@ -53,7 +53,7 @@ type unsafe_info =
 type error =
   Circular_dependency of (Ident.t * unsafe_info) list
 | Conflicting_inline_attributes
-| Non_value_layout of Types.type_expr * Layouts.Layout.Violation.violation
+| Non_value_layout of Types.type_expr * Layouts.Layout.Violation.t
 
 exception Error of Location.t * error
 

lambda/translmod.ml

@@ -417,7 +417,7 @@ module Analyser =
           { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
         get_field env comments @@
         {Types.ld_id; ld_mutable; ld_global = Unrestricted;
-         ld_layout=Layout.any (* ignored *);
+         ld_layout=Layout.any ~why:Dummy_layout (* ignored *);
          ld_type=ld_type.Typedtree.ctyp_type;
          ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
       let open Typedtree in

lambda/translmod.mli

@@ -424,7 +424,8 @@ let explicit_arity attrs =
 let layout ~legacy_immediate attrs =
   let layout =
     List.find_map
-      (fun a -> match a.attr_name.txt with
+      (fun a ->
+         match a.attr_name.txt with
          | "ocaml.void"|"void" -> Some (a, Void)
          | "ocaml.value"|"value" -> Some (a, Value)
          | "ocaml.any"|"any" -> Some (a, Any)
@@ -435,21 +436,22 @@ let layout ~legacy_immediate attrs =
   in
   match layout with
   | None -> Ok None
-  | Some (a, Value) ->
-    mark_used a.attr_name;
-    Ok (Some Value)
-  | Some (a, (Immediate | Immediate64 as l)) ->
-    mark_used a.attr_name;
-    if   legacy_immediate
-      || Language_extension.(   is_enabled (Layouts Beta)
-                             || is_enabled (Layouts Alpha))
-    then Ok (Some l)
-    else Error (a.attr_loc, l)
-  | Some (a, (Any | Void as l)) ->
-    mark_used a.attr_name;
-    if Language_extension.is_enabled (Layouts Alpha)
-    then Ok (Some l)
-    else Error (a.attr_loc, l)
+  | Some (a, l) ->
+     mark_used a.attr_name;
+     let l_loc = Location.mkloc l a.attr_loc in
+     let check b =
+       if b
+       then Ok (Some l_loc)
+       else Error l_loc
+     in
+     match l with
+     | Value -> check true
+     | Immediate | Immediate64 ->
+        check  (legacy_immediate
+             || Language_extension.(   is_enabled (Layouts Beta)
+                                    || is_enabled (Layouts Alpha)))
+     | Any | Void ->
+        check (Language_extension.is_enabled (Layouts Alpha))
 
 (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
    attributes cannot be input by the user, they are added by the

ocamldoc/odoc_sig.ml

@@ -199,4 +199,5 @@ val tailcall : Parsetree.attributes ->
 (* CR layouts: we should eventually be able to delete ~legacy_immediate (after we
    turn on layouts by default). *)
 val layout : legacy_immediate:bool -> Parsetree.attributes ->
-  (Asttypes.const_layout option, Location.t * Asttypes.const_layout) result
+  (Asttypes.const_layout Location.loc option,
+   Asttypes.const_layout Location.loc) result

parsing/builtin_attributes.ml

@@ -82,6 +82,7 @@ type 'a loc = {
 
 let mkloc txt loc = { txt ; loc }
 let mknoloc txt = mkloc txt none
+let get_txt { txt } = txt
 
 (******************************************************************************)
 (* Input info *)

parsing/builtin_attributes.mli

@@ -90,7 +90,7 @@ type 'a loc = {
 
 val mknoloc : 'a -> 'a loc
 val mkloc : 'a -> t -> 'a loc
-
+val get_txt : 'a loc -> 'a
 
 (** {1 Input info} *)
 

parsing/location.ml

@@ -45,7 +45,10 @@ Line 1, characters 12-19:
                 ^^^^^^^
 Error: This type B.b_value = A.a_value should be an instance of type
          ('a : immediate)
-       B.b_value has layout value, which is not a sublayout of immediate.
+       B.b_value has an unknown layout,
+         which might not be a sublayout of immediate.
+       No .cmi file found containing A.a_value.
+       Hint: Adding "a" to your dependencies might help.
 |}];;
 
 (* type err2 = b_void value_arg;;

parsing/location.mli

@@ -299,3 +299,9 @@ Error: Layout void is used here, but the appropriate layouts extension is not en
 
 (* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
    sort.  Bring back here when we have one enabled by default. *)
+
+(**************************************************)
+(* Test 31: checking that #poly_var patterns work *)
+
+(* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one enabled by default. *)

testsuite/tests/typing-layouts-missing-cmi/c.ml

@@ -1443,3 +1443,22 @@ Error: This expression has type t_void but an expression was expected of type
          ('a : value)
        t_void has layout void, which is not a sublayout of value.
 |}]
+
+(**************************************************)
+(* Test 31: checking that #poly_var patterns work *)
+
+type ('a : void) poly_var = [`A of int * 'a | `B]
+
+let f #poly_var = "hello"
+
+[%%expect{|
+Line 1, characters 41-43:
+1 | type ('a : void) poly_var = [`A of int * 'a | `B]
+                                             ^^
+Error: This type ('a : value) should be an instance of type ('a0 : void)
+       'a has layout void, which does not overlap with value.
+|}]
+(* CR layouts bug: this should be accepted (or maybe we should reject
+   the type definition if we're not allowing `void` things in structures).
+   This bug is a goof at the top of Typecore.build_or_pat;
+   there is another CR layouts there. *)

testsuite/tests/typing-layouts/basics.ml

@@ -448,7 +448,7 @@ val f18 : 'a -> 'a = <fun>
 (* Test 22: approx_type catch-all can't be restricted to value *)
 
 (* CR layouts: This test moved to [basics_alpha.ml] as it needs a non-value
-   sort.  Bring back here when we have one enabled by default. *)
+   sort.  Bring back here when we have one. *)
 
 type t_void [@@void];;
 [%%expect{|
@@ -505,3 +505,9 @@ Error: Layout void is used here, but the appropriate layouts extension is not en
 
 (* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a non-value
    sort.  Bring back here when we have one. *)
+
+(**************************************************)
+(* Test 31: checking that #poly_var patterns work *)
+
+(* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value
+   sort.  Bring back here when we have one. *)

testsuite/tests/typing-layouts/basics_alpha.ml

@@ -3,6 +3,6 @@ File "baz.ml", line 1, characters 8-18:
             ^^^^^^^^^^
 Error: This expression has type 'a Foo.t
        but an expression was expected of type ('b : '_representable_layout_1)
-       'a Foo.t has layout any, which is not representable.
+       'a Foo.t has an unknown layout, which might not be representable.
        No .cmi file found containing Foo.t.
        Hint: Adding "foo" to your dependencies might help.

testsuite/tests/typing-layouts/basics_beta.ml

@@ -2,6 +2,6 @@ File "client.ml", line 2, characters 0-19:
 2 | and alias = missing
     ^^^^^^^^^^^^^^^^^^^
 Error: 
-       alias has layout any, which is not a sublayout of value.
+       alias has an unknown layout, which might not be a sublayout of value.
        No .cmi file found containing Missing.t.
        Hint: Adding "missing" to your dependencies might help.

testsuite/tests/typing-missing-cmi-2/test.compilers.reference

@@ -3,6 +3,6 @@ File "main.ml", line 1, characters 8-11:
             ^^^
 Error: This expression has type M.a but an expression was expected of type
          ('a : value)
-       M.a has layout any, which is not a sublayout of value.
+       M.a has an unknown layout, which might not be a sublayout of value.
        No .cmi file found containing M.a.
        Hint: Adding "m" to your dependencies might help.

testsuite/tests/typing-missing-cmi-indirections/test.compilers.reference

@@ -427,7 +427,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                             List.mapi
                               (fun i ty_arg ->
                                  (ty_arg,
-                                  Layout.(equal void cstr_arg_layouts.(i)))
+                                  Layout.is_void_defaulting cstr_arg_layouts.(i))
                               ) ty_args
                           in
                           tree_of_constr_with_args (tree_of_constr env path)
@@ -511,7 +511,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
               let name = Ident.name ld_id in
               (* PR#5722: print full module path only
                  for first record field *)
-              let is_void = Layout.(equal void ld_layout) in
+              let is_void = Layout.is_void_defaulting ld_layout in
               let lid =
                 if first then tree_of_label env path (Out_name.create name)
                 else Oide_ident (Out_name.create name)
@@ -616,7 +616,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         in
         let args = instantiate_types env type_params ty_list cstr.cstr_args in
         let args = List.mapi (fun i arg ->
-            (arg, Layout.(equal void cstr.cstr_arg_layouts.(i))))
+            (arg, Layout.is_void_defaulting cstr.cstr_arg_layouts.(i)))
             args
         in
         tree_of_constr_with_args

testsuite/tests/typing-missing-cmi/test.compilers.reference

@@ -233,7 +233,7 @@ let printer_type ppf typename =
 
 let match_simple_printer_type desc printer_type =
   Ctype.begin_def();
-  let ty_arg = Ctype.newvar Layout.value in
+  let ty_arg = Ctype.newvar (Layout.value ~why:Debug_printer_argument) in
   begin try
     Ctype.unify !toplevel_env
       (Ctype.newconstr printer_type [ty_arg])
@@ -247,7 +247,10 @@ let match_simple_printer_type desc printer_type =
 
 let match_generic_printer_type desc path args printer_type =
   Ctype.begin_def();
-  let args = List.map (fun _ -> Ctype.newvar Layout.value) args in
+  let args = List.map
+               (fun _ -> Ctype.newvar
+                           (Layout.value ~why:Debug_printer_argument))
+               args in
   let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in
   let ty_args =
     List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in