Thanks to visit codestin.com
Credit goes to github.com

Skip to content

Commit 001d6fc

Browse files
ncik-robertsncik-roberts
authored
Syntactic function arity typechecking and translation (#1817)
* Newtypes * Constraint/coercion * Add map_half_typed_cases * Implement type-checking/translation This also promotes tests whose output changes. * Add upstream tests Tests from: - ocaml/ocaml#12236 (and the corresponding updates to outputs found in ocaml/ocaml#12386 and ocaml/ocaml#12391) - ocaml/ocaml#12496 (not merged) * Fix ocamldoc * Update chamelon minimizer * Respond to requested changes to minimizer * update new test brought in from rebase * Fix bug in chunking code * `make bootstrap` * Add Ast_invariant check * Fix type-directed disambiguation of optional arg defaults * Minor comments from review * Run syntactic-arity test, update output, and fix printing bug * Remove unnecessary call to escape * Backport changes from upstream to comparative alloc tests * Avoid the confusing [Split_function_ty] module * Comment [split_function_ty] better. * [contains_gadt] as variant instead of bool * Calculate is_final_val_param on the fly rather than precomputing indexes * Note suboptimality * Get typecore typechecking * Finish resolving merge conflicts and run tests * make bootstrap * Add iteration on / mapping over locations and attributes * Reduce diff and fix typo in comment: * promote change to zero-alloc arg structure * Undo unintentional formatting changes to chamelon * Fix minimizer * Minimize diff * Fix bug with local-returning method * Fix regression where polymorphic parameters weren't allowed to be used in same parameter list as GADTs * Fix merge conflicts and make bootstrap * Apply expected diff to zero-alloc test changed in this PR
1 parent 97a5954 commit 001d6fc

File tree

79 files changed

+4337
-1737
lines changed

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

79 files changed

+4337
-1737
lines changed

‎chamelon/compat.jst.ml‎

Lines changed: 139 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -37,51 +37,122 @@ type texp_construct_identifier = Alloc.t option
3737
let mkTexp_construct ?id:(mode = Some Alloc.legacy) (name, desc, args) =
3838
Texp_construct (name, desc, args, mode)
3939

40-
type texp_function = {
40+
type texp_function_param_identifier = {
41+
param_sort : Jkind.Sort.t;
42+
param_mode : Alloc.t;
43+
param_curry : function_curry;
44+
param_newtypes : (string Location.loc * Jkind.annotation option) list;
45+
}
46+
47+
type texp_function_param = {
4148
arg_label : Asttypes.arg_label;
49+
pattern : pattern;
4250
param : Ident.t;
43-
cases : value case list;
51+
partial : partial;
52+
optional_default : expression option;
53+
param_identifier : texp_function_param_identifier;
54+
}
55+
56+
type texp_function_cases_identifier = {
57+
last_arg_mode : Alloc.t;
58+
last_arg_sort : Jkind.Sort.t;
59+
last_arg_exp_extra : exp_extra option;
60+
last_arg_attributes : attributes;
61+
}
62+
63+
type texp_function_body =
64+
| Function_body of expression
65+
| Function_cases of {
66+
cases : value case list;
67+
param : Ident.t;
68+
partial : partial;
69+
function_cases_identifier : texp_function_cases_identifier;
70+
}
71+
72+
type texp_function = {
73+
params : texp_function_param list;
74+
body : texp_function_body;
4475
}
4576

4677
type texp_function_identifier = {
47-
partial : partial;
48-
arg_mode : Alloc.t;
4978
alloc_mode : Alloc.t;
50-
region : bool;
51-
curry : fun_curry_state;
52-
warnings : Warnings.state;
53-
arg_sort : Jkind.sort;
5479
ret_sort : Jkind.sort;
80+
region : bool;
5581
ret_mode : Alloc.t;
5682
}
5783

84+
let texp_function_cases_identifier_defaults =
85+
{
86+
last_arg_mode = Alloc.legacy;
87+
last_arg_sort = Jkind.Sort.value;
88+
last_arg_exp_extra = None;
89+
last_arg_attributes = [];
90+
}
91+
92+
let texp_function_param_identifier_defaults =
93+
{
94+
param_sort = Jkind.Sort.value;
95+
param_mode = Alloc.legacy;
96+
param_curry = More_args { partial_mode = Alloc.legacy };
97+
param_newtypes = [];
98+
}
99+
58100
let texp_function_defaults =
59101
{
60-
partial = Total;
61-
arg_mode = Alloc.legacy;
62102
alloc_mode = Alloc.legacy;
63-
region = false;
64-
curry = Final_arg { partial_mode = Alloc.legacy };
65-
warnings = Warnings.backup ();
66-
arg_sort = Jkind.Sort.value;
67103
ret_sort = Jkind.Sort.value;
68104
ret_mode = Alloc.legacy;
105+
region = false;
69106
}
70107

71108
let mkTexp_function ?(id = texp_function_defaults)
72-
({ arg_label; param; cases } : texp_function) =
109+
({ params; body } : texp_function) =
73110
Texp_function
74111
{
75-
arg_label;
76-
param;
77-
cases;
78-
partial = id.partial;
79-
arg_mode = id.arg_mode;
112+
params =
113+
List.map
114+
(fun {
115+
arg_label;
116+
pattern;
117+
param;
118+
partial;
119+
param_identifier = id;
120+
optional_default;
121+
} ->
122+
{
123+
fp_arg_label = arg_label;
124+
fp_kind =
125+
(match optional_default with
126+
| None -> Tparam_pat pattern
127+
| Some default ->
128+
Tparam_optional_default (pattern, default, id.param_sort));
129+
fp_param = param;
130+
fp_partial = partial;
131+
fp_sort = id.param_sort;
132+
fp_mode = id.param_mode;
133+
fp_curry = id.param_curry;
134+
fp_newtypes = id.param_newtypes;
135+
fp_loc = Location.none;
136+
})
137+
params;
138+
body =
139+
(match body with
140+
| Function_body expr -> Tfunction_body expr
141+
| Function_cases
142+
{ cases; param; partial; function_cases_identifier = id } ->
143+
Tfunction_cases
144+
{
145+
fc_cases = cases;
146+
fc_param = param;
147+
fc_partial = partial;
148+
fc_arg_mode = id.last_arg_mode;
149+
fc_arg_sort = id.last_arg_sort;
150+
fc_exp_extra = id.last_arg_exp_extra;
151+
fc_attributes = id.last_arg_attributes;
152+
fc_loc = Location.none;
153+
});
80154
alloc_mode = id.alloc_mode;
81155
region = id.region;
82-
curry = id.curry;
83-
warnings = id.warnings;
84-
arg_sort = id.arg_sort;
85156
ret_sort = id.ret_sort;
86157
ret_mode = id.ret_mode;
87158
}
@@ -128,34 +199,52 @@ let view_texp (e : expression_desc) =
128199
| Texp_tuple (args, mode) ->
129200
let labels, args = List.split args in
130201
Texp_tuple (args, (labels, mode))
131-
| Texp_function
132-
{
133-
arg_label;
134-
param;
135-
cases;
136-
partial;
137-
arg_mode;
138-
alloc_mode;
139-
region;
140-
curry;
141-
warnings;
142-
arg_sort;
143-
ret_sort;
144-
ret_mode;
145-
} ->
202+
| Texp_function { params; body; alloc_mode; region; ret_sort; ret_mode } ->
203+
let params =
204+
List.map
205+
(fun param ->
206+
let pattern, optional_default =
207+
match param.fp_kind with
208+
| Tparam_optional_default (pattern, optional_default, _) ->
209+
(pattern, Some optional_default)
210+
| Tparam_pat pattern -> (pattern, None)
211+
in
212+
{
213+
arg_label = param.fp_arg_label;
214+
param = param.fp_param;
215+
partial = param.fp_partial;
216+
pattern;
217+
optional_default;
218+
param_identifier =
219+
{
220+
param_sort = param.fp_sort;
221+
param_mode = param.fp_mode;
222+
param_curry = param.fp_curry;
223+
param_newtypes = param.fp_newtypes;
224+
};
225+
})
226+
params
227+
in
228+
let body =
229+
match body with
230+
| Tfunction_body body -> Function_body body
231+
| Tfunction_cases cases ->
232+
Function_cases
233+
{
234+
cases = cases.fc_cases;
235+
param = cases.fc_param;
236+
partial = cases.fc_partial;
237+
function_cases_identifier =
238+
{
239+
last_arg_mode = cases.fc_arg_mode;
240+
last_arg_sort = cases.fc_arg_sort;
241+
last_arg_exp_extra = cases.fc_exp_extra;
242+
last_arg_attributes = cases.fc_attributes;
243+
};
244+
}
245+
in
146246
Texp_function
147-
( { arg_label; param; cases },
148-
{
149-
partial;
150-
arg_mode;
151-
alloc_mode;
152-
region;
153-
curry;
154-
warnings;
155-
arg_sort;
156-
ret_sort;
157-
ret_mode;
158-
} )
247+
({ params; body }, { alloc_mode; region; ret_sort; ret_mode })
159248
| Texp_sequence (e1, sort, e2) -> Texp_sequence (e1, e2, sort)
160249
| Texp_match (e, sort, cases, partial) -> Texp_match (e, cases, partial, sort)
161250
| _ -> O e

‎chamelon/compat.mli‎

Lines changed: 27 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,11 +7,36 @@ val mkTarrow :
77
Asttypes.arg_label * type_expr * type_expr * commutable -> type_desc
88

99
type apply_arg
10+
type texp_function_param_identifier
11+
type texp_function_cases_identifier
1012

11-
type texp_function = {
13+
val texp_function_cases_identifier_defaults : texp_function_cases_identifier
14+
val texp_function_param_identifier_defaults : texp_function_param_identifier
15+
16+
type texp_function_param = {
1217
arg_label : Asttypes.arg_label;
18+
pattern : pattern;
1319
param : Ident.t;
14-
cases : value case list;
20+
partial : partial;
21+
optional_default : expression option;
22+
(** The optional argument's default value. If [optional_default] is present,
23+
[arg_label] must be [Optional], and [pattern] matches values of type [t]
24+
if the parameter type is [t option]. *)
25+
param_identifier : texp_function_param_identifier;
26+
}
27+
28+
type texp_function_body =
29+
| Function_body of expression
30+
| Function_cases of {
31+
cases : value case list;
32+
param : Ident.t;
33+
partial : partial;
34+
function_cases_identifier : texp_function_cases_identifier;
35+
}
36+
37+
type texp_function = {
38+
params : texp_function_param list;
39+
body : texp_function_body;
1540
}
1641

1742
type texp_ident_identifier

‎chamelon/compat.upstream.ml‎

Lines changed: 95 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -23,17 +23,81 @@ type texp_construct_identifier = unit
2323
let mkTexp_construct ?id:(() = ()) (name, desc, args) =
2424
Texp_construct (name, desc, args)
2525

26-
type texp_function = {
26+
type texp_function_param_identifier = unit
27+
type texp_function_cases_identifier = unit
28+
29+
let texp_function_param_identifier_defaults = ()
30+
let texp_function_cases_identifier_defaults = ()
31+
32+
type texp_function_param = {
2733
arg_label : Asttypes.arg_label;
34+
pattern : pattern;
2835
param : Ident.t;
29-
cases : value case list;
36+
partial : partial;
37+
optional_default : expression option;
38+
param_identifier : texp_function_param_identifier;
3039
}
3140

32-
type texp_function_identifier = partial
41+
type texp_function_body =
42+
| Function_body of expression
43+
| Function_cases of {
44+
cases : value case list;
45+
param : Ident.t;
46+
partial : partial;
47+
function_cases_identifier : texp_function_cases_identifier;
48+
}
49+
50+
type texp_function = {
51+
params : texp_function_param list;
52+
body : texp_function_body;
53+
}
54+
55+
type texp_function_identifier = unit
56+
57+
let dummy_type_expr = newty2 ~level:0 (mkTvar (Some "a"))
58+
59+
let mk_exp ed =
60+
{
61+
exp_desc = ed;
62+
exp_loc = Location.none;
63+
exp_extra = [];
64+
exp_type = dummy_type_expr;
65+
exp_env = Env.empty;
66+
exp_attributes = [];
67+
}
3368

34-
let mkTexp_function ?id:(partial = Total)
35-
({ arg_label; param; cases } : texp_function) =
36-
Texp_function { arg_label; param; cases; partial }
69+
(* This code can be simplified when we upgrade the upstream OCaml version past
70+
PR #12236, which makes Texp_function n-ary (i.e., closer to the
71+
[texp_function] record) instead of unary.
72+
*)
73+
let mkTexp_function ?id:(() = ()) ({ params; body } : texp_function) =
74+
let exp =
75+
List.fold_right
76+
(fun {
77+
arg_label;
78+
pattern;
79+
param;
80+
partial;
81+
optional_default;
82+
param_identifier = ();
83+
} acc ->
84+
assert (Option.is_none optional_default);
85+
mk_exp
86+
(Texp_function
87+
{
88+
arg_label;
89+
param;
90+
cases = [ { c_lhs = pattern; c_guard = None; c_rhs = acc } ];
91+
partial;
92+
}))
93+
params
94+
(match body with
95+
| Function_body expr -> expr
96+
| Function_cases { cases; param; partial; function_cases_identifier = () }
97+
->
98+
mk_exp (Texp_function { arg_label = Nolabel; param; cases; partial }))
99+
in
100+
exp.exp_desc
37101

38102
type texp_sequence_identifier = unit
39103

@@ -66,14 +130,37 @@ type matched_expression_desc =
66130
expression * computation case list * partial * texp_match_identifier
67131
| O of expression_desc
68132

69-
let view_texp (e : expression_desc) =
133+
let rec view_texp (e : expression_desc) =
70134
match e with
71135
| Texp_ident (path, longident, vd) -> Texp_ident (path, longident, vd, ())
72136
| Texp_apply (exp, args) -> Texp_apply (exp, args, ())
73137
| Texp_construct (name, desc, args) -> Texp_construct (name, desc, args, ())
74138
| Texp_tuple args -> Texp_tuple (args, ())
75139
| Texp_function { arg_label; param; cases; partial } ->
76-
Texp_function ({ arg_label; param; cases }, partial)
140+
let params, body =
141+
match cases with
142+
| [ { c_lhs; c_guard = None; c_rhs } ] -> (
143+
let param =
144+
{
145+
arg_label;
146+
partial;
147+
param;
148+
pattern = c_lhs;
149+
optional_default = None;
150+
param_identifier = ();
151+
}
152+
in
153+
match view_texp c_rhs.exp_desc with
154+
| Texp_function ({ params = inner_params; body = inner_body }, ())
155+
->
156+
(param :: inner_params, inner_body)
157+
| _ -> ([ param ], Function_body c_rhs))
158+
| cases ->
159+
( [],
160+
Function_cases
161+
{ param; partial; cases; function_cases_identifier = () } )
162+
in
163+
Texp_function ({ params; body }, ())
77164
| Texp_sequence (e1, e2) -> Texp_sequence (e1, e2, ())
78165
| Texp_match (e, cases, partial) -> Texp_match (e, cases, partial, ())
79166
| _ -> O e

0 commit comments

Comments
 (0)