flambda-backend: Check that layout variables aren't unconstrained whe…

…n writing `cmi`s (#1474)

* Working implementation of check

* Fix bug where GADT constructors of extensible variant decls weren't getting defaulted

* Cleanup: rename and comment things; CR places of confusion

* Flatten a variant created in the hot path

* Use global ref instead of passing [loc] through the hot path of [typexp]

* Respond to review comments

testsuite/tests/typing-layouts-gadt-sort-var/extract_extensible.ml

@@ -0,0 +1,6 @@
+(* Disable warning 8 as it's unrelated to this test: It's the inexhaustive
+   match warning when you don't have a wildcard case for extensible variants.
+*)
+let[@ocaml.warning "-8"] f (Gadt_extensible.Mk (produce, consume)) =
+  let (surely_is_a_value, _) = (produce (), 5) in
+  consume surely_is_a_value

testsuite/tests/typing-layouts-gadt-sort-var/gadt_extensible.ml

@@ -0,0 +1,4 @@
+type t_ext = ..
+
+type t_ext +=
+| Mk : (unit -> 'a) * ('a -> unit) -> t_ext

testsuite/tests/typing-layouts-gadt-sort-var/insert_extensible.ml

@@ -0,0 +1,5 @@
+type t_void [@@void]
+
+let rec g (_ : t_void) = ()
+
+and packed = Gadt_extensible.Mk ((fun _ -> assert false), g)

testsuite/tests/typing-layouts-gadt-sort-var/test_extensible.compilers.reference

@@ -0,0 +1,6 @@
+File "insert_extensible.ml", line 5, characters 58-59:
+5 | and packed = Gadt_extensible.Mk ((fun _ -> assert false), g)
+                                                              ^
+Error: This expression has type t_void -> unit
+       but an expression was expected of type 'a -> unit
+       t_void has layout void, which is not a sublayout of value.

testsuite/tests/typing-layouts-gadt-sort-var/test_extensible.ml

@@ -0,0 +1,14 @@
+(* TEST
+
+   readonly_files = "gadt_extensible.ml insert_extensible.ml extract_extensible.ml"
+   flags = "-extension layouts_alpha"
+   * setup-ocamlc.byte-build-env
+   ** ocamlc.byte
+   module = "gadt_extensible.ml"
+   *** ocamlc.byte
+   module = "extract_extensible.ml"
+   **** ocamlc.byte
+   module = "insert_extensible.ml"
+   ocamlc_byte_exit_status = "2"
+   ***** check-ocamlc.byte-output
+*)

typing/ctype.ml

@@ -655,8 +655,14 @@ let closed_extension_constructor ext =
   try
     List.iter mark_type ext.ext_type_params;
     begin match ext.ext_ret_type with
-    | Some _ -> ()
-    | None -> iter_type_expr_cstr_args closed_type ext.ext_args
+    | Some res_ty ->
+        (* gadts cannot have free type variables, but they might
+           have undefaulted layout variables; these lines default
+           them. Test case: typing-layouts-gadt-sort-var/test_extensible.ml *)
+        iter_type_expr_cstr_args remove_mode_and_layout_variables ext.ext_args;
+        remove_mode_and_layout_variables res_ty
+    | None ->
+        iter_type_expr_cstr_args closed_type ext.ext_args
     end;
     unmark_extension_constructor ext;
     None

typing/env.ml

@@ -2654,9 +2654,10 @@ let persistent_structures_of_dir dir =
 (* Save a signature to a file *)
 let save_signature_with_transform cmi_transform ~alerts sg modname filename =
   Btype.cleanup_abbrev ();
-  Subst.reset_for_saving ();
+  Subst.reset_additional_action_type_id ();
   let sg = Subst.Lazy.of_signature sg
-    |> Subst.Lazy.signature Make_local (Subst.for_saving Subst.identity)
+    |> Subst.Lazy.signature Make_local
+        (Subst.with_additional_action Prepare_for_saving Subst.identity)
   in
   let cmi =
     Persistent_env.make_cmi !persistent_env modname sg alerts

typing/layouts.ml

@@ -64,7 +64,21 @@ module Sort = struct
           if result != s then r := Some result; (* path compression *)
           result
         end
-    end
+      end
+
+  (* This is constant-time if [var] was just returned from a previous call to
+     [get]. That's because [var] will always be [None] in that case.
+  *)
+  let var_constraint : var -> const option = fun r ->
+    match !r with
+    | None -> None
+    | Some t -> begin
+        match get t with
+        | Const const -> Some const
+        | Var { contents = None } -> None
+        | Var _ ->
+            Misc.fatal_error "[get] should return [Const _] or [Var None]"
+      end
 
   let default_value : t option = Some (Const Value)
   let default_void : t option = Some (Const Void)

typing/layouts.mli

@@ -28,6 +28,11 @@ module Sort : sig
   (** A sort variable that can be unified during type-checking. *)
   type var
 
+  (** Return the concrete constraint placed on the variable. This check is
+      constant-time if [var] was just returned from [Layout.get].
+  *)
+  val var_constraint : var -> const option
+
   (** Create a new sort variable that can be unified. *)
   val new_var : unit -> t