Skip to content

Commit 4cd4891

Browse files
mshinwellGbury
mshinwell
and
Gbury
authored
Add is_last flag to closinfo words (#938)
Co-authored-by: Guillaume Bury <[email protected]>
1 parent 03a3cde commit 4cd4891

File tree

16 files changed

+108
-63
lines changed

16 files changed

+108
-63
lines changed

‎backend/cmm_helpers.ml

Lines changed: 18 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -106,16 +106,20 @@ let caml_int64_ops = "caml_int64_ops"
106106
let pos_arity_in_closinfo = (8 * size_addr) - 8
107107
(* arity = the top 8 bits of the closinfo word *)
108108

109-
let closure_info ~arity ~startenv =
109+
let closure_info ~arity ~startenv ~is_last =
110110
let arity =
111111
match arity with Lambda.Tupled, n -> -n | Lambda.Curried _, n -> n
112112
in
113113
assert (-128 <= arity && arity <= 127);
114-
assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 1));
114+
assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 2));
115115
Nativeint.(
116116
add
117117
(shift_left (of_int arity) pos_arity_in_closinfo)
118-
(add (shift_left (of_int startenv) 1) 1n))
118+
(add
119+
(shift_left
120+
(Bool.to_int is_last |> Nativeint.of_int)
121+
(pos_arity_in_closinfo - 1))
122+
(add (shift_left (of_int startenv) 1) 1n)))
119123

120124
let alloc_float_header mode dbg =
121125
match mode with
@@ -131,8 +135,8 @@ let alloc_closure_header ~mode sz dbg =
131135

132136
let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg)
133137

134-
let alloc_closure_info ~arity ~startenv dbg =
135-
Cconst_natint (closure_info ~arity ~startenv, dbg)
138+
let alloc_closure_info ~arity ~startenv ~is_last dbg =
139+
Cconst_natint (closure_info ~arity ~startenv ~is_last, dbg)
136140

137141
let alloc_boxedint32_header mode dbg =
138142
match mode with
@@ -2548,7 +2552,7 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
25482552
Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1), dbg ());
25492553
alloc_closure_info
25502554
~arity:(curried (arity - num - 1))
2551-
~startenv:3 (dbg ());
2555+
~startenv:3 (dbg ()) ~is_last:true;
25522556
Cconst_symbol
25532557
(name1 ^ "_" ^ Int.to_string (num + 1) ^ "_app", dbg ());
25542558
Cvar arg;
@@ -2559,7 +2563,8 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
25592563
( Calloc mode,
25602564
[ alloc_closure_header ~mode 4 (dbg ());
25612565
Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1), dbg ());
2562-
alloc_closure_info ~arity:(curried 1) ~startenv:2 (dbg ());
2566+
alloc_closure_info ~arity:(curried 1) ~startenv:2
2567+
~is_last:true (dbg ());
25632568
Cvar arg;
25642569
Cvar clos ],
25652570
dbg () ));
@@ -3832,31 +3837,33 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
38323837
let rec emit_others pos = function
38333838
| [] -> clos_vars @ cont
38343839
| (f2 : Clambda.ufunction) :: rem -> (
3840+
let is_last = match rem with [] -> true | _ :: _ -> false in
38353841
match f2.arity with
38363842
| (Curried _, (0 | 1)) as arity ->
38373843
(Cint (infix_header pos) :: closure_symbol f2)
38383844
@ Csymbol_address f2.label
3839-
:: Cint (closure_info ~arity ~startenv:(startenv - pos))
3845+
:: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last)
38403846
:: emit_others (pos + 3) rem
38413847
| arity ->
38423848
(Cint (infix_header pos) :: closure_symbol f2)
38433849
@ Csymbol_address (curry_function_sym arity)
3844-
:: Cint (closure_info ~arity ~startenv:(startenv - pos))
3850+
:: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last)
38453851
:: Csymbol_address f2.label
38463852
:: emit_others (pos + 4) rem)
38473853
in
3854+
let is_last = match remainder with [] -> true | _ :: _ -> false in
38483855
Cint (black_closure_header (fundecls_size fundecls + List.length clos_vars))
38493856
:: cdefine_symbol symb
38503857
@ closure_symbol f1
38513858
@
38523859
match f1.arity with
38533860
| (Curried _, (0 | 1)) as arity ->
38543861
Csymbol_address f1.label
3855-
:: Cint (closure_info ~arity ~startenv)
3862+
:: Cint (closure_info ~arity ~startenv ~is_last)
38563863
:: emit_others 3 remainder
38573864
| arity ->
38583865
Csymbol_address (curry_function_sym arity)
3859-
:: Cint (closure_info ~arity ~startenv)
3866+
:: Cint (closure_info ~arity ~startenv ~is_last)
38603867
:: Csymbol_address f1.label :: emit_others 4 remainder)
38613868

