Skip to content

Remove exact from expected_mode #2300

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.

Sign up for GitHub

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 5 commits into from
Feb 20, 2024
Merged

Remove exact from expected_mode #2300

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
b375069
remove exact from expected_mode
riaqn Feb 20, 2024
7e89baa
Kill off an Option.get
goldfirere Feb 20, 2024
2b560e7
address comments
riaqn Feb 20, 2024
0c0560c
improve tests
riaqn Feb 20, 2024
ac0bc1e
add comments
riaqn Feb 20, 2024
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
23 changes: 22 additions & 1 deletion ocaml/testsuite/tests/typing-local/exclave.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -214,6 +214,27 @@ Error: This function or one of its parameters escape their region
when it is partially applied.
|}]

let f () =
exclave_ (
(fun x -> function | "a" -> () | _ -> ()) : (string -> string -> unit)
)
[%%expect{|
Line 3, characters 4-45:
3 | (fun x -> function | "a" -> () | _ -> ()) : (string -> string -> unit)
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This function or one of its parameters escape their region
when it is partially applied.
|}]

(* For n-ary functions, inner functions are not constrained *)
let f () =
exclave_ (
(fun x -> fun y -> ()) : (string -> string -> unit)
)
[%%expect{|
val f : unit -> local_ (string -> (string -> unit)) = <fun>
|}]

let f : local_ string -> string =
fun x -> exclave_ s
[%%expect{|
Expand All @@ -222,4 +243,4 @@ Line 2, characters 11-21:
^^^^^^^^^^
Error: This expression was expected to be not local, but is an exclave expression,
which must be local.
|}]
|}]
29 changes: 29 additions & 0 deletions ocaml/testsuite/tests/typing-local/local.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2767,6 +2767,15 @@ Error: This function or one of its parameters escape their region
when it is partially applied.
|}];;

let f () = ((fun x -> function | 0 -> x | y -> x + y) : (local_ int -> (int -> int)));;
[%%expect{|
Line 1, characters 12-53:
1 | let f () = ((fun x -> function | 0 -> x | y -> x + y) : (local_ int -> (int -> int)));;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This function or one of its parameters escape their region
when it is partially applied.
|}];;

(* ok if curried *)
let f () = ((fun x -> (fun y -> x + y) [@extension.curry])
: (local_ int -> (int -> int)));;
Expand All @@ -2784,6 +2793,26 @@ Error: This function or one of its parameters escape their region
when it is partially applied.
|}];;

let f () = local_ ((fun x -> function | 0 -> x | y -> x + y) : (_ -> _));;
[%%expect{|
Line 1, characters 19-60:
1 | let f () = local_ ((fun x -> function | 0 -> x | y -> x + y) : (_ -> _));;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This function or one of its parameters escape their region
when it is partially applied.
|}];;

(* For n-ary functions, inner functions are not constrained *)
let f () = ((fun x -> fun y -> x + y) : (local_ int -> (int -> int)));;
[%%expect{|
val f : unit -> local_ int -> (int -> int) = <fun>
|}];;

let f () = local_ ((fun x -> fun y -> x + y) : (_ -> _));;
[%%expect{|
val f : unit -> local_ (int -> (int -> int)) = <fun>
|}];;

(* ok if curried *)
let f () = local_ ((fun x -> (fun y -> x + y) [@extension.curry]) : (_ -> _));;
[%%expect{|
Expand Down
17 changes: 16 additions & 1 deletion ocaml/testsuite/tests/typing-unique/unique.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -561,6 +561,21 @@ Error: This function when partially applied returns a once value,
but expected to be many.
|}]

let curry : unique_ box -> (unique_ box -> unique_ box) = fun b1 -> function | b2 -> b2
[%%expect{|
Line 1, characters 58-87:
1 | let curry : unique_ box -> (unique_ box -> unique_ box) = fun b1 -> function | b2 -> b2
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This function when partially applied returns a once value,
but expected to be many.
|}]

(* For n-ary functions, inner functions are not constrained *)
let no_curry : unique_ box -> (unique_ box -> unique_ box) = fun b1 -> fun b2 -> b2
[%%expect{|
val no_curry : unique_ box -> (unique_ box -> unique_ box) = <fun>
|}]

(* If both type and mode are wrong, complain about type *)
let f () =
let id2 (x : string) = shared_id x in
Expand Down Expand Up @@ -615,4 +630,4 @@ Line 5, characters 16-17:
5 | in Node (x, x)
^

|}]
|}]
106 changes: 48 additions & 58 deletions ocaml/typing/typecore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -343,12 +343,6 @@ type expected_mode =
mode : Value.r;
(** The upper bound, hence r (right) *)

