Skip to content

Commit f80990e

Browse files
lpw25lpw25
committed
Store both ends of the stack chain in continuations
1 parent 243f4cd commit f80990e

File tree

14 files changed

+158
-94
lines changed

14 files changed

+158
-94
lines changed

‎asmcomp/cmmgen.ml

+39-7
Original file line numberDiff line numberDiff line change
@@ -608,6 +608,8 @@ let rec transl env e =
608608
transl_prim_2 env p arg1 arg2 dbg
609609
| (p, [arg1; arg2; arg3]) ->
610610
transl_prim_3 env p arg1 arg2 arg3 dbg
611+
| (p, [arg1; arg2; arg3; arg4]) ->
612+
transl_prim_4 env p arg1 arg2 arg3 arg4 dbg
611613
| (Pread_symbol _, _::_::_::_::_)
612614
| (Pbigarrayset (_, _, _, _), [])
613615
| (Pbigarrayref (_, _, _, _), [])
@@ -933,7 +935,9 @@ and transl_prim_1 env p arg dbg =
933935
tag_int (bswap16 (ignore_high_bit_int (untag_int
934936
(transl env arg) dbg)) dbg) dbg
935937
| Pperform ->
936-
let cont = make_alloc dbg Obj.cont_tag [int_const dbg 0] in
938+
let cont =
939+
make_alloc dbg Obj.cont_tag [int_const dbg 0; int_const dbg 0]
940+
in
937941
Cop(Capply typ_val,
938942
[Cconst_symbol ("caml_perform", dbg); transl env arg; cont],
939943
dbg)
@@ -1193,11 +1197,6 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
11931197
[transl env arg1; transl env arg2; transl env arg3], dbg)
11941198

11951199
(* Effects *)
1196-
| Presume ->
1197-
Cop (Capply typ_val,
1198-
[Cconst_symbol ("caml_resume", dbg);
1199-
transl env arg1; transl env arg2; transl env arg3],
1200-
dbg)
12011200

12021201
| Prunstack ->
12031202
Cop (Capply typ_val,
@@ -1211,7 +1210,40 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
12111210
transl env arg1; transl env arg2; transl env arg3],
12121211
dbg)
12131212

1214-
| Pperform | Pdls_get
1213+
| Pperform | Pdls_get | Presume
1214+
| Patomic_exchange | Patomic_fetch_add | Patomic_load _
1215+
| Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint
1216+
| Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint
1217+
| Pintoffloat | Pfloatofint | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat
1218+
| Pmulfloat | Pdivfloat | Pstringlength | Pstringrefu | Pstringrefs
1219+
| Pbyteslength | Pbytesrefu | Pbytesrefs | Pisint | Pisout
1220+
| Pbswap16 | Pint_as_pointer | Popaque | Pread_symbol _ | Pmakeblock (_, _, _)
1221+
| Pfield _ | Psetfield (_, _, _) | Pfloatfield _ | Psetfloatfield (_, _)
1222+
| Pduprecord (_, _) | Pccall _ | Praise _ | Pdivint _ | Pmodint _ | Pintcomp _
1223+
| Pcompare_ints | Pcompare_floats | Pcompare_bints _
1224+
| Poffsetint _ | Poffsetref _ | Pfloatcomp _ | Pmakearray (_, _)
1225+
| Pduparray (_, _) | Parraylength _ | Parrayrefu _ | Parrayrefs _
1226+
| Pbintofint _ | Pintofbint _ | Pcvtbint (_, _) | Pnegbint _ | Paddbint _
1227+
| Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _
1228+
| Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp (_, _)
1229+
| Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
1230+
| Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
1231+
->
1232+
fatal_errorf "Cmmgen.transl_prim_3: %a"
1233+
Printclambda_primitives.primitive p
1234+
1235+
and transl_prim_4 env p arg1 arg2 arg3 arg4 dbg =
1236+
match p with
1237+
| Presume ->
1238+
Cop (Capply typ_val,
1239+
[Cconst_symbol ("caml_resume", dbg);
1240+
transl env arg1; transl env arg2;
1241+
transl env arg3; transl env arg4],
1242+
dbg)
1243+
| Psetfield_computed _
1244+
| Pbytessetu | Pbytessets | Parraysetu _
1245+
| Parraysets _ | Pbytes_set _ | Pbigstring_set _ | Patomic_cas
1246+
| Prunstack | Preperform | Pperform | Pdls_get
12151247
| Patomic_exchange | Patomic_fetch_add | Patomic_load _
12161248
| Pfield_computed | Psequand | Psequor | Pnot | Pnegint | Paddint
12171249
| Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint

