Skip to content

Rework jkind default #2158

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 13 commits into from
Dec 18, 2023
Merged

Rework jkind default #2158

Show file tree
Hide file tree
Changes from 4 commits
Commits
Show all changes
13 commits
Select commit Hold shift + click to select a range
d60a76a
extend policy to control ty var jkind init
alanechang Dec 13, 2023
582f60b
annotation on type vars should be upper bounds
alanechang Dec 13, 2023
b056c36
proper jkind reason
alanechang Dec 13, 2023
e37e050
sort init rhs of constraints for backward compatibility
alanechang Dec 14, 2023
8ddac50
add comment&rename to jkind_initialization_choice
alanechang Dec 14, 2023
bfb2f13
refactor policy
alanechang Dec 14, 2023
eed2bc8
comment about transl_simple_type_delayed
alanechang Dec 14, 2023
39af45f
use Any more in typeclass
alanechang Dec 14, 2023
1be3148
add new_var_jkind param and thread it through
alanechang Dec 14, 2023
4a8df8e
use Any for with constraint
alanechang Dec 14, 2023
b5d4ab7
add note
alanechang Dec 14, 2023
4608d1f
more tests
alanechang Dec 14, 2023
64b2344
more tests
alanechang Dec 14, 2023
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
8 changes: 4 additions & 4 deletions ocaml/testsuite/tests/typing-layouts/basics.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -289,7 +289,7 @@ Error:
|}]
(* CR layouts v2.9: improve error, which requires layout histories *)