38623869
(* Build the NULL terminated array of gc roots *)

‎backend/cmm_helpers.mli

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -60,13 +60,18 @@ val boxedint64_header : nativeint
6060
val boxedintnat_header : nativeint
6161

6262
(** Closure info for a closure of given arity and distance to environment *)
63-
val closure_info : arity:Clambda.arity -> startenv:int -> nativeint
63+
val closure_info :
64+
arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint
6465

6566
(** Wrappers *)
6667
val alloc_infix_header : int -> Debuginfo.t -> expression
6768

6869
val alloc_closure_info :
69-
arity:Lambda.function_kind * int -> startenv:int -> Debuginfo.t -> expression
70+
arity:Lambda.function_kind * int ->
71+
startenv:int ->
72+
is_last:bool ->
73+
Debuginfo.t ->
74+
expression
7075

7176
(** Integers *)
7277

‎backend/cmmgen.ml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -452,19 +452,20 @@ let rec transl env e =
452452
[] ->
453453
List.map (transl env) clos_vars
454454
| f :: rem ->
455+
let is_last = match rem with [] -> true | _::_ -> false in
455456
Cmmgen_state.add_function f;
456457
let dbg = f.dbg in
457458
let without_header =
458459
match f.arity with
459460
| Curried _, (1|0) as arity ->
460461
Cconst_symbol (f.label, dbg) ::
461462
alloc_closure_info ~arity
462-
~startenv:(startenv - pos) dbg ::
463+
~startenv:(startenv - pos) ~is_last dbg ::
463464
transl_fundecls (pos + 3) rem
464465
| arity ->
465466
Cconst_symbol (curry_function_sym arity, dbg) ::
466467
alloc_closure_info ~arity
467-
~startenv:(startenv - pos) dbg ::
468+
~startenv:(startenv - pos) ~is_last dbg ::
468469
Cconst_symbol (f.label, dbg) ::
469470
transl_fundecls (pos + 4) rem
470471
in

‎middle_end/flambda2/simplify_shared/slot_offsets.ml

Lines changed: 20 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -92,7 +92,8 @@ module Layout = struct
9292
| Infix_header
9393
| Function_slot of
9494
{ size : words;
95-
function_slot : Function_slot.t
95+
function_slot : Function_slot.t;
96+
last_function_slot : bool
9697
}
9798

9899
type t =
@@ -104,9 +105,10 @@ module Layout = struct
104105
let print_slot fmt = function
105106
| Value_slot v -> Format.fprintf fmt "value_slot %a" Value_slot.print v
106107
| Infix_header -> Format.fprintf fmt "infix_header"
107-
| Function_slot { size; function_slot } ->
108-
Format.fprintf fmt "function_slot(%d) %a" size Function_slot.print
109-
function_slot
108+
| Function_slot { size; function_slot; last_function_slot } ->
109+
Format.fprintf fmt "function_slot%s(%d) %a"
110+
(if last_function_slot then "[last]" else "")
111+
size Function_slot.print function_slot
110112

111113
let print fmt l =
112114
Format.fprintf fmt "@[<v>startenv: %d;@ " l.startenv;
@@ -122,7 +124,7 @@ module Layout = struct
122124
| Some Dead_function_slot -> acc
123125
| Some (Live_function_slot { size; offset }) ->
124126
Numeric_types.Int.Map.add offset
125-
(Function_slot { size; function_slot })
127+
(Function_slot { size; function_slot; last_function_slot = false })
126128
acc
127129
| None ->
128130
Misc.fatal_errorf "No function_slot offset for %a" Function_slot.print
@@ -166,12 +168,20 @@ module Layout = struct
166168
in
167169
startenv, acc_slots
168170
| Value_slot _ ->
169-
let startenv =
170-
match startenv with
171-
| Some i ->
171+
let startenv, acc_slots =
172+
match startenv, acc_slots with
173+
| Some i, _ ->
172174
assert (i < offset);
173-
startenv
174-
| None -> Some offset
175+
startenv, acc_slots
176+
| None, (o, Function_slot s) :: r ->
177+
( Some offset,
178+
(o, Function_slot { s with last_function_slot = true }) :: r )
179+
| None, [] -> Misc.fatal_errorf "Set of closures with no closure slot"
180+
| None, (_, ((Value_slot _ | Infix_header) as slot)) :: _ ->
181+
Misc.fatal_errorf
182+
"Expected a function slot right before the first value slot, but \
183+
found %a"
184+
print_slot slot
175185
in
176186
let acc_slots = (offset, slot) :: acc_slots in
177187
startenv, acc_slots

