flambda-backend: Fix issue with layout any and Tstr_eval in the native toplevel (#1402)

* Fix issue with layout any and Tstr_eval in the native toplevel

* Add native code top-level fix

* Fix the `ocaml/` version of the toplevel

Author: ccasin

lambda/translmod.ml

@@ -44,14 +44,13 @@ type error =
 exception Error of Location.t * error
 
 (* CR layouts v2: This is used as part of the "void safety check" in the case of
-   `Tstr_eval`, where we want to allow `any` in particular.  Remove when we
-   remove the safety check. *)
-let layout_must_not_be_void loc ty layout =
-  match Layout.(sub layout void) with
-  | Ok () ->
+   [Tstr_eval], where we want to allow any sort (see comment on that case of
+   typemod).  Remove when we remove the safety check. *)
+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
     raise (Error (loc, Non_value_layout (ty, violation)))
-  | Error _ -> ()
 
 let cons_opt x_opt xs =
   match x_opt with
@@ -668,11 +667,11 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
       size
   | item :: rem ->
       match item.str_desc with
-      | Tstr_eval (expr, layout, _) ->
+      | Tstr_eval (expr, sort, _) ->
           let body, size =
             transl_structure ~scopes loc fields cc rootpath final_env rem
           in
-          layout_must_not_be_void expr.exp_loc expr.exp_type layout;
+          sort_must_not_be_void expr.exp_loc expr.exp_type sort;
           Lsequence(transl_exp ~scopes expr, body), size
       | Tstr_value(rec_flag, pat_expr_list) ->
           (* Translate bindings first *)
@@ -1105,8 +1104,8 @@ let transl_store_structure ~scopes glob map prims aliases str =
       Lambda.subst no_env_update subst cont
     | item :: rem ->
         match item.str_desc with
-        | Tstr_eval (expr, layout, _attrs) ->
-            layout_must_not_be_void expr.exp_loc expr.exp_type layout;
+        | Tstr_eval (expr, sort, _attrs) ->
+            sort_must_not_be_void expr.exp_loc expr.exp_type sort;
             Lsequence(Lambda.subst no_env_update subst
                         (transl_exp ~scopes expr),
                       transl_store ~scopes rootpath subst cont rem)
@@ -1501,9 +1500,9 @@ let transl_store_gen ~scopes module_name ({ str_items = str }, restr) topl =
   let f str =
     let expr =
       match str with
-      | [ { str_desc = Tstr_eval (expr, layout, _attrs) } ] when topl ->
+      | [ { str_desc = Tstr_eval (expr, sort, _attrs) } ] when topl ->
         assert (size = 0);
-        layout_must_not_be_void expr.exp_loc expr.exp_type layout;
+        sort_must_not_be_void expr.exp_loc expr.exp_type sort;
         Lambda.subst (fun _ _ env -> env) !transl_store_subst
           (transl_exp ~scopes expr)
       | str ->
@@ -1604,8 +1603,8 @@ let transl_toplevel_item ~scopes item =
        expr", so that Toploop can display the result of the expression.
        Otherwise, the normal compilation would result in a Lsequence returning
        unit. *)
-    Tstr_eval (expr, layout, _) ->
-      layout_must_not_be_void expr.exp_loc expr.exp_type layout;
+    Tstr_eval (expr, sort, _) ->
+      sort_must_not_be_void expr.exp_loc expr.exp_type sort;
       transl_exp ~scopes expr
   | Tstr_value(Nonrecursive,
                [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) ->

testsuite/tests/tool-toplevel/any.ml

@@ -0,0 +1,8 @@
+(* TEST
+   exit_status = "2"
+   * toplevel.opt
+     reference = "${test_source_directory}/any.native.reference"
+*)
+
+(* This checks that things with layout "any" don't cause problems in [Tstr_eval] *)
+assert false;;

testsuite/tests/tool-toplevel/any.native.reference

@@ -0,0 +1,2 @@
+Exception: Assert_failure ("//toplevel//", 8, 0).
+

toplevel/byte/topeval.ml

@@ -143,7 +143,7 @@ let execute_phrase print_outcome ppf phr =
                   | [] -> Ophr_signature []
                   | _ ->
                       match find_eval_phrase str with
-                      | Some (exp, _, _) ->
+                      | Some (exp, _, _, _) ->
                         let outv = outval_of_value newenv v exp.exp_type in
                         let ty = Printtyp.tree_of_type_scheme exp.exp_type in
                         Ophr_eval (outv, ty)

toplevel/native/topeval.ml

@@ -18,7 +18,6 @@
 open Format
 open Misc
 open Parsetree
-open Layouts
 open Types
 open Typedtree
 open Outcometree
@@ -123,7 +122,7 @@ let pr_item =
 
 let phrase_seqid = ref 0
 
-let name_expression ~loc ~attrs exp =
+let name_expression ~loc ~attrs sort exp =
   let name = "_$" in
   let id = Ident.create_local name in
   let vd =
@@ -145,9 +144,7 @@ let name_expression ~loc ~attrs exp =
    let vb =
      { vb_pat = pat;
        vb_expr = exp;
-       (* CR layouts v2: revisit when we allow non-value top-level module
-          bindings *)
-       vb_sort = Sort.value;
+       vb_sort = sort;
        vb_attributes = attrs;
        vb_loc = loc; }
    in
@@ -201,8 +198,8 @@ let execute_phrase print_outcome ppf phr =
          tool-toplevel/topeval.ml in the testsuite) *)
       let str, sg', rewritten =
          match find_eval_phrase str with