type ('a : any) t4 = ('a : any)
type ('a : any) t4 = 'a
and s4 = string t4;;
[%%expect{|
type ('a : any) t4 = 'a
Expand Down Expand Up @@ -1100,7 +1100,7 @@ val f : ('a : float64). unit -> 'a t22f t22f = <fun>

(* CR layouts v5: bring void version here from layouts_alpha *)

type (_ : any, _ : any) eq = Refl : ('a : any). ('a, 'a) eq
type (_ : any, _ : any) eq = Refl : ('a : any). ('a, 'a) eq

module Mf : sig
type t_float64 : float64
Expand Down Expand Up @@ -1207,7 +1207,7 @@ let q () =
()

[%%expect{|
val ( let* ) : 'a -> (t_float64 -> 'b) -> unit = <fun>
val ( let* ) : ('b : any) 'a. 'a -> (t_float64 -> 'b) -> unit = <fun>
val q : unit -> unit = <fun>
|}]

Expand All @@ -1219,7 +1219,7 @@ let q () =
assert false

[%%expect{|
val ( let* ) : 'a -> ('b -> t_float64) -> unit = <fun>
val ( let* ) : ('b : any) 'a. 'a -> ('b -> t_float64) -> unit = <fun>
val q : unit -> unit = <fun>
|}]

Expand Down
10 changes: 5 additions & 5 deletions ocaml/testsuite/tests/typing-layouts/basics_alpha.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ module type S1 = sig val f : t_any -> int end
module type S1 = sig
type t : any

type ('a : any) s = ('a : any) -> int constraint ('a : any) = t
type ('a : any) s = 'a -> int constraint 'a = t
end;;
[%%expect{|
module type S1 = sig type t : any type 'a s = 'a -> int constraint 'a = t end
Expand All @@ -54,7 +54,7 @@ module type S1 = sig type t : any type 'a s = 'a -> int constraint 'a = t end
module type S1 = sig
type t : any

type ('a : any) s = int -> ('a : any) constraint ('a : any) = t
type ('a : any) s = int -> 'a constraint 'a = t
end;;
[%%expect{|
module type S1 = sig type t : any type 'a s = int -> 'a constraint 'a = t end
Expand Down Expand Up @@ -301,7 +301,7 @@ Error:
|}]
(* CR layouts v2.9: improve error, which will require jkind histories *)

type ('a : any) t4 = ('a : any)
type ('a : any) t4 = 'a
and s4 = string t4;;
[%%expect{|
type ('a : any) t4 = 'a
Expand Down Expand Up @@ -1321,7 +1321,7 @@ let q () =
()

[%%expect{|
val ( let* ) : 'a -> (t_float64 -> 'b) -> unit = <fun>
val ( let* ) : ('b : any) 'a. 'a -> (t_float64 -> 'b) -> unit = <fun>
val q : unit -> unit = <fun>
|}]

Expand All @@ -1347,7 +1347,7 @@ let q () =
assert false

[%%expect{|
val ( let* ) : 'a -> ('b -> t_float64) -> unit = <fun>
val ( let* ) : ('b : any) 'a. 'a -> ('b -> t_float64) -> unit = <fun>
val q : unit -> unit = <fun>
|}]

Expand Down
3 changes: 2 additions & 1 deletion ocaml/testsuite/tests/typing-local/local.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1023,7 +1023,8 @@ val catch : (unit -> local_ string) -> string * string = <fun>
(* same, but this time the function is allowed to return its argument *)
let use_locally (f : local_ 'a -> local_ 'a) : local_ 'a -> local_ 'a = f
[%%expect{|
val use_locally : (local_ 'a -> local_ 'a) -> local_ 'a -> local_ 'a = <fun>
val use_locally :
('a : any). (local_ 'a -> local_ 'a) -> local_ 'a -> local_ 'a = <fun>
|}]

let loc = ((fun x -> local_ x) : local_ int -> local_ int)
Expand Down
8 changes: 4 additions & 4 deletions ocaml/testsuite/tests/typing-poly/poly.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1795,10 +1795,10 @@ external reraise : exn -> 'a = "%reraise"
module M :
functor () ->
sig
val f : 'a -> 'a
val g : 'a -> 'a
val h : 'a -> 'a
val i : 'a -> 'a
val f : ('a : any). 'a -> 'a
val g : ('a : any). 'a -> 'a
val h : ('a : any). 'a -> 'a
val i : ('a : any). 'a -> 'a
end
|}]

Expand Down
6 changes: 6 additions & 0 deletions ocaml/typing/jkind.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -629,6 +629,8 @@ type any_creation_reason =
| Dummy_jkind
| Type_expression_call
| Inside_of_Tarrow
| Wildcard
| Unification_var

type float64_creation_reason = Primitive of Ident.t

Expand Down Expand Up @@ -988,6 +990,8 @@ end = struct
| Type_expression_call ->
fprintf ppf "a call to [type_expression] via the ocaml API"
| Inside_of_Tarrow -> fprintf ppf "argument or result of a Tarrow"
| Wildcard -> fprintf ppf "a _ in a type"
| Unification_var -> fprintf ppf "a fresh unification variable"

let format_immediate_creation_reason ppf : immediate_creation_reason -> _ =
function
Expand Down Expand Up @@ -1359,6 +1363,8 @@ module Debug_printers = struct
| Dummy_jkind -> fprintf ppf "Dummy_jkind"
| Type_expression_call -> fprintf ppf "Type_expression_call"
| Inside_of_Tarrow -> fprintf ppf "Inside_of_Tarrow"
| Wildcard -> fprintf ppf "Wildcard"
| Unification_var -> fprintf ppf "Unification_var"

let immediate_creation_reason ppf : immediate_creation_reason -> _ = function
| Empty_record -> fprintf ppf "Empty_record"
Expand Down
2 changes: 2 additions & 0 deletions ocaml/typing/jkind.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -256,6 +256,8 @@ type any_creation_reason =
unified to correct levels *)
| Type_expression_call
| Inside_of_Tarrow
| Wildcard
| Unification_var

type float64_creation_reason = Primitive of Ident.t

Expand Down
22 changes: 11 additions & 11 deletions ocaml/typing/typeclass.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -261,9 +261,9 @@ let unify_delayed_method_type loc env label ty expected_ty=
raise(Error(loc, env, Field_type_mismatch ("method", label, trace)))

let type_constraint val_env sty sty' loc =
let cty = transl_simple_type val_env ~closed:false Alloc.Const.legacy sty in
let cty = transl_simple_type ~new_var_jkind:Sort val_env ~closed:false Alloc.Const.legacy sty in
let ty = cty.ctyp_type in
let cty' = transl_simple_type val_env ~closed:false Alloc.Const.legacy sty' in
let cty' = transl_simple_type ~new_var_jkind:Sort val_env ~closed:false Alloc.Const.legacy sty' in
let ty' = cty'.ctyp_type in
begin
try Ctype.unify val_env ty ty' with Ctype.Unify err ->
Expand Down Expand Up @@ -308,7 +308,7 @@ let rec class_type_field env sign self_scope ctf =
| Pctf_val ({txt=lab}, mut, virt, sty) ->
mkctf_with_attrs
(fun () ->
let cty = transl_simple_type env ~closed:false Alloc.Const.legacy sty in
let cty = transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy sty in
let ty = cty.ctyp_type in
begin match
Ctype.constrain_type_jkind
Expand Down Expand Up @@ -343,7 +343,7 @@ let rec class_type_field env sign self_scope ctf =
) :: !delayed_meth_specs;
Tctf_method (lab, priv, virt, returned_cty)
| _ ->
let cty = transl_simple_type env ~closed:false Alloc.Const.legacy sty in
let cty = transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy sty in
let ty = cty.ctyp_type in
add_method loc env lab priv virt ty sign;
Tctf_method (lab, priv, virt, cty))
Expand All @@ -367,7 +367,7 @@ and class_signature virt env pcsig self_scope loc =
(* Introduce a dummy method preventing self type from being closed. *)
Ctype.add_dummy_method env ~scope:self_scope sign;

let self_cty = transl_simple_type env ~closed:false Alloc.Const.legacy sty in
let self_cty = transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy sty in
let self_type = self_cty.ctyp_type in
begin try
Ctype.unify env self_type sign.csig_self
Expand Down Expand Up @@ -417,7 +417,7 @@ and class_type_aux env virt self_scope scty =
List.length styl)));
let ctys = List.map2
(fun sty ty ->
let cty' = transl_simple_type env ~closed:false Alloc.Const.legacy sty in
let cty' = transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy sty in
let ty' = cty'.ctyp_type in
begin
try Ctype.unify env ty' ty with Ctype.Unify err ->
Expand All @@ -437,7 +437,7 @@ and class_type_aux env virt self_scope scty =
cltyp (Tcty_signature clsig) typ

| Pcty_arrow (l, sty, scty) ->
let cty = transl_simple_type env ~closed:false Alloc.Const.legacy sty in
let cty = transl_simple_type ~new_var_jkind:Sort env ~closed:false Alloc.Const.legacy sty in
let ty = cty.ctyp_type in
let ty =
if Btype.is_optional l
Expand Down Expand Up @@ -670,7 +670,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
(fun () ->
let cty =
Ctype.with_local_level_if_principal
(fun () -> Typetexp.transl_simple_type val_env
(fun () -> Typetexp.transl_simple_type ~new_var_jkind:Sort val_env
~closed:false Alloc.Const.legacy styp)
~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type)
in
Expand Down Expand Up @@ -760,7 +760,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
with_attrs
(fun () ->
let sty = Ast_helper.Typ.force_poly sty in
let cty = transl_simple_type val_env ~closed:false Alloc.Const.legacy sty in
let cty = transl_simple_type ~new_var_jkind:Sort val_env ~closed:false Alloc.Const.legacy sty in
let ty = cty.ctyp_type in
add_method loc val_env label.txt priv Virtual ty sign;
let field =
Expand Down Expand Up @@ -800,7 +800,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
| Some sty ->
let sty = Ast_helper.Typ.force_poly sty in
let cty' =
Typetexp.transl_simple_type val_env ~closed:false Alloc.Const.legacy sty
Typetexp.transl_simple_type ~new_var_jkind:Sort val_env ~closed:false Alloc.Const.legacy sty
in
cty'.ctyp_type
in
Expand Down Expand Up @@ -1118,7 +1118,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
if Path.same decl.cty_path unbound_class then
raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
let tyl = List.map
(fun sty -> transl_simple_type val_env ~closed:false Alloc.Const.legacy sty)
(fun sty -> transl_simple_type ~new_var_jkind:Sort val_env ~closed:false Alloc.Const.legacy sty)
styl
in
let (params, clty) =
Expand Down
8 changes: 4 additions & 4 deletions ocaml/typing/typecore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4006,7 +4006,7 @@ let rec approx_type env sty =
(* Polymorphic types will only unify with types that match all of their
polymorphic parts, so we need to fully translate the type here
unlike in the monomorphic case *)
Typetexp.transl_simple_type env ~closed:false arg_mode arg_sty
Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false arg_mode arg_sty
in
let ret = approx_type env sty in
let marg = Alloc.of_const arg_mode in
Expand Down Expand Up @@ -4061,7 +4061,7 @@ let type_pattern_approx env spat ty_expected =
mode_annots_or_default mode_annots ~default:Alloc.Const.legacy
in
let ty_pat =
Typetexp.transl_simple_type env ~closed:false arg_type_mode sty
Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false arg_type_mode sty
in
begin try unify env ty_pat.ctyp_type ty_expected with Unify trace ->
raise(Error(spat.ppat_loc, env, Pattern_type_clash(trace, None)))
Expand Down Expand Up @@ -5678,7 +5678,7 @@ and type_expect_
let type_mode =
mode_annots_or_default mode_annots ~default:Alloc.Const.legacy
in
Typetexp.transl_simple_type env ~closed:false type_mode sty
Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false type_mode sty
end
~post:(fun cty -> generalize_structure cty.ctyp_type)
in
Expand Down Expand Up @@ -6013,7 +6013,7 @@ and type_expect_
| Some sty ->
let sty = Ast_helper.Typ.force_poly sty in
let cty =
Typetexp.transl_simple_type env ~closed:false
Typetexp.transl_simple_type ~new_var_jkind:Any env ~closed:false
Alloc.Const.legacy sty
in
cty.ctyp_type, Some cty
Expand Down
18 changes: 9 additions & 9 deletions ocaml/typing/typedecl.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -360,7 +360,7 @@ let transl_labels env univars closed lbls =
Builtin_attributes.warning_scope attrs
(fun () ->
let arg = Ast_helper.Typ.force_poly arg in
let cty = transl_simple_type env ?univars ~closed Mode.Alloc.Const.legacy arg in
let cty = transl_simple_type ~new_var_jkind:Sort env ?univars ~closed Mode.Alloc.Const.legacy arg in
let gbl =
match mut with
| Mutable -> Types.Global
Expand Down Expand Up @@ -393,7 +393,7 @@ let transl_labels env univars closed lbls =

let transl_types_gf env univars closed tyl =
let mk arg =
let cty = transl_simple_type env ?univars ~closed Mode.Alloc.Const.legacy arg in
let cty = transl_simple_type ~new_var_jkind:Sort env ?univars ~closed Mode.Alloc.Const.legacy arg in
let gf = transl_global_flags arg.ptyp_loc arg.ptyp_attributes in
(cty, gf)
in
Expand Down Expand Up @@ -468,7 +468,7 @@ let make_constructor
transl_constructor_arguments env univars closed sargs
in
let tret_type =
transl_simple_type env ?univars ~closed Mode.Alloc.Const.legacy
transl_simple_type ~new_var_jkind:Sort env ?univars ~closed Mode.Alloc.Const.legacy
sret_type
in
let ret_type = tret_type.ctyp_type in
Expand Down Expand Up @@ -626,8 +626,8 @@ let transl_declaration env sdecl (id, uid) =
let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
let cstrs = List.map
(fun (sty, sty', loc) ->
transl_simple_type env ~closed:false Mode.Alloc.Const.legacy sty,
transl_simple_type env ~closed:false Mode.Alloc.Const.legacy sty', loc)
transl_simple_type ~new_var_jkind:Any env ~closed:false Mode.Alloc.Const.legacy sty,
transl_simple_type ~new_var_jkind:Sort env ~closed:false Mode.Alloc.Const.legacy sty', loc)
sdecl.ptype_cstrs
in
let unboxed_attr = get_unboxed_from_attributes sdecl in
Expand All @@ -651,7 +651,7 @@ let transl_declaration env sdecl (id, uid) =
None -> None, None
| Some sty ->
let no_row = not (is_fixed_type sdecl) in
let cty = transl_simple_type env ~closed:no_row Mode.Alloc.Const.legacy sty in
let cty = transl_simple_type ~new_var_jkind:Any env ~closed:no_row Mode.Alloc.Const.legacy sty in
Some cty, Some cty.ctyp_type
in
let any = Jkind.any ~why:Initial_typedecl_env in
Expand Down Expand Up @@ -2355,10 +2355,10 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
let constraints =
List.map (fun (ty, ty', loc) ->
let cty =
transl_simple_type env ~closed:false Mode.Alloc.Const.legacy ty
transl_simple_type ~new_var_jkind:Sort env ~closed:false Mode.Alloc.Const.legacy ty
in
let cty' =
transl_simple_type env ~closed:false Mode.Alloc.Const.legacy ty'
transl_simple_type ~new_var_jkind:Sort env ~closed:false Mode.Alloc.Const.legacy ty'
in
(* Note: We delay the unification of those constraints
after the unification of parameters, so that clashing
Expand All @@ -2372,7 +2372,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
None -> None, None
| Some sty ->
let cty =
transl_simple_type env ~closed:no_row Mode.Alloc.Const.legacy sty
transl_simple_type ~new_var_jkind:Sort env ~closed:no_row Mode.Alloc.Const.legacy sty
in
Some cty, Some cty.ctyp_type
in
Expand Down
Loading