Skip to content

Commit 7a746de

Browse files
alainfrischalainfrisch
authored
Keep more type information in Lambda (#2156)
* Propagate type information about function parameters and return * Keep value kind on staticcatch parameters
1 parent 4c130ca commit 7a746de

31 files changed

Lines changed: 455 additions & 284 deletions

‎Changes‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -589,6 +589,10 @@ Working version
589589
of mutually-recursive type declarations.
590590
(Gabriel Scherer, review by Armaël Guéneau)
591591

592+
- GPR#2156: propagate more type information through Lambda and Clambda
593+
intermediate language, as a preparation step for more future optimizations
594+
(Pierre Chambart and Alain Frisch, cross-reviewed by themselves)
595+
592596
### Bug fixes:
593597

594598
- MPR#7867: Fix #mod_use raising an exception for filenames with no

‎asmcomp/clambda.ml‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,11 @@ and ulambda =
6060
| Uswitch of ulambda * ulambda_switch * Debuginfo.t
6161
| Ustringswitch of ulambda * (string * ulambda) list * ulambda option
6262
| Ustaticfail of int * ulambda list
63-
| Ucatch of int * Backend_var.With_provenance.t list * ulambda * ulambda
63+
| Ucatch of
64+
int *
65+
(Backend_var.With_provenance.t * value_kind) list *
66+
ulambda *
67+
ulambda
6468
| Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
6569
| Uifthenelse of ulambda * ulambda * ulambda
6670
| Usequence of ulambda * ulambda
@@ -74,7 +78,8 @@ and ulambda =
7478
and ufunction = {
7579
label : function_label;
7680
arity : int;
77-
params : Backend_var.With_provenance.t list;
81+
params : (Backend_var.With_provenance.t * value_kind) list;
82+
return : value_kind;
7883
body : ulambda;
7984
dbg : Debuginfo.t;
8085
env : Backend_var.t option;

‎asmcomp/clambda.mli‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,11 @@ and ulambda =
7171
| Uswitch of ulambda * ulambda_switch * Debuginfo.t
7272
| Ustringswitch of ulambda * (string * ulambda) list * ulambda option
7373
| Ustaticfail of int * ulambda list
74-
| Ucatch of int * Backend_var.With_provenance.t list * ulambda * ulambda
74+
| Ucatch of
75+
int *
76+
(Backend_var.With_provenance.t * value_kind) list *
77+
ulambda *
78+
ulambda
7579
| Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
7680
| Uifthenelse of ulambda * ulambda * ulambda
7781
| Usequence of ulambda * ulambda
@@ -85,7 +89,8 @@ and ulambda =
8589
and ufunction = {
8690
label : function_label;
8791
arity : int;
88-
params : Backend_var.With_provenance.t list;
92+
params : (Backend_var.With_provenance.t * value_kind) list;
93+
return : value_kind;
8994
body : ulambda;
9095
dbg : Debuginfo.t;
9196
env : Backend_var.t option;

‎asmcomp/closure.ml‎

Lines changed: 25 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -654,10 +654,12 @@ let rec substitute loc fpc sb rn ulam =
654654
let new_nfail = next_raise_count () in
655655
new_nfail, Some (Int.Map.add nfail new_nfail rn)
656656
| None -> nfail, rn in
657-
let ids' = List.map VP.rename ids in
657+
let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in
658658
let sb' =
659659
List.fold_right2
660-
(fun id id' s -> V.Map.add (VP.var id) (Uvar (VP.var id')) s)
660+
(fun (id, _) (id', _) s ->
661+
V.Map.add (VP.var id) (Uvar (VP.var id')) s
662+
)
661663
ids ids' sb
662664
in
663665
Ucatch(nfail, ids', substitute loc fpc sb rn u1,
@@ -923,7 +925,8 @@ let rec close fenv cenv = function
923925
let (new_fun, approx) = close fenv cenv
924926
(Lfunction{
925927
kind = Curried;
926-
params = final_args;
928+
return = Pgenval;
929+
params = List.map (fun v -> v, Pgenval) final_args;
927930
body = Lapply{ap_should_be_tailcall=false;
928931
ap_loc=loc;
929932
ap_func=(Lvar funct_var);
@@ -1102,7 +1105,7 @@ let rec close fenv cenv = function
11021105
| Lstaticcatch(body, (i, vars), handler) ->
11031106
let (ubody, _) = close fenv cenv body in
11041107
let (uhandler, _) = close fenv cenv handler in
1105-
let vars = List.map (fun var -> VP.create var) vars in
1108+
let vars = List.map (fun (var, k) -> VP.create var, k) vars in
11061109
(Ucatch(i, vars, ubody, uhandler), Value_unknown)
11071110
| Ltrywith(body, id, handler) ->
11081111
let (ubody, _) = close fenv cenv body in
@@ -1165,9 +1168,9 @@ and close_functions fenv cenv fun_defs =
11651168
List.flatten
11661169
(List.map
11671170
(function
1168-
| (id, Lfunction{kind; params; body; attr; loc}) ->
1171+
| (id, Lfunction{kind; params; return; body; attr; loc}) ->
11691172
Simplif.split_default_wrapper ~id ~kind ~params
1170-
~body ~attr ~loc
1173+
~body ~attr ~loc ~return
11711174
| _ -> assert false
11721175
)
11731176
fun_defs)
@@ -1189,7 +1192,7 @@ and close_functions fenv cenv fun_defs =
11891192
let uncurried_defs =
11901193
List.map
11911194
(function
1192-
(id, Lfunction{kind; params; body; loc}) ->
1195+
(id, Lfunction{kind; params; return; body; loc}) ->
11931196
let label = Compilenv.make_symbol (Some (V.unique_name id)) in
11941197
let arity = List.length params in
11951198
let fundesc =
@@ -1199,20 +1202,20 @@ and close_functions fenv cenv fun_defs =
11991202
fun_inline = None;
12001203
fun_float_const_prop = !Clflags.float_const_prop } in
12011204
let dbg = Debuginfo.from_location loc in
1202-
(id, params, body, fundesc, dbg)
1205+
(id, params, return, body, fundesc, dbg)
12031206
| (_, _) -> fatal_error "Closure.close_functions")
12041207
fun_defs in
12051208
(* Build an approximate fenv for compiling the functions *)
12061209
let fenv_rec =
12071210
List.fold_right
1208-
(fun (id, _params, _body, fundesc, _dbg) fenv ->
1211+
(fun (id, _params, _return, _body, fundesc, _dbg) fenv ->
12091212
V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv)
12101213
uncurried_defs fenv in
12111214
(* Determine the offsets of each function's closure in the shared block *)
12121215
let env_pos = ref (-1) in
12131216
let clos_offsets =
12141217
List.map
1215-
(fun (_id, _params, _body, fundesc, _dbg) ->
1218+
(fun (_id, _params, _return, _body, fundesc, _dbg) ->
12161219
let pos = !env_pos + 1 in
12171220
env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
12181221
pos)
@@ -1222,23 +1225,28 @@ and close_functions fenv cenv fun_defs =
12221225
does not use its environment parameter is invalidated. *)
12231226
let useless_env = ref initially_closed in
12241227
(* Translate each function definition *)
1225-
let clos_fundef (id, params, body, fundesc, dbg) env_pos =
1228+
let clos_fundef (id, params, return, body, fundesc, dbg) env_pos =
12261229
let env_param = V.create_local "env" in
12271230
let cenv_fv =
12281231
build_closure_env env_param (fv_pos - env_pos) fv in
12291232
let cenv_body =
12301233
List.fold_right2
1231-
(fun (id, _params, _body, _fundesc, _dbg) pos env ->
1234+
(fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
12321235
V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
12331236
uncurried_defs clos_offsets cenv_fv in
12341237
let (ubody, approx) = close fenv_rec cenv_body body in
12351238
if !useless_env && occurs_var env_param ubody then raise NotClosed;
1236-
let fun_params = if !useless_env then params else params @ [env_param] in
1239+
let fun_params =
1240+
if !useless_env
1241+
then params
1242+
else params @ [env_param, Pgenval]
1243+
in
12371244
let f =
12381245
{
12391246
label = fundesc.fun_label;
12401247
arity = fundesc.fun_arity;
1241-
params = List.map (fun var -> VP.create var) fun_params;
1248+
params = List.map (fun (var, kind) -> VP.create var, kind) fun_params;
1249+
return;
12421250
body = ubody;
12431251
dbg;
12441252
env = Some env_param;
@@ -1248,7 +1256,7 @@ and close_functions fenv cenv fun_defs =
12481256
their wrapper functions) to be inlined *)
12491257
let n =
12501258
List.fold_left
1251-
(fun n id -> n + if V.name id = "*opt*" then 8 else 1)
1259+
(fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1)
12521260
0
12531261
fun_params
12541262
in
@@ -1264,7 +1272,7 @@ and close_functions fenv cenv fun_defs =
12641272
| Never_inline -> min_int
12651273
| Unroll _ -> assert false
12661274
in
1267-
let fun_params = List.map (fun var -> VP.create var) fun_params in
1275+
let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in
12681276
if lambda_smaller ubody threshold
12691277
then fundesc.fun_inline <- Some(fun_params, ubody);
12701278

@@ -1280,7 +1288,7 @@ and close_functions fenv cenv fun_defs =
12801288
recompile *)
12811289
Compilenv.backtrack snap; (* PR#6337 *)
12821290
List.iter
1283-
(fun (_id, _params, _body, fundesc, _dbg) ->
1291+
(fun (_id, _params, _return, _body, fundesc, _dbg) ->
12841292
fundesc.fun_closed <- false;
12851293
fundesc.fun_inline <- None;
12861294
)

‎asmcomp/cmmgen.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1969,7 +1969,7 @@ let rec transl env e =
19691969
(* CR-someday mshinwell: consider how we can do better than
19701970
[typ_val] when appropriate. *)
19711971
let ids_with_types =
1972-
List.map (fun i -> (i, Cmm.typ_val)) ids in
1972+
List.map (fun (i, _) -> (i, Cmm.typ_val)) ids in
19731973
ccatch(nfail, ids_with_types, transl env body, transl env handler)
19741974
| Utrywith(body, exn, handler) ->
19751975
Ctrywith(transl env body, exn, transl env handler)
@@ -2910,7 +2910,7 @@ let transl_function ~ppf_dump f =
29102910
[ Reduce_code_size ]
29112911
in
29122912
Cfunction {fun_name = f.label;
2913-
fun_args = List.map (fun id -> (id, typ_val)) f.params;
2913+
fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params;
29142914
fun_body = cmm_body;
29152915
fun_codegen_options;
29162916
fun_dbg = f.dbg}

‎asmcomp/flambda_to_clambda.ml‎

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -309,7 +309,7 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
309309
let env_handler, ids =
310310
List.fold_right (fun var (env, ids) ->
311311
let id, env = Env.add_fresh_ident env var in
312-
env, VP.create id :: ids)
312+
env, (VP.create id, Lambda.Pgenval) :: ids)
313313
vars (env, [])
314314
in
315315
Ucatch (Static_exception.to_int static_exn, ids,
@@ -527,7 +527,11 @@ and to_clambda_set_of_closures t env
527527
in
528528
{ label = Compilenv.function_label closure_id;
529529
arity = Flambda_utils.function_arity function_decl;
530-
params = List.map (fun var -> VP.create var) (params @ [env_var]);
530+
params =
531+
List.map
532+
(fun var -> VP.create var, Lambda.Pgenval)
533+
(params @ [env_var]);
534+
return = Lambda.Pgenval;
531535
body = to_clambda t env_body function_decl.body;
532536
dbg = function_decl.dbg;
533537
env = Some env_var;
@@ -567,7 +571,8 @@ and to_clambda_closed_set_of_closures t env symbol
567571
in
568572
{ label = Compilenv.function_label (Closure_id.wrap id);
569573
arity = Flambda_utils.function_arity function_decl;
570-
params = List.map (fun var -> VP.create var) params;
574+
params = List.map (fun var -> VP.create var, Lambda.Pgenval) params;
575+
return = Lambda.Pgenval;
571576
body = to_clambda t env_body function_decl.body;
572577
dbg = function_decl.dbg;
573578
env = None;

‎asmcomp/printclambda.ml‎

Lines changed: 22 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -52,17 +52,24 @@ let rec structured_constant ppf = function
5252
fprintf ppf ")"
5353
| Uconst_string s -> fprintf ppf "%S" s
5454
| Uconst_closure(clos, sym, fv) ->
55-
let idents ppf =
56-
List.iter (fprintf ppf "@ %a" VP.print) in
57-
let one_fun ppf f =
58-
fprintf ppf "(fun@ %s@ %d@ @[<2>%a@]@ @[<2>%a@])"
59-
f.label f.arity idents f.params lam f.body in
6055
let funs ppf =
6156
List.iter (fprintf ppf "@ %a" one_fun) in
6257
let sconsts ppf scl =
6358
List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
6459
fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
6560

61+
and one_fun ppf f =
62+
let idents ppf =
63+
List.iter
64+
(fun (x, k) ->
65+
fprintf ppf "@ %a%a"
66+
VP.print x
67+
Printlambda.value_kind k
68+
)
69+
in
70+
fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
71+
f.label (value_kind f.return) f.arity idents f.params lam f.body
72+
6673
and phantom_defining_expr ppf = function
6774
| Uphantom_const const -> uconstant ppf const
6875
| Uphantom_var var -> Ident.print ppf var
@@ -103,13 +110,8 @@ and lam ppf = function
103110
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
104111
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
105112
| Uclosure(clos, fv) ->
106-
let idents ppf =
107-
List.iter (fprintf ppf "@ %a" VP.print) in
108-
let one_fun ppf f =
109-
fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])"
110-
f.label f.arity idents f.params lam f.body in
111113
let funs ppf =
112-
List.iter (fprintf ppf "@ %a" one_fun) in
114+
List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in
113115
let lams ppf =
114116
List.iter (fprintf ppf "@ %a" lam) in
115117
fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
@@ -196,12 +198,15 @@ and lam ppf = function
196198
| Ucatch(i, vars, lbody, lhandler) ->
197199
fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
198200
lam lbody i
199-
(fun ppf vars -> match vars with
200-
| [] -> ()
201-
| _ ->
202-
List.iter
203-
(fun x -> fprintf ppf " %a" VP.print x)
204-
vars)
201+
(fun ppf vars ->
202+
List.iter
203+
(fun (x, k) ->
204+
fprintf ppf " %a%a"
205+
VP.print x
206+
Printlambda.value_kind k
207+
)
208+
vars
209+
)
205210
vars
206211
lam lhandler
207212
| Utrywith(lbody, param, lhandler) ->

‎asmcomp/un_anf.ml‎

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -54,9 +54,10 @@ let ignore_primitive (_ : Lambda.primitive) = ()
5454
let ignore_string (_ : string) = ()
5555
let ignore_int_array (_ : int array) = ()
5656
let ignore_var_with_provenance (_ : VP.t) = ()
57-
let ignore_var_with_provenance_list (_ : VP.t list) = ()
57+
let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = ()
5858
let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
5959
let ignore_meth_kind (_ : Lambda.meth_kind) = ()
60+
let ignore_value_kind (_ : Lambda.value_kind) = ()
6061

6162
(* CR-soon mshinwell: check we aren't traversing function bodies more than
6263
once (need to analyse exactly what the calls are from Cmmgen into this
@@ -65,7 +66,7 @@ let ignore_meth_kind (_ : Lambda.meth_kind) = ()
6566
let closure_environment_var (ufunction:Clambda.ufunction) =
6667
(* The argument after the arity is the environment *)
6768
if List.length ufunction.params = ufunction.arity + 1 then
68-
let env_var = List.nth ufunction.params ufunction.arity in
69+
let (env_var, _) = List.nth ufunction.params ufunction.arity in
6970
assert (VP.name env_var = "env");
7071
Some env_var
7172
else
@@ -103,15 +104,16 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
103104
| Uclosure (functions, captured_variables) ->
104105
List.iter loop captured_variables;
105106
List.iter (fun (
106-
{ Clambda. label; arity; params; body; dbg; env; } as clos) ->
107+
{ Clambda. label; arity; params; return; body; dbg; env; } as clos) ->
107108
(match closure_environment_var clos with
108109
| None -> ()
109110
| Some env_var ->
110111
environment_vars :=
111112
V.Set.add (VP.var env_var) !environment_vars);
112113
ignore_function_label label;
113114
ignore_int arity;
114-
ignore_var_with_provenance_list params;
115+
ignore_params_with_value_kind params;
116+
ignore_value_kind return;
115117
loop body;
116118
ignore_debuginfo dbg;
117119
ignore_var_option env)
@@ -156,7 +158,7 @@ let make_var_info (clam : Clambda.ulambda) : var_info =
156158
List.iter loop args
157159
| Ucatch (static_exn, vars, body, handler) ->
158160
ignore_int static_exn;
159-
ignore_var_with_provenance_list vars;
161+
ignore_params_with_value_kind vars;
160162
loop body;
161163
loop handler
162164
| Utrywith (body, var, handler) ->
@@ -276,10 +278,11 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) =
276278
| Uclosure (functions, captured_variables) ->
277279
ignore_ulambda_list captured_variables;
278280
(* Start a new let stack for speed. *)
279-
List.iter (fun { Clambda. label; arity; params; body; dbg; env; } ->
281+
List.iter (fun {Clambda. label; arity; params; return; body; dbg; env} ->
280282
ignore_function_label label;
281283
ignore_int arity;
282-
ignore_var_with_provenance_list params;
284+
ignore_params_with_value_kind params;
285+
ignore_value_kind return;
283286
let_stack := [];
284287
loop body;
285288
let_stack := [];
@@ -358,7 +361,7 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) =
358361
examine_argument_list args
359362
| Ucatch (static_exn, vars, body, handler) ->
360363
ignore_int static_exn;
361-
ignore_var_with_provenance_list vars;
364+
ignore_params_with_value_kind vars;
362365
let_stack := [];
363366
loop body;
364367
let_stack := [];

0 commit comments

Comments
 (0)