‎bytecomp/bytegen.ml

+24-6
Original file line numberDiff line numberDiff line change
@@ -888,16 +888,34 @@ let rec comp_expr stack_info env exp sz cont =
888888
(Kmakeblock(List.length args, 0) ::
889889
Kccall("caml_make_array", 1) :: cont)
890890
end
891-
| Lprim((Presume|Prunstack), args, _) ->
891+
| Lprim(Presume, args, _) ->
892892
let nargs = List.length args - 1 in
893-
assert (nargs = 2);
894-
(* Resume itself only pushes 3 words, but perform adds another *)
895-
check_stack stack_info (sz + 4);
896-
if is_tailcall cont then
893+
assert (nargs = 3);
894+
if is_tailcall cont then begin
895+
(* Resumeterm itself only pushes 2 words, but perform adds another *)
896+
check_stack stack_info 3;
897897
comp_args stack_info env args sz
898898
(Kresumeterm(sz + nargs) :: discard_dead_code cont)
899-
else
899+
end else begin
900+
(* Resume itself only pushes 2 words, but perform adds another *)
901+
check_stack stack_info (sz + nargs + 3);
900902
comp_args stack_info env args sz (Kresume :: cont)
903+
end
904+
| Lprim(Prunstack, args, _) ->
905+
let nargs = List.length args in
906+
assert (nargs = 3);
907+
if is_tailcall cont then begin
908+
(* Resumeterm itself only pushes 2 words, but perform adds another *)
909+
check_stack stack_info 3;
910+
Kconst const_unit :: Kpush ::
911+
comp_args stack_info env args (sz + 1)
912+
(Kresumeterm(sz + nargs) :: discard_dead_code cont)
913+
end else begin
914+
(* Resume itself only pushes 2 words, but perform adds another *)
915+
check_stack stack_info (sz + nargs + 3);
916+
Kconst const_unit :: Kpush ::
917+
comp_args stack_info env args (sz + 1) (Kresume :: cont)
918+
end
901919
| Lprim(Preperform, args, _) ->
902920
let nargs = List.length args - 1 in
903921
assert (nargs = 2);

‎lambda/translprim.ml

+2-1
Original file line numberDiff line numberDiff line change
@@ -130,6 +130,7 @@ let primitives_table =
130130
"%field0", Primitive (Pfield(0, Pointer, Mutable), 1);
131131
"%field1", Primitive (Pfield(1, Pointer, Mutable), 1);
132132
"%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2);
133+
"%setfield1", Primitive ((Psetfield(1, Pointer, Assignment)), 2);
133134
"%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1);
134135
"%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1);
135136
"%raise", Raise Raise_regular;
@@ -371,7 +372,7 @@ let primitives_table =
371372
"%runstack", Primitive (Prunstack, 3);
372373
"%reperform", Primitive (Preperform, 3);
373374
"%perform", Primitive (Pperform, 1);
374-
"%resume", Primitive (Presume, 3);
375+
"%resume", Primitive (Presume, 4);
375376
"%dls_get", Primitive (Pdls_get, 1);
376377
]
377378

‎runtime/amd64.S

+12-14
Original file line numberDiff line numberDiff line change
@@ -1190,20 +1190,22 @@ ENDFUNCTION(G(caml_reperform))
11901190