‎middle_end/flambda2/simplify_shared/slot_offsets.mli

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,8 @@ module Layout : sig
8282
| Infix_header
8383
| Function_slot of
8484
{ size : int;
85-
function_slot : Function_slot.t
85+
function_slot : Function_slot.t;
86+
last_function_slot : bool
8687
}
8788
(**)
8889

‎middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -135,14 +135,15 @@ end = struct
135135
env, res, [P.int ~dbg 1n], updates)
136136
in
137137
List.rev_append fields acc, slot_offset + 1, env, res, eff, updates
138-
| Function_slot { size; function_slot } -> (
138+
| Function_slot { size; function_slot; last_function_slot } -> (
139139
let code_id = Function_slot.Map.find function_slot decls in
140140
let code_linkage_name = Code_id.linkage_name code_id in
141141
let arity, closure_code_pointers, dbg =
142142
get_func_decl_params_arity env code_id
143143
in
144144
let closure_info =
145145
C.closure_info ~arity ~startenv:(startenv - slot_offset)
146+
~is_last:last_function_slot
146147
in
147148
let acc =
148149
match for_static_sets with

‎ocaml/asmcomp/cmm_helpers.ml

Lines changed: 18 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -80,17 +80,20 @@ let caml_int64_ops = "caml_int64_ops"
8080
let pos_arity_in_closinfo = 8 * size_addr - 8
8181
(* arity = the top 8 bits of the closinfo word *)
8282

83-
let closure_info ~arity ~startenv =
83+
let closure_info ~arity ~startenv ~is_last =
8484
let arity =
8585
match arity with
8686
| Lambda.Tupled, n -> -n
8787
| Lambda.Curried _, n -> n
8888
in
8989
assert (-128 <= arity && arity <= 127);
90-
assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 1));
90+
assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 2));
9191
Nativeint.(add (shift_left (of_int arity) pos_arity_in_closinfo)
92-
(add (shift_left (of_int startenv) 1)
93-
1n))
92+
(add
93+
(shift_left
94+
(Bool.to_int is_last |> Nativeint.of_int)
95+
(pos_arity_in_closinfo - 1))
96+
(add (shift_left (of_int startenv) 1) 1n)))
9497

9598
let alloc_float_header mode dbg =
9699
match mode with
@@ -102,8 +105,8 @@ let alloc_closure_header ~mode sz dbg =
102105
| Alloc_heap -> Cconst_natint (white_closure_header sz, dbg)
103106
| Alloc_local -> Cconst_natint (local_closure_header sz, dbg)
104107
let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg)
105-
let alloc_closure_info ~arity ~startenv dbg =
106-
Cconst_natint (closure_info ~arity ~startenv, dbg)
108+
let alloc_closure_info ~arity ~startenv ~is_last dbg =
109+
Cconst_natint (closure_info ~arity ~startenv ~is_last, dbg)
107110
let alloc_boxedint32_header mode dbg =
108111
match mode with
109112
| Lambda.Alloc_heap -> Cconst_natint (boxedint32_header, dbg)
@@ -2161,7 +2164,7 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
21612164
[alloc_closure_header ~mode 5 (dbg ());
21622165
Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ());
21632166
alloc_closure_info ~arity:(curried (arity - num - 1))
2164-
~startenv:3 (dbg ());
2167+
~startenv:3 ~is_last:true (dbg ());
21652168
Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1) ^ "_app",
21662169
dbg ());
21672170
Cvar arg; Cvar clos],
@@ -2170,7 +2173,8 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
21702173
Cop(Calloc mode,
21712174
[alloc_closure_header ~mode 4 (dbg ());
21722175
Cconst_symbol(name1 ^ "_" ^ Int.to_string (num+1), dbg ());
2173-
alloc_closure_info ~arity:(curried 1) ~startenv:2 (dbg ());
2176+
alloc_closure_info ~arity:(curried 1) ~startenv:2
2177+
~is_last:true (dbg ());
21742178
Cvar arg; Cvar clos],
21752179
dbg ());
21762180
fun_codegen_options = [];
@@ -2915,32 +2919,34 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont =
29152919
let rec emit_others pos = function
29162920
[] -> clos_vars @ cont
29172921
| (f2 : Clambda.ufunction) :: rem ->
2922+
let is_last = match rem with [] -> true | _ :: _ -> false in
29182923
match f2.arity with
29192924
| Curried _, (0|1) as arity ->
29202925
Cint(infix_header pos) ::
29212926
(closure_symbol f2) @
29222927
Csymbol_address f2.label ::
2923-
Cint(closure_info ~arity ~startenv:(startenv - pos)) ::
2928+
Cint(closure_info ~arity ~startenv:(startenv - pos) ~is_last) ::
29242929
emit_others (pos + 3) rem
29252930
| arity ->
29262931
Cint(infix_header pos) ::
29272932
(closure_symbol f2) @
29282933
Csymbol_address(curry_function_sym f2.arity) ::
2929-
Cint(closure_info ~arity ~startenv:(startenv - pos)) ::
2934+
Cint(closure_info ~arity ~startenv:(startenv - pos) ~is_last) ::
29302935
Csymbol_address f2.label ::
29312936
emit_others (pos + 4) rem in
2937+
let is_last = match remainder with [] -> true | _ :: _ -> false in
29322938
Cint(black_closure_header (fundecls_size fundecls
29332939
+ List.length clos_vars)) ::
29342940
cdefine_symbol symb @
29352941
(closure_symbol f1) @
29362942
match f1.arity with
29372943
| Curried _, (0|1) as arity ->
29382944
Csymbol_address f1.label ::
2939-
Cint(closure_info ~arity ~startenv) ::
2945+
Cint(closure_info ~arity ~startenv ~is_last) ::
29402946
emit_others 3 remainder
29412947
| arity ->
29422948
Csymbol_address(curry_function_sym f1.arity) ::
2943-
Cint(closure_info ~arity ~startenv) ::
2949+
Cint(closure_info ~arity ~startenv ~is_last) ::
29442950
Csymbol_address f1.label ::
29452951
emit_others 4 remainder
29462952

