Skip to content

Fix issue with layout any and Tstr_eval in the native toplevel #1402

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
May 24, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
13 changes: 7 additions & 6 deletions native_toplevel/opttoploop.ml
Original file line number Diff line number Diff line change
Expand Up @@ -364,9 +364,9 @@ let add_directive name dir_fun dir_info =
Hashtbl.add directive_table name dir_fun;
Hashtbl.add directive_info_table name dir_info

(* Give a name to an unnamed expression of layout Value *)
(* Give a name to an unnamed expression *)

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 =
Expand All @@ -390,7 +390,7 @@ let name_expression ~loc ~attrs exp =
vb_expr = exp;
vb_attributes = attrs;
vb_loc = loc;
vb_sort = Layouts.Sort.value }
vb_sort = sort }
in
let item =
{ str_desc = Tstr_value(Nonrecursive, [vb]);
Expand Down Expand Up @@ -429,16 +429,17 @@ let execute_phrase print_outcome ppf phr =
Typecore.force_delayed_checks ();
let str, sg', rewritten =
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 }
] ->
let str, sg' = name_expression ~loc ~attrs e in
let str, sg' = name_expression ~loc ~attrs sort e in
str, sg', true
| _ -> str, sg', false
in
Expand Down
27 changes: 13 additions & 14 deletions ocaml/lambda/translmod.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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 *)
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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 ->
Expand Down Expand Up @@ -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}]) ->
Expand Down
8 changes: 8 additions & 0 deletions ocaml/testsuite/tests/tool-toplevel/any.ml
Original file line number Diff line number Diff line change
@@ -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;;
2 changes: 2 additions & 0 deletions ocaml/testsuite/tests/tool-toplevel/any.native.reference
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
Exception: Assert_failure ("//toplevel//", 8, 0).

2 changes: 1 addition & 1 deletion ocaml/toplevel/byte/topeval.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
11 changes: 4 additions & 7 deletions ocaml/toplevel/native/topeval.ml
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,6 @@
open Format
open Misc
open Parsetree
open Layouts
open Types
open Typedtree
open Outcometree
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
7 changes: 4 additions & 3 deletions ocaml/toplevel/topcommon.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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 *)
Expand Down
2 changes: 1 addition & 1 deletion ocaml/toplevel/topcommon.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion ocaml/typing/printtyped.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down
17 changes: 10 additions & 7 deletions ocaml/typing/typecore.ml
Original file line number Diff line number Diff line change
Expand Up @@ -7512,15 +7512,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;
Expand All @@ -7534,6 +7530,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 =
Expand Down
2 changes: 2 additions & 0 deletions ocaml/typing/typecore.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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 *
Expand Down
2 changes: 1 addition & 1 deletion ocaml/typing/typedtree.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 1 addition & 3 deletions ocaml/typing/typedtree.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
10 changes: 6 additions & 4 deletions ocaml/typing/typemod.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down