Skip to content

Commit 918226f

Browse files
stedolanstedolan
committed
Allow local closure allocations (#27)
This commit breaks systhreads tests: local allocations do not yet work with threads, but this patch causes some to happen anyway. (+Bootstrap)
1 parent 2552e7d commit 918226f

File tree

20 files changed

+135
-88
lines changed

20 files changed

+135
-88
lines changed

‎asmcomp/cmmgen.ml

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -377,6 +377,16 @@ let rec transl env e =
377377
Cconst_symbol (sym, dbg)
378378
| Uclosure(fundecls, clos_vars) ->
379379
let startenv = fundecls_size fundecls in
380+
let mode =
381+
Option.get @@
382+
List.fold_left (fun s { mode; dbg; _ } ->
383+
match s with
384+
| None -> Some mode
385+
| Some m' ->
386+
if (mode <> m') then
387+
Misc.fatal_errorf "Inconsistent modes in let rec at %s"
388+
(Debuginfo.to_string dbg);
389+
s) None fundecls in
380390
let rec transl_fundecls pos = function
381391
[] ->
382392
List.map (transl env) clos_vars
@@ -405,7 +415,7 @@ let rec transl env e =
405415
| [] -> Debuginfo.none
406416
| fundecl::_ -> fundecl.dbg
407417
in
408-
make_alloc dbg Obj.closure_tag (transl_fundecls 0 fundecls)
418+
make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 fundecls)
409419
| Uoffset(arg, offset) ->
410420
(* produces a valid Caml value, pointing just after an infix header *)
411421
let ptr = transl env arg in

‎boot/ocamlc

2.57 KB
Binary file not shown.

‎boot/ocamllex

0 Bytes
Binary file not shown.

‎lambda/lambda.ml

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -316,7 +316,8 @@ and lfunction =
316316
return: value_kind;
317317
body: lambda;
318318
attr: function_attribute; (* specified with [@inline] attribute *)
319-
loc: scoped_location; }
319+
loc: scoped_location;
320+
mode: alloc_mode }
320321

321322
and lambda_apply =
322323
{ ap_func : lambda;
@@ -841,8 +842,8 @@ let shallow_map f = function
841842
ap_inlined;
842843
ap_specialised;
843844
}
844-
| Lfunction { kind; params; return; body; attr; loc; } ->
845-
Lfunction { kind; params; return; body = f body; attr; loc; }
845+
| Lfunction { kind; params; return; body; attr; loc; mode } ->
846+
Lfunction { kind; params; return; body = f body; attr; loc; mode }
846847
| Llet (str, k, v, e1, e2) ->
847848
Llet (str, k, v, f e1, f e2)
848849
| Lletrec (idel, e2) ->

‎lambda/lambda.mli

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -300,7 +300,8 @@ and lfunction =
300300
return: value_kind;
301301
body: lambda;
302302
attr: function_attribute; (* specified with [@inline] attribute *)
303-
loc : scoped_location; }
303+
loc : scoped_location;
304+
mode : alloc_mode }
304305