‎ocaml/asmcomp/cmm_helpers.mli

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -59,12 +59,13 @@ val boxedint64_header : nativeint
5959
val boxedintnat_header : nativeint
6060

6161
(** Closure info for a closure of given arity and distance to environment *)
62-
val closure_info : arity:Clambda.arity -> startenv:int -> nativeint
62+
val closure_info : arity:Clambda.arity -> startenv:int -> is_last:bool
63+
-> nativeint
6364

6465
(** Wrappers *)
6566
val alloc_infix_header : int -> Debuginfo.t -> expression
6667
val alloc_closure_info :
67-
arity:(Lambda.function_kind * int) -> startenv:int ->
68+
arity:(Lambda.function_kind * int) -> startenv:int -> is_last:bool ->
6869
Debuginfo.t -> expression
6970

7071
(** Integers *)

‎ocaml/asmcomp/cmmgen.ml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -395,19 +395,20 @@ let rec transl env e =
395395
[] ->
396396
List.map (transl env) clos_vars
397397
| f :: rem ->
398+
let is_last = match rem with [] -> true | _::_ -> false in
398399
Cmmgen_state.add_function f;
399400
let dbg = f.dbg in
400401
let without_header =
401402
match f.arity with
402403
| Curried _, (1|0) as arity ->
403404
Cconst_symbol (f.label, dbg) ::
404405
alloc_closure_info ~arity
405-
~startenv:(startenv - pos) dbg ::
406+
~startenv:(startenv - pos) ~is_last dbg ::
406407
transl_fundecls (pos + 3) rem
407408
| arity ->
408409
Cconst_symbol (curry_function_sym f.arity, dbg) ::
409410
alloc_closure_info ~arity
410-
~startenv:(startenv - pos) dbg ::
411+
~startenv:(startenv - pos) ~is_last dbg ::
411412
Cconst_symbol (f.label, dbg) ::
412413
transl_fundecls (pos + 4) rem
413414
in

‎ocaml/runtime/alloc.c

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -229,7 +229,7 @@ CAMLprim value caml_alloc_dummy_infix(value vsize, value voffset)
229229
block contains no pointers into the heap. However, the block
230230
cannot be marshaled or hashed, because not all closinfo fields
231231
and infix header fields are correctly initialized. */
232-
Closinfo_val(v) = Make_closinfo(0, wosize);
232+
Closinfo_val(v) = Make_closinfo(0, wosize, 1);
233233
if (offset > 0) {
234234
v += Bsize_wsize(offset);
235235
Hd_val(v) = Make_header(offset, Infix_tag, Caml_white);

0 commit comments

Comments
 (0)