11911191
FUNCTION(G(caml_resume))
11921192
CFI_STARTPROC
1193-
/* %rax -> fiber, %rbx -> fun, %rdi -> arg */
1193+
/* %rax -> fiber, %rbx -> fun, %rdi -> arg, %rsi -> last_fiber */
11941194
leaq -1(%rax), %r10 /* %r10 (new stack) = Ptr_val(%rax) */
1195-
movq %rdi, %rax /* %rax := argument to function in %rbx */
1195+
movq %rdi, %rax /* %rax := argument to the function in %rbx */
11961196
/* check if stack null, then already used */
11971197
testq %r10, %r10
1198-
jz 2f
1198+
jz 1f
11991199
#if defined(WITH_THREAD_SANITIZER)
1200-
/* Save non-callee-saved registers %rax and %r10 before C call */
1200+
/* Save non-callee-saved registers %rax, %rsi and %r10 before C call */
12011201
ENTER_FUNCTION
12021202
pushq %rax; CFI_ADJUST(8);
1203+
pushq %rsi; CFI_ADJUST(8);
12031204
pushq %r10; CFI_ADJUST(8);
12041205
/* Necessary to include the caller of caml_resume in the TSan backtrace */
1205-
TSAN_ENTER_FUNCTION(16)
1206+
TSAN_ENTER_FUNCTION(24)
12061207
popq %r10; CFI_ADJUST(-8);
1208+
popq %rsi; CFI_ADJUST(-8);
12071209
popq %rax; CFI_ADJUST(-8);
12081210
TSAN_SAVE_CALLER_REGS
12091211
/* Signal to TSan all stack frames exited by the perform. */
@@ -1217,21 +1219,17 @@ CFI_STARTPROC
12171219
TSAN_RESTORE_CALLER_REGS
12181220
LEAVE_FUNCTION
12191221
#endif
1220-
/* Find end of list of stacks and add current */
1221-
movq %r10, %rsi
1222-
1: movq Stack_handler(%rsi), %rcx
1223-
movq Handler_parent(%rcx), %rsi
1224-
testq %rsi, %rsi
1225-
jnz 1b
1222+
/* Add current stack to the last fiber */
1223+
movq (Stack_handler-1)(%rsi), %rdi
12261224
movq Caml_state(current_stack), %rsi
1227-
movq %rsi, Handler_parent(%rcx)
1225+
movq %rsi, Handler_parent(%rdi)
12281226
/* Need to update the oldest saved frame pointer here as the current fiber
12291227
stack may have been reallocated or we may be resuming a computation
12301228
that was not originally run here. */
1231-
UPDATE_BASE_POINTER(%rcx)
1229+
UPDATE_BASE_POINTER(%rdi)
12321230
SWITCH_OCAML_STACKS
12331231
jmp *(%rbx)
1234-
2: ENTER_FUNCTION
1232+
1: ENTER_FUNCTION
12351233
TSAN_ENTER_FUNCTION(0) /* Necessary to include the caller of caml_resume
12361234
in the TSan backtrace */
12371235
LEA_VAR(caml_raise_continuation_already_resumed, %rax)

‎runtime/arm64.S

+8-10
Original file line numberDiff line numberDiff line change
@@ -810,23 +810,21 @@ FUNCTION(caml_resume)
810810
CFI_STARTPROC
811811
/* x0: new fiber
812812
x1: fun
813-
x2: arg */
813+
x2: arg
814+
x3: last_fiber */
814815
sub x0, x0, 1 /* x0 = Ptr_val(x0) */
815-
ldr x3, [x1] /* code pointer */
816+
ldr x4, [x1] /* code pointer */
816817
/* Check if stack null, then already used */
817-
cbz x0, 2f
818-
/* Find end of list of stacks (put in x8) */
819-
mov TMP, x0
820-
1: ldr x8, Stack_handler(TMP)
821-
ldr TMP, Handler_parent(x8)
822-
cbnz TMP, 1b
818+
cbz x0, 1f
823819
/* Add current stack to the end */
820+
sub x3, x3, 1 /* x3 = Ptr_val(x3) */
821+
ldr x8, Stack_handler(x3)
824822
ldr x9, Caml_state(current_stack)
825823
str x9, Handler_parent(x8)
826824
SWITCH_OCAML_STACKS x9, x0
827825
mov x0, x2
828-
br x3
829-
2: ADDRGLOBAL(ADDITIONAL_ARG, caml_raise_continuation_already_resumed)
826+
br x4
827+
1: ADDRGLOBAL(ADDITIONAL_ARG, caml_raise_continuation_already_resumed)
830828
b G(caml_c_call)
831829
CFI_ENDPROC
832830
END_FUNCTION(caml_resume)

‎runtime/callback.c