305306
and lambda_apply =
306307
{ ap_func : lambda;

‎lambda/simplif.ml

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -210,8 +210,8 @@ let simplify_exits lam =
210210
| Lapply ap ->
211211
Lapply{ap with ap_func = simplif ap.ap_func;
212212
ap_args = List.map simplif ap.ap_args}
213-
| Lfunction{kind; params; return; body = l; attr; loc} ->
214-
Lfunction{kind; params; return; body = simplif l; attr; loc}
213+
| Lfunction{kind; params; return; body = l; attr; loc; mode} ->
214+
Lfunction{kind; params; return; body = simplif l; attr; loc; mode}
215215
| Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2)
216216
| Lletrec(bindings, body) ->
217217
Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
@@ -523,19 +523,19 @@ let simplify_lets lam =
523523
end
524524
| _ -> no_opt ()
525525
end
526-
| Lfunction{kind; params; return=return1; body = l; attr; loc} ->
526+
| Lfunction{kind; params; return=return1; body = l; attr; loc; mode} ->
527527
begin match simplif l with
528-
Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc}
528+
Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc; mode}
529529
when kind = Curried && optimize &&
530530
List.length params + List.length params' <= Lambda.max_arity() ->
531531
(* The return type is the type of the value returned after
532532
applying all the parameters to the function. The return
533533
type of the merged function taking [params @ params'] as
534534
parameters is the type returned after applying [params']. *)
535535
let return = return2 in
536-
Lfunction{kind; params = params @ params'; return; body; attr; loc}
536+
Lfunction{kind; params = params @ params'; return; body; attr; loc; mode}
537537
| body ->
538-
Lfunction{kind; params; return = return1; body; attr; loc}
538+
Lfunction{kind; params; return = return1; body; attr; loc; mode}
539539
end
540540
| Llet(_str, _k, v, Lvar w, l2) when optimize ->
541541
Hashtbl.add subst v (simplif (Lvar w));
@@ -710,7 +710,7 @@ and list_emit_tail_infos is_tail =
710710
'Some' constructor, only to deconstruct it immediately in the
711711
function's body. *)
712712

713-
let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
713+
let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc ~mode =
714714
let rec aux map = function
715715
| Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
716716
Ident.name optparam = "*opt*" && List.mem_assoc optparam params
@@ -749,16 +749,16 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
749749
let inner_fun =
750750
Lfunction { kind = Curried;
751751
params = List.map (fun id -> id, Pgenval) new_ids;
752-
return; body; attr; loc; }
752+
return; body; attr; loc; mode }
753753
in
754754
(wrapper_body, (inner_id, inner_fun))
755755
in
756756
try
757757
let body, inner = aux [] body in
758758
let attr = default_stub_attribute in
759-
[(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner]
759+
[(fun_id, Lfunction{kind; params; return; body; attr; loc; mode}); inner]
760760
with Exit ->
761-
[(fun_id, Lfunction{kind; params; return; body; attr; loc})]
761+
[(fun_id, Lfunction{kind; params; return; body; attr; loc; mode})]
762762

763763
(* Simplify local let-bound functions: if all occurrences are
764764
fully-applied function calls in the same "tail scope", replace the

‎lambda/simplif.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,4 +37,5 @@ val split_default_wrapper
3737
-> body:lambda
3838
-> attr:function_attribute
3939
-> loc:Lambda.scoped_location
40+
-> mode:Lambda.alloc_mode
4041
-> (Ident.t * lambda) list

‎lambda/translclass.ml

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -35,12 +35,12 @@ let lfunction params body =
3535
Lfunction {kind = Curried; params = params @ params';
3636
return = Pgenval;
3737
body = body'; attr;
38-
loc}
38+
loc; mode = Alloc_heap}
3939
| _ ->
4040
Lfunction {kind = Curried; params; return = Pgenval;
4141
body;
4242
attr = default_function_attribute;
43-
loc = Loc_unknown}
43+
loc = Loc_unknown; mode = Alloc_heap}
4444

4545
let lapply ap =
4646
match ap.ap_func with
@@ -184,7 +184,8 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl =
184184
attr = default_function_attribute;
185185
loc = of_location ~scopes pat.pat_loc;
186186
body = Matching.for_function ~scopes pat.pat_loc
187-
None (Lvar param) [pat, rem] partial}
187+
None (Lvar param) [pat, rem] partial;
188+
mode = Alloc_heap }
188189
in
189190
begin match obj_init with
190191
Lfunction {kind = Curried; params; body = rem} -> build params rem
@@ -445,7 +446,8 @@ let rec transl_class_rebind ~scopes obj_init cl vf =
445446
attr = default_function_attribute;
446447
loc = of_location ~scopes pat.pat_loc;
447448
body = Matching.for_function ~scopes pat.pat_loc
448-
None (Lvar param) [pat, rem] partial}
449+
None (Lvar param) [pat, rem] partial;
450+
mode = Alloc_heap}
449451
in
450452
(path, path_lam,
451453
match obj_init with
@@ -798,6 +800,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
798800
attr = default_function_attribute;
799801
loc = Loc_unknown;
800802
return = Pgenval;
803+
mode = Alloc_heap;
801804
params = [cla, Pgenval]; body = cl_init}) in
802805
Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
803806
and lbody fv =
@@ -820,6 +823,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
820823
attr = default_function_attribute;
821824
loc = Loc_unknown;
822825
return = Pgenval;
826+
mode = Alloc_heap;
823827
params = [cla, Pgenval]; body = cl_init};
824828
lambda_unit; lenvs],
825829
Loc_unknown)
@@ -876,6 +880,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
876880
return = Pgenval;
877881
attr = default_function_attribute;
878882
loc = Loc_unknown;
883+
mode = Alloc_heap;
879884
body = def_ids cla cl_init}, lam)
880885
and lcache lam =
881886
if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
@@ -900,6 +905,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag =
900905
kind = Curried;
901906
attr = default_function_attribute;
902907
loc = Loc_unknown;
908+
mode = Alloc_heap;
903909
return = Pgenval;
904910
params = [cla, Pgenval];
905911
body = def_ids cla cl_init;