exact : Alloc.lr option;
(** In some scnearios, restricing the upper bound is not sufficient.
For example, when defining a function [fun a -> fun b -> e]. If the outer
function is [local], the inner function must be made [local] as well. See
[type_function] for more details *)

strictly_local : bool;
(** Indicates that the expression was directly annotated with [local], which
should force any allocations to be on the stack. If [true] the [mode] field
Expand Down Expand Up @@ -466,7 +460,6 @@ let mode_default mode =
{ position = RNontail;
closure_context = None;
mode = Value.disallow_left mode;
exact = None;
strictly_local = false;
tuple_modes = [] }

Expand Down Expand Up @@ -554,10 +547,6 @@ let mode_tuple mode tuple_modes =
{ (mode_default mode) with
tuple_modes }

let mode_exact mode exact =
{ (mode_default mode) with
exact = Some exact }

(** Takes [marg:Alloc.lr] extracted from the arrow type and returns the real
mode of argument, after taking into consideration partial application and
tail-call. Returns [expected_mode] and [Value.lr] which are backed by the same
Expand Down Expand Up @@ -819,7 +808,6 @@ let expect_mode_cross env ty (expected_mode : expected_mode) =
if mode_cross env ty then
{ expected_mode with
mode = Value.disallow_left Value.max;
exact = None;
strictly_local = false }
else expected_mode

Expand Down Expand Up @@ -4718,11 +4706,6 @@ type split_function_ty =
filtered_arrow: filtered_arrow;
arg_sort : Jkind.sort;
ret_sort : Jkind.sort;
(* If [i = n], then [Final_arg];
if [i < n], then the mode of the result of partially applying
[f] up to [a_i].
*)
curry: function_curry;
(* An instance of [a_i], unless [x_i] is annotated as polymorphic,
in which case it's just [a_i] (not an instance).
*)
Expand All @@ -4735,8 +4718,10 @@ type split_function_ty =
*)
expected_pat_mode: expected_pat_mode;
expected_inner_mode: expected_mode;
(* [alloc_mode] is the mode of [fun x_i ... x_n -> e]. *)
alloc_mode: Mode.Alloc.r;
(* [alloc_mode] is the mode of [fun x_i ... x_n -> e].
This needs to be a left mode for the construction of the [fp_curry] field
of the outer function. *)
alloc_mode: Mode.Alloc.lr;
}