-         | Some (e, attrs, loc) ->
-             let str, sg' = name_expression ~loc ~attrs e in
+         | Some (e, sort, attrs, loc) ->
+             let str, sg' = name_expression ~loc ~attrs sort e in
              str, sg', true
          | None -> str, sg', false
       in

toplevel/topcommon.ml

@@ -67,14 +67,15 @@ let print_out_phrase = Oprint.out_phrase
 let find_eval_phrase str =
   let open Typedtree in
   match str.str_items with
-  | [ { str_desc = Tstr_eval (e, _, attrs) ; str_loc = loc } ]
+  | [ { str_desc = Tstr_eval (e, sort, attrs) ; str_loc = loc } ]
   | [ { str_desc = Tstr_value (Asttypes.Nonrecursive,
                                 [{ vb_expr = e
                                  ; vb_pat = { pat_desc = Tpat_any; _ }
-                                 ; vb_attributes = attrs }])
+                                 ; vb_attributes = attrs
+                                 ; vb_sort = sort }])
       ; str_loc = loc }
     ] ->
-      Some (e, attrs, loc)
+      Some (e, sort, attrs, loc)
   | _ -> None
 
 (* The current typing environment for the toplevel *)

toplevel/topcommon.mli

@@ -49,7 +49,7 @@ val record_backtrace : unit -> unit
 
 val find_eval_phrase :
   Typedtree.structure ->
-    (Typedtree.expression * Typedtree.attributes * Location.t) option
+    (Typedtree.expression * Layouts.sort * Typedtree.attributes * Location.t) option
 
 val max_printer_depth: int ref
 val max_printer_steps: int ref

typing/printtyped.ml

@@ -917,7 +917,7 @@ and structure_item i ppf x =
   | Tstr_eval (e, l, attrs) ->
       line i ppf "Tstr_eval\n";
       attributes i ppf attrs;
-      line i ppf "%a\n" Layouts.Layout.format l;
+      Layouts.Layout.(line i ppf "%a\n" format (of_sort l));
       expression i ppf e;
   | Tstr_value (rf, l) ->
       line i ppf "Tstr_value %a\n" fmt_rec_flag rf;

typing/typecore.ml

@@ -7518,15 +7518,11 @@ let type_let existential_ctx env rec_flag spat_sexp_list =
 
 (* Typing of toplevel expressions *)
 
-(* CR layouts: In many places, we call this (or various related functions like
-   type_expect) and then immediately call `type_layout` to find the layout of
-   the resulting type.  This feels like it could be improved - perhaps
-   type_expression could cheaply keep track of the layout of the type it's
-   computing and return it? *)
-let type_expression env sexp =
+let type_expression env layout sexp =
   Typetexp.TyVarEnv.reset ();
   begin_def();
-  let exp = type_exp env mode_global sexp in
+  let expected = mk_expected (newvar layout) in
+  let exp = type_expect env mode_global sexp expected in
   end_def();
   if maybe_expansive exp then lower_contravariant env exp.exp_type;
   generalize exp.exp_type;
@@ -7540,6 +7536,13 @@ let type_expression env sexp =
       {exp with exp_type = desc.val_type}
   | _ -> exp
 
+let type_representable_expression env sexp =
+  let sort = Sort.new_var () in
+  let exp = type_expression env (Layout.of_sort sort) sexp in
+  exp, sort
+
+let type_expression env sexp = type_expression env Layout.any sexp
+
 (* Error report *)
 
 let spellcheck ppf unbound_name valid_names =

typing/typecore.mli

@@ -121,6 +121,8 @@ val type_let:
           Typedtree.value_binding list * Env.t
 val type_expression:
         Env.t -> Parsetree.expression -> Typedtree.expression
+val type_representable_expression:
+        Env.t -> Parsetree.expression -> Typedtree.expression * sort
 val type_class_arg_pattern:
         string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern ->
         Typedtree.pattern *

typing/typedtree.ml

@@ -346,7 +346,7 @@ and structure_item =
   }
 
 and structure_item_desc =
-    Tstr_eval of expression * layout * attributes
+    Tstr_eval of expression * sort * attributes
   | Tstr_value of rec_flag * value_binding list
   | Tstr_primitive of value_description
   | Tstr_type of rec_flag * type_declaration list

typing/typedtree.mli

@@ -542,9 +542,7 @@ and structure_item =
   }
 
 and structure_item_desc =
-    Tstr_eval of expression * Layouts.layout * attributes
-    (* CR layouts v5: The above layout is now only used to implement the void
-       sanity check.  Consider removing when void is handled properly. *)
+    Tstr_eval of expression * Layouts.sort * attributes
   | Tstr_value of rec_flag * value_binding list
   | Tstr_primitive of value_description
   | Tstr_type of rec_flag * type_declaration list

typing/typemod.ml

@@ -2628,12 +2628,14 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr =
     | None ->
     match desc with
     | Pstr_eval (sexpr, attrs) ->
-        let expr =
+        (* We restrict [Tstr_eval] expressions to representable layouts to
+           support the native toplevel.  See the special handling of [Tstr_eval]
+           near the top of [execute_phrase] in [opttoploop.ml]. *)
+        let expr, sort =
           Builtin_attributes.warning_scope attrs
-            (fun () -> Typecore.type_expression env sexpr)
+            (fun () -> Typecore.type_representable_expression env sexpr)
         in
-        let layout = Ctype.type_layout expr.exp_env expr.exp_type in
-        Tstr_eval (expr, layout, attrs), [], shape_map, env
+        Tstr_eval (expr, sort, attrs), [], shape_map, env
     | Pstr_value(rec_flag, sdefs) ->
         let force_global =
           (* Values bound by '_' still escape in the toplevel, because