‎lambda/translcore.ml

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -595,14 +595,16 @@ and transl_exp0 ~in_new_scope ~scopes e =
595595
transl_exp ~scopes e
596596
| `Other ->
597597
(* other cases compile to a lazy block holding a function *)
598+
let mode = transl_alloc_mode e.exp_mode in (* FIXME test *)
598599
let fn = Lfunction {kind = Curried;
599600
params= [Ident.create_local "param", Pgenval];
600601
return = Pgenval;
601602
attr = default_function_attribute;
602603
loc = of_location ~scopes e.exp_loc;
604+
mode;
603605
body = transl_exp ~scopes e} in
604606
Lprim(Pmakeblock(Config.lazy_tag, Mutable, None,
605-
transl_alloc_mode e.exp_mode), [fn],
607+
mode), [fn],
606608
of_location ~scopes e.exp_loc)
607609
end
608610
| Texp_object (cs, meths) ->
@@ -748,22 +750,24 @@ and transl_apply ~scopes
748750
let body =
749751
match build_apply handle ((Lvar id_arg, optional)::args') l with
750752
Lfunction{kind = Curried; params = ids; return;
751-
body = lam; attr; loc} ->
753+
body = lam; attr; loc; mode} ->
752754
Lfunction{kind = Curried;
753755
params = (id_arg, Pgenval)::ids;
754756
return;
755757
body = lam; attr;
756-
loc}
758+
loc;
759+
mode} (* FIXME mode *)
757760
| Levent(Lfunction{kind = Curried; params = ids; return;
758-
body = lam; attr; loc}, _) ->
761+
body = lam; attr; loc; mode}, _) ->
759762
Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids;
760763
return;
761764
body = lam; attr;
762-
loc}
765+
loc;
766+
mode} (* FIXME mode *)
763767
| lam ->
764768
Lfunction{kind = Curried; params = [id_arg, Pgenval];
765769
return = Pgenval; body = lam;
766-
attr = default_stub_attribute; loc = loc}
770+
attr = default_stub_attribute; loc = loc; mode=Alloc_heap (* FIXME *)}
767771
in
768772
List.fold_left
769773
(fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
@@ -895,7 +899,8 @@ and transl_function ~scopes e param cases partial =
895899
in
896900
let attr = default_function_attribute in
897901
let loc = of_location ~scopes e.exp_loc in
898-
let lam = Lfunction{kind; params; return; body; attr; loc} in
902+
let mode = transl_alloc_mode e.exp_mode in
903+
let lam = Lfunction{kind; params; return; body; attr; loc; mode} in
899904
Translattribute.add_function_attributes lam e.exp_loc e.exp_attributes
900905

901906
(* Like transl_exp, but used when a new scope was just introduced. *)
@@ -1189,7 +1194,7 @@ and transl_letop ~scopes loc env let_ ands param case partial =
11891194
in
11901195
let attr = default_function_attribute in
11911196
let loc = of_location ~scopes case.c_rhs.exp_loc in
1192-
Lfunction{kind; params; return; body; attr; loc}
1197+
Lfunction{kind; params; return; body; attr; loc; mode=Alloc_heap(*FIXME*)}
11931198
in
11941199
Lapply{
11951200
ap_loc = of_location ~scopes loc;

‎lambda/translmod.ml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -124,6 +124,7 @@ and apply_coercion_result loc strict funct params args cc_res =
124124
is_a_functor = true;
125125
stub = true; };
126126
loc = loc;
127+
mode = Alloc_heap;
127128
body = apply_coercion
128129
loc Strict cc_res
129130
(Lapply{
@@ -495,6 +496,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc =
495496
stub = false;
496497
};
497498
loc;
499+
mode = Alloc_heap;
498500
body;
499501
}
500502

‎lambda/translprim.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -740,7 +740,8 @@ let transl_primitive loc p env ty path =
740740
return = Pgenval;
741741
attr = default_stub_attribute;
742742
loc;
743-
body; }
743+
body;
744+
mode = Alloc_heap (*FIXME*) }
744745

745746
let lambda_primitive_needs_event_after = function
746747
| Prevapply | Pdirapply (* PR#6920 *)

‎middle_end/clambda.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -83,6 +83,7 @@ and ufunction = {
8383
body : ulambda;
8484
dbg : Debuginfo.t;
8585
env : Backend_var.t option;
86+
mode : Lambda.alloc_mode;
8687
}
8788

8889
and ulambda_switch =

‎middle_end/clambda.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -94,6 +94,7 @@ and ufunction = {
9494
body : ulambda;
9595
dbg : Debuginfo.t;
9696
env : Backend_var.t option;
97+
mode : Lambda.alloc_mode;
9798
}
9899

99100
and ulambda_switch =

‎middle_end/closure/closure.ml

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -956,6 +956,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
956956
ap_specialised=Default_specialise;
957957
};
958958
loc;
959+
mode = Alloc_heap; (* FIXME BUG: wrong mode *)
959960
attr = default_function_attribute})
960961
in
961962
let new_fun =
@@ -1228,8 +1229,8 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
12281229
List.flatten
12291230
(List.map
12301231
(function
1231-
| (id, Lfunction{kind; params; return; body; attr; loc}) ->
1232-
Simplif.split_default_wrapper ~id ~kind ~params
1232+
| (id, Lfunction{kind; params; return; body; attr; loc; mode}) ->
1233+
Simplif.split_default_wrapper ~id ~kind ~params ~mode
12331234
~body ~attr ~loc ~return
12341235
| _ -> assert false
12351236
)
@@ -1252,7 +1253,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
12521253
let uncurried_defs =
12531254
List.map
12541255
(function
1255-
(id, Lfunction{kind; params; return; body; loc}) ->
1256+
(id, Lfunction{kind; params; return; body; loc; mode}) ->
12561257
let label = Compilenv.make_symbol (Some (V.unique_name id)) in
12571258
let arity = List.length params in
12581259
let fundesc =
@@ -1262,20 +1263,20 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
12621263
fun_inline = None;
12631264
fun_float_const_prop = !Clflags.float_const_prop } in
12641265
let dbg = Debuginfo.from_location loc in
1265-
(id, params, return, body, fundesc, dbg)
1266+
(id, params, return, body, mode, fundesc, dbg)
12661267
| (_, _) -> fatal_error "Closure.close_functions")
12671268
fun_defs in
12681269
(* Build an approximate fenv for compiling the functions *)
12691270
let fenv_rec =
12701271
List.fold_right
1271-
(fun (id, _params, _return, _body, fundesc, _dbg) fenv ->
1272+
(fun (id, _params, _return, _body, _mode, fundesc, _dbg) fenv ->
12721273
V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv)
12731274
uncurried_defs fenv in
12741275
(* Determine the offsets of each function's closure in the shared block *)
12751276
let env_pos = ref (-1) in
12761277
let clos_offsets =
12771278
List.map
1278-
(fun (_id, _params, _return, _body, fundesc, _dbg) ->
1279+
(fun (_id, _params, _return, _body, _mode, fundesc, _dbg) ->
12791280
let pos = !env_pos + 1 in
12801281
env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
12811282
pos)
@@ -1285,13 +1286,13 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
12851286
does not use its environment parameter is invalidated. *)
12861287
let useless_env = ref initially_closed in
12871288
(* Translate each function definition *)
1288-
let clos_fundef (id, params, return, body, fundesc, dbg) env_pos =
1289+
let clos_fundef (id, params, return, body, mode, fundesc, dbg) env_pos =
12891290
let env_param = V.create_local "env" in
12901291
let cenv_fv =
12911292
build_closure_env env_param (fv_pos - env_pos) fv in
12921293
let cenv_body =
12931294
List.fold_right2
1294-
(fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
1295+
(fun (id, _params, _return, _body, _mode, _fundesc, _dbg) pos env ->
12951296
V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
12961297
uncurried_defs clos_offsets cenv_fv in
12971298
let (ubody, approx) =
@@ -1312,6 +1313,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
13121313
body = ubody;
13131314
dbg;
13141315
env = Some env_param;
1316+
mode;
13151317
}
13161318
in
13171319
(* give more chance of function with default parameters (i.e.
@@ -1350,7 +1352,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs =
13501352
recompile *)
13511353
Compilenv.backtrack snap; (* PR#6337 *)
13521354
List.iter
1353-
(fun (_id, _params, _return, _body, fundesc, _dbg) ->
1355+
(fun (_id, _params, _return, _body, _mode, fundesc, _dbg) ->
13541356
fundesc.fun_closed <- false;
13551357
fundesc.fun_inline <- None;
13561358
)

0 commit comments

Comments
 (0)