(** Return the updated environment (e.g. it may have a closure lock)
Expand All @@ -4758,13 +4743,13 @@ let split_function_ty
~mode_annots ~in_function ~is_first_val_param ~is_final_val_param
=
let alloc_mode =
match expected_mode.exact with
| Some alloc_mode ->
(* expected_mode.mode is exact *)
alloc_mode
| None ->
let alloc_mode = value_to_alloc_r2g expected_mode.mode in
(* expected_mode.mode is upper bound *)
(* Unlike most allocations which can be the highest mode allowed by
[expected_mode] and their [alloc_mode] identical to [expected_mode] ,
functions have more constraints. For example, an outer function needs
to be made global if its inner function is global. As a result, a
function deserves a separate allocation mode.
*)
fst (Alloc.newvar_below alloc_mode)
in
if expected_mode.strictly_local then
Expand Down Expand Up @@ -4822,29 +4807,12 @@ let split_function_ty
if region_locked then Env.add_region_lock env
else env
in
let expected_inner_mode, curry =
let expected_inner_mode =
if not is_final_val_param then
(* no need to check mode crossing in this case because ty_res always a
function *)
(* [inner_alloc_mode] will be precisely the allocation mode of the inner
function *)
let inner_alloc_mode, _ = Alloc.newvar_below ret_mode in
begin match
Alloc.submode (Alloc.close_over arg_mode) inner_alloc_mode
with
| Ok () -> ()
| Error e ->
raise (Error(loc_fun, env, Uncurried_function_escapes e))
end;
begin match
Alloc.submode (Alloc.partial_apply alloc_mode) inner_alloc_mode
with
| Ok () -> ()
| Error e ->
raise (Error(loc_fun, env, Uncurried_function_escapes e))
end;
mode_exact (alloc_as_value inner_alloc_mode) inner_alloc_mode,
More_args {partial_mode = Alloc.disallow_right inner_alloc_mode}
let ret_value_mode = alloc_as_value ret_mode in
mode_default ret_value_mode
else
let ret_value_mode = alloc_as_value ret_mode in
let ret_value_mode =
Expand All @@ -4859,7 +4827,7 @@ let split_function_ty
end
in
let ret_value_mode = expect_mode_cross env ty_ret ret_value_mode in
ret_value_mode, Final_arg
ret_value_mode
in
let ty_arg_mono =
if has_poly then ty_arg
Expand All @@ -4886,8 +4854,8 @@ let split_function_ty
let ret_sort = type_sort ~why:Function_result ty_ret in
env,
{ filtered_arrow; arg_sort; ret_sort;
alloc_mode = Alloc.disallow_left alloc_mode; ty_arg_mono;
expected_inner_mode; expected_pat_mode; curry;
alloc_mode; ty_arg_mono;
expected_inner_mode; expected_pat_mode
}

type type_function_result_param =
Expand All @@ -4907,11 +4875,12 @@ type type_function_result =
newtypes: (string loc * Jkind.annotation option) list;
(* Whether any of the value parameters contains a GADT pattern. *)
params_contain_gadt: contains_gadt;
(* The alloc mode of the "rest of the function". None only for
recursive calls to [type_function] when there are no parameters
left.
(* The alloc mode of the "rest of the function". None only for recursive
calls to [type_function] when there are no parameters left. This needs to
be a left mode for the construction of the [fp_curry] field of the outer
function.
*)
fun_alloc_mode: Mode.Alloc.r option;
fun_alloc_mode: Mode.Alloc.lr option;
(* Information about the return of the function. None only for
recursive calls to [type_function] when there are no parameters
left.
Expand Down Expand Up @@ -5008,7 +4977,7 @@ let pat_modes ~force_toplevel rec_mode_var (attrs, spat) =
tuple_pat_mode mode modes, mode_tuple mode modes
end
| Some mode ->
simple_pat_mode mode, mode_exact mode (value_to_alloc_r2g mode)
simple_pat_mode mode, mode_default mode
in
attrs, pat_mode, exp_mode, spat

Expand Down Expand Up @@ -6623,7 +6592,7 @@ and type_function
let env,
{ filtered_arrow = { ty_arg; arg_mode; ty_ret; ret_mode };
arg_sort; ret_sort;
ty_arg_mono; expected_pat_mode; expected_inner_mode; curry;
ty_arg_mono; expected_pat_mode; expected_inner_mode;
alloc_mode;
} =
split_function_ty env expected_mode ty_expected loc
Expand Down Expand Up @@ -6670,7 +6639,7 @@ and type_function
in
ty_default_arg, Some (default_arg, arg_label, default_arg_sort)
in
let (pat, params, body, ret_info, newtypes, contains_gadt), partial =
let (pat, params, body, ret_info, newtypes, contains_gadt, curry), partial =
(* Check everything else in the scope of the parameter. *)
map_half_typed_cases Value env expected_pat_mode
ty_arg_internal ty_ret pat.ppat_loc
Expand All @@ -6682,7 +6651,7 @@ and type_function
~contains_gadt:param_contains_gadt ->
let { function_ = _, params_suffix, body;
newtypes; params_contain_gadt = suffix_contains_gadt;
fun_alloc_mode = _; ret_info;
fun_alloc_mode; ret_info;
}
=
type_function ext_env expected_inner_mode ty_expected
Expand All @@ -6695,7 +6664,28 @@ and type_function
else
suffix_contains_gadt
in
pat, params_suffix, body, ret_info, newtypes, contains_gadt
let curry =
if is_final_val_param then
Final_arg
else
let fun_alloc_mode = Option.get fun_alloc_mode in
begin match
Alloc.submode (Alloc.close_over arg_mode) fun_alloc_mode
with
| Ok () -> ()
| Error e ->
raise (Error(loc_fun, env, Uncurried_function_escapes e))
end;
begin match
Alloc.submode (Alloc.partial_apply alloc_mode) fun_alloc_mode
with
| Ok () -> ()
| Error e ->
raise (Error(loc_fun, env, Uncurried_function_escapes e))
end;
More_args {partial_mode = Alloc.disallow_right fun_alloc_mode}
in
pat, params_suffix, body, ret_info, newtypes, contains_gadt, curry
end
|> function
(* The result must be a singleton because we passed a singleton
Expand Down Expand Up @@ -8730,7 +8720,7 @@ and type_n_ary_function
{ exp_desc =
Texp_function
{ params; body; region = region_locked; ret_sort;
alloc_mode = fun_alloc_mode; ret_mode;
alloc_mode = Mode.Alloc.disallow_left fun_alloc_mode; ret_mode;
};
exp_loc = loc;
exp_extra =
Expand Down