+1-1
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@
5555
Caml_inline value alloc_and_clear_stack_parent(caml_domain_state* domain_state)
5656
{
5757
struct stack_info* parent_stack = Stack_parent(domain_state->current_stack);
58-
value cont = caml_alloc_1(Cont_tag, Val_ptr(parent_stack));
58+
value cont = caml_alloc_2(Cont_tag, Val_ptr(parent_stack), Val_long(0));
5959
Stack_parent(domain_state->current_stack) = NULL;
6060
return cont;
6161
}

‎runtime/interp.c

+12-5
Original file line numberDiff line numberDiff line change
@@ -274,6 +274,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
274274
volatile value raise_exn_bucket = Val_unit;
275275
struct longjmp_buffer raise_buf;
276276
value resume_fn, resume_arg;
277+
struct stack_info* resume_tail;
277278
caml_domain_state* domain_state = Caml_state;
278279
struct caml_exception_context exception_ctx =
279280
{ &raise_buf, domain_state->local_roots, &raise_exn_bucket};
@@ -1283,7 +1284,8 @@ value caml_interprete(code_t prog, asize_t prog_size)
12831284
Instruct(RESUME):
12841285
resume_fn = sp[0];
12851286
resume_arg = sp[1];
1286-
sp -= 3;
1287+
resume_tail = Ptr_val(sp[2]);
1288+
sp -= 2;
12871289
sp[0] = Val_long(domain_state->trap_sp_off);
12881290
sp[1] = Val_long(0);
12891291
sp[2] = (value)pc;
@@ -1297,11 +1299,13 @@ do_resume: {
12971299
Setup_for_c_call;
12981300
caml_raise_continuation_already_resumed();
12991301
}
1300-
while (Stack_parent(stk) != NULL) stk = Stack_parent(stk);
1301-
Stack_parent(stk) = Caml_state->current_stack;
1302+
if (resume_tail == NULL) {
1303+
resume_tail = stk;
1304+
}
1305+
Stack_parent(resume_tail) = Caml_state->current_stack;
13021306

13031307
domain_state->current_stack->sp = sp;
1304-
domain_state->current_stack = Ptr_val(accu);
1308+
domain_state->current_stack = stk;
13051309
sp = domain_state->current_stack->sp;
13061310

13071311
domain_state->trap_sp_off = Long_val(sp[0]);
@@ -1316,6 +1320,7 @@ do_resume: {
13161320
Instruct(RESUMETERM):
13171321
resume_fn = sp[0];
13181322
resume_arg = sp[1];
1323+
resume_tail = Ptr_val(sp[2]);
13191324
sp = sp + *pc - 2;
13201325
sp[0] = Val_long(domain_state->trap_sp_off);
13211326
sp[1] = Val_long(extra_args);
@@ -1335,7 +1340,7 @@ do_resume: {
13351340
goto raise_exception;
13361341
}
13371342

1338-
Alloc_small(cont, 1, Cont_tag, Enter_gc);
1343+
Alloc_small(cont, 2, Cont_tag, Enter_gc);
13391344

13401345
sp -= 4;
13411346
sp[0] = Val_long(domain_state->trap_sp_off);
@@ -1348,6 +1353,7 @@ do_resume: {
13481353
sp = parent_stack->sp;
13491354
Stack_parent(old_stack) = NULL;
13501355
Field(cont, 0) = Val_ptr(old_stack);
1356+
Field(cont, 1) = Val_long(0);
13511357

13521358
domain_state->trap_sp_off = Long_val(sp[0]);
13531359
extra_args = Long_val(sp[1]);
@@ -1380,6 +1386,7 @@ do_resume: {
13801386
accu = caml_continuation_use(cont);
13811387
Restore_after_c_call;
13821388
resume_fn = raise_unhandled_effect;
1389+
resume_tail = cont_tail;
13831390

13841391
goto do_resume;
13851392
}

‎runtime/minor_gc.c

+5-3
Original file line numberDiff line numberDiff line change
@@ -273,11 +273,12 @@ static void oldify_one (void* st_v, value v, volatile value *p)
273273

274274
if (tag == Cont_tag) {
275275
value stack_value = Field(v, 0);
276-
CAMLassert(Wosize_hd(hd) == 1 && infix_offset == 0);
277-
result = alloc_shared(st->domain, 1, Cont_tag, Reserved_hd(hd));
276+
CAMLassert(Wosize_hd(hd) == 2 && infix_offset == 0);
277+
result = alloc_shared(st->domain, 2, Cont_tag, Reserved_hd(hd));
278278
if( try_update_object_header(v, p, result, 0) ) {
279279
struct stack_info* stk = Ptr_val(stack_value);
280-
Field(result, 0) = Val_ptr(stk);
280+
Field(result, 0) = stack_value;
281+
Field(result, 1) = Field(v, 1);
281282
if (stk != NULL) {
282283
caml_scan_stack(&oldify_one, oldify_scanning_flags, st,
283284
stk, 0);
@@ -290,6 +291,7 @@ static void oldify_one (void* st_v, value v, volatile value *p)
290291
caml_global_heap_state.MARKED);
291292
#ifdef DEBUG
292293
Field(result, 0) = Val_long(1);
294+
Field(result, 1) = Val_long(1);
293295
#endif
294296
}
295297
} else if (tag < Infix_tag) {

‎runtime/power.S

+6-9
Original file line numberDiff line numberDiff line change
@@ -721,27 +721,24 @@ ENDFUNCTION caml_reperform
721721
FUNCTION caml_resume
722722
/* r3: new fiber
723723
r4: fun
724-
r5: arg */
724+
r5: arg
725+
r6: last_fiber */
725726
addi 3, 3, -1 /* r3 = Ptr_val(r3) */
726727
ld 12, 0(4) /* r12 = code pointer */
727728
mtctr 12 /* CTR = code pointer */
728729
/* Check if stack is null, then already used */
729730
cmpdi 3, 0
730-
beq 2f
731-
/* Find end of list of stacks (put in r7) */
732-
mr TMP, 3
733-
1: ld 7, Stack_handler(TMP)
734-
ld TMP, Handler_parent(7)
735-
cmpdi TMP, 0
736-
bne 1b
731+
beq 1f
737732
/* Add current stack to the end */
733+
addi 6, 6, -1 /* r6 = Ptr_val(r6) */
734+
ld 7, Stack_handler(6)
738735
ld 8, Caml_state(current_stack)
739736
std 8, Handler_parent(7)
740737
/* Switch stacks and run code */
741738
SWITCH_OCAML_STACKS 8, 3
742739
mr 3, 5
743740
bctr
744-
2: Addrglobal(C_CALL_FUN, caml_raise_continuation_already_resumed)
741+
1: Addrglobal(C_CALL_FUN, caml_raise_continuation_already_resumed)
745742
b .Lcaml_c_call
746743
ENDFUNCTION caml_resume
747744

‎runtime/riscv.S

+8-10
Original file line numberDiff line numberDiff line change
@@ -738,23 +738,21 @@ END_FUNCTION(caml_reperform)
738738
FUNCTION(caml_resume)
739739
/* a0: new fiber
740740
a1: fun
741-
a2: arg */
741+
a2: arg
742+
a3: last_fiber */
742743
addi a0, a0, -1 /* a0 = Ptr_val(a0) */
743-
ld a3, 0(a1) /* code pointer */
744+
ld a4, 0(a1) /* code pointer */
744745
/* Check if stack null, then already used */
745-
beqz a0, 2f
746-
/* Find end of list of stacks (put in t2) */
747-
mv TMP, a0
748-
1: ld t2, Stack_handler(TMP)
749-
ld TMP, Handler_parent(t2)
750-
bnez TMP, 1b
746+
beqz a0, 1f
751747
/* Add current stack to the end */
748+
addi a3, a3, -1 /* a3 = Ptr_val(a3) */
749+
ld t2, Stack_handler(a3)
752750
ld t3, Caml_state(current_stack)
753751
sd t3, Handler_parent(t2)
754752
SWITCH_OCAML_STACKS t3, a0
755753
mv a0, a2
756-
jr a3
757-
2: la ADDITIONAL_ARG, caml_raise_continuation_already_resumed
754+
jr a4
755+
1: la ADDITIONAL_ARG, caml_raise_continuation_already_resumed
758756
j L(caml_c_call)
759757
END_FUNCTION(caml_resume)
760758

0 commit comments

Comments
 (0)