diff options
author | Andy Wingo <wingo@pobox.com> | 2018-07-15 09:50:52 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2018-07-20 11:42:30 +0200 |
commit | b1705bd0f0181a6496223b26cb5da68fa470ccaa (patch) | |
tree | 709a7ac76ea0d491326ab5464820cc72132c984b | |
parent | e95f15c932650783f34253e396216c66050905f0 (diff) | |
download | guile-b1705bd0f0181a6496223b26cb5da68fa470ccaa.tar.gz |
Prepare for frames having separate virtual and machine return addrs
* libguile/frames.c (scm_frame_return_address): Use
SCM_FRAME_VIRTUAL_RETURN_ADDRESS.
(scm_c_frame_previous): Likewise.
* libguile/frames.h: Update diagram for new names.
(union scm_vm_stack_element): Rename "as_ip" to "as_vcode", and
add "as_mcode" for machine code pointers.
(SCM_FRAME_VIRTUAL_RETURN_ADDRESS)
(SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS): Rename to these, from
SCM_FRAME_RETURN_ADDRESS and SCM_FRAME_SET_RETURN_ADDRESS.
* libguile/vm-engine.c (halt, call, call-label, return-values)
(return-from-interrupt): Adapt to renamings. Make "halt" have frame
size as a parameter.
* libguile/vm.c (scm_i_vm_mark_stack): Adapt to renaming.
(push_interrupt_frame): Take mRA as additional argument. In future we
will set it as frame mRA.
(capture_continuation): Adapt to renaming.
(scm_call_n): Adapt to renaming and make frame size adjustable.
(push_interrupt_frame, reinstate_continuation_x): Make frame size
adjustable.
* module/language/cps/slot-allocation.scm (allocate-slots): Make frame
size adjustable.
* libguile/intrinsics.h (scm_t_thread_mra_intrinsic): New type; use for
push_interrupt_frame.
(scm_t_thread_u8_scm_sp_vra_intrinsic): Rename from the same but was
"ra" instead of "vra", and change type to uint32_t*.
* module/system/vm/disassembler.scm (define-clobber-parser):
Parameterize clobber set for calls by frame size.
-rw-r--r-- | libguile/frames.c | 6 | ||||
-rw-r--r-- | libguile/frames.h | 46 | ||||
-rw-r--r-- | libguile/intrinsics.c | 2 | ||||
-rw-r--r-- | libguile/intrinsics.h | 13 | ||||
-rw-r--r-- | libguile/vm-engine.c | 23 | ||||
-rw-r--r-- | libguile/vm.c | 31 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 8 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 3 |
8 files changed, 70 insertions, 62 deletions
diff --git a/libguile/frames.c b/libguile/frames.c index 845248007..d989d6292 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -366,8 +366,8 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, #define FUNC_NAME s_scm_frame_return_address { SCM_VALIDATE_VM_FRAME (1, frame); - return scm_from_uintptr_t ((uintptr_t) (SCM_FRAME_RETURN_ADDRESS - (SCM_VM_FRAME_FP (frame)))); + return scm_from_uintptr_t ((uintptr_t) (SCM_FRAME_VIRTUAL_RETURN_ADDRESS + (SCM_VM_FRAME_FP (frame)))); } #undef FUNC_NAME @@ -404,7 +404,7 @@ scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame) new_sp = SCM_FRAME_PREVIOUS_SP (this_fp); frame->fp_offset = stack_top - new_fp; frame->sp_offset = stack_top - new_sp; - frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp); + frame->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (this_fp); if (scm_i_vm_is_boot_continuation_code (frame->ip)) goto again; diff --git a/libguile/frames.h b/libguile/frames.h index bbc47d009..85e36a5c2 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -39,29 +39,30 @@ Stack frame layout ------------------ - | ... | - +==================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp) - | Dynamic link | - +------------------+ - | Return address | - +==================+ <- fp - | Local 0 | - +------------------+ - | Local 1 | - +------------------+ - | ... | - +------------------+ - | Local N-1 | - \------------------/ <- sp + | ... | + +==============================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp) + | Dynamic link | + +------------------------------+ + | Virtual return address (vRA) | + +==============================+ <- fp + | Local 0 | + +------------------------------+ + | Local 1 | + +------------------------------+ + | ... | + +------------------------------+ + | Local N-1 | + \------------------------------/ <- sp The stack grows down. The calling convention is that a caller prepares a stack frame - consisting of the saved FP and the return address, followed by the - procedure and then the arguments to the call, in order. Thus in the - beginning of a call, the procedure being called is in slot 0, the - first argument is in slot 1, and the SP points to the last argument. - The number of arguments, including the procedure, is thus FP - SP. + consisting of the saved FP and the saved virtual return address, + followed by the procedure and then the arguments to the call, in + order. Thus in the beginning of a call, the procedure being called + is in slot 0, the first argument is in slot 1, and the SP points to + the last argument. The number of arguments, including the procedure, + is thus FP - SP. After ensuring that the correct number of arguments have been passed, a function will set the stack pointer to point to the last local @@ -90,7 +91,8 @@ union scm_vm_stack_element { uintptr_t as_uint; - uint32_t *as_ip; + uint32_t *as_vcode; + uint8_t *as_mcode; SCM as_scm; double as_f64; uint64_t as_u64; @@ -102,8 +104,8 @@ union scm_vm_stack_element }; #define SCM_FRAME_PREVIOUS_SP(fp) ((fp) + 2) -#define SCM_FRAME_RETURN_ADDRESS(fp) ((fp)[0].as_ip) -#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) ((fp)[0].as_ip = (ra)) +#define SCM_FRAME_VIRTUAL_RETURN_ADDRESS(fp) ((fp)[0].as_vcode) +#define SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS(fp, ra) ((fp)[0].as_vcode = (ra)) #define SCM_FRAME_DYNAMIC_LINK(fp) ((fp) + (fp)[1].as_uint) #define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) ((fp)[1].as_uint = ((dl) - (fp))) #define SCM_FRAME_SLOT(fp,i) ((fp) - (i) - 1) diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index 75cf2f05e..317526688 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -349,7 +349,7 @@ current_module (scm_thread *thread) static void push_prompt (scm_thread *thread, uint8_t escape_only_p, - SCM tag, const union scm_vm_stack_element *sp, void *ra) + SCM tag, const union scm_vm_stack_element *sp, uint32_t *ra) { struct scm_vm *vp = &thread->vm; scm_t_dynstack_prompt_flags flags; diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 3c35749fc..3bd264f3d 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -61,10 +61,11 @@ typedef void (*scm_t_scm_noreturn_intrinsic) (SCM) SCM_NORETURN; typedef void (*scm_t_u32_noreturn_intrinsic) (uint32_t) SCM_NORETURN; typedef SCM (*scm_t_scm_from_thread_u64_intrinsic) (scm_thread*, uint64_t); typedef SCM (*scm_t_scm_from_thread_intrinsic) (scm_thread*); -typedef void (*scm_t_thread_u8_scm_sp_ra_intrinsic) (scm_thread*, - uint8_t, SCM, - const union scm_vm_stack_element*, - void*); +typedef void (*scm_t_thread_u8_scm_sp_vra_intrinsic) (scm_thread*, + uint8_t, SCM, + const union scm_vm_stack_element*, + uint32_t*); +typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -113,7 +114,7 @@ typedef void (*scm_t_thread_u8_scm_sp_ra_intrinsic) (scm_thread*, M(scm_from_thread_u32, cons_rest, "cons-rest", CONS_REST) \ M(u32_from_thread_u32_u32, compute_kwargs_npositional, "compute-kwargs-npositional", COMPUTE_KWARGS_NPOSITIONAL) \ M(thread_u32_u32_scm_u8_u8, bind_kwargs, "bind-kwargs", BIND_KWARGS) \ - M(thread, push_interrupt_frame, "push-interrupt-frame", PUSH_INTERRUPT_FRAME) \ + M(thread_mra, push_interrupt_frame, "push-interrupt-frame", PUSH_INTERRUPT_FRAME) \ M(scm_from_scm_scm_scmp_sp, foreign_call, "foreign-call", FOREIGN_CALL) \ M(thread_scm_noreturn, reinstate_continuation_x, "reinstate-continuation!", REINSTATE_CONTINUATION_X) \ M(scm_from_thread, capture_continuation, "capture-continuation", CAPTURE_CONTINUATION) \ @@ -130,7 +131,7 @@ typedef void (*scm_t_thread_u8_scm_sp_ra_intrinsic) (scm_thread*, M(thread, apply_non_program, "apply-non-program", APPLY_NON_PROGRAM) \ M(scm_from_thread_u64, allocate_words, "allocate-words", ALLOCATE_WORDS) \ M(scm_from_thread, current_module, "current-module", CURRENT_MODULE) \ - M(thread_u8_scm_sp_ra, push_prompt, "push-prompt", PUSH_PROMPT) \ + M(thread_u8_scm_sp_vra, push_prompt, "push-prompt", PUSH_PROMPT) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index e9e1b477e..cf4cab7ff 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -321,13 +321,14 @@ VM_NAME (scm_thread *thread) */ VM_DEFINE_OP (0, halt, "halt", OP1 (X32)) { - /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */ - - uint32_t nvals = FRAME_LOCALS_COUNT_FROM (4); + size_t frame_size = 2; + /* Boot closure, then empty frame, then callee, then values. */ + size_t first_value = 1 + frame_size + 1; + uint32_t nvals = FRAME_LOCALS_COUNT_FROM (first_value); SCM ret; if (nvals == 1) - ret = FP_REF (4); + ret = FP_REF (first_value); else { uint32_t n; @@ -335,10 +336,10 @@ VM_NAME (scm_thread *thread) VM_ASSERT (nvals <= (UINTPTR_MAX >> 8), abort ()); ret = scm_words ((nvals << 8) | scm_tc7_values, nvals + 1); for (n = 0; n < nvals; n++) - SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (4 + n)); + SCM_SET_CELL_OBJECT (ret, n+1, FP_REF (first_value + n)); } - VP->ip = SCM_FRAME_RETURN_ADDRESS (VP->fp); + VP->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp); VP->sp = SCM_FRAME_PREVIOUS_SP (VP->fp); VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); @@ -371,7 +372,7 @@ VM_NAME (scm_thread *thread) old_fp = VP->fp; VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1); SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (VP->fp, ip + 2); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 2); RESET_FRAME (nlocals); @@ -414,7 +415,7 @@ VM_NAME (scm_thread *thread) old_fp = VP->fp; VP->fp = SCM_FRAME_SLOT (old_fp, proc - 1); SCM_FRAME_SET_DYNAMIC_LINK (VP->fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (VP->fp, ip + 3); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (VP->fp, ip + 3); RESET_FRAME (nlocals); @@ -576,7 +577,7 @@ VM_NAME (scm_thread *thread) RESET_FRAME (nlocals); old_fp = VP->fp; - ip = SCM_FRAME_RETURN_ADDRESS (VP->fp); + ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp); VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); /* Clear stack frame. */ @@ -2373,7 +2374,7 @@ VM_NAME (scm_thread *thread) NEXT (1); SYNC_IP (); - CALL_INTRINSIC (push_interrupt_frame, (thread)); + CALL_INTRINSIC (push_interrupt_frame, (thread, 0)); CACHE_SP (); ip = (uint32_t *) vm_handle_interrupt_code; APPLY_HOOK (); @@ -2388,7 +2389,7 @@ VM_NAME (scm_thread *thread) VM_DEFINE_OP (184, return_from_interrupt, "return-from-interrupt", OP1 (X32)) { VP->sp = sp = SCM_FRAME_PREVIOUS_SP (VP->fp); - ip = SCM_FRAME_RETURN_ADDRESS (VP->fp); + ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp); VP->fp = SCM_FRAME_DYNAMIC_LINK (VP->fp); NEXT (0); diff --git a/libguile/vm.c b/libguile/vm.c index 7720afaca..cf7b13cac 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -710,7 +710,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, Note that there may be other reasons to not have a dead slots map, e.g. if all of the frame's slots below the callee frame are live. */ - slot_map = find_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache); + slot_map = find_slot_map (SCM_FRAME_VIRTUAL_RETURN_ADDRESS (fp), &cache); } return_unused_stack_to_os (vp); @@ -1011,24 +1011,25 @@ cons_rest (scm_thread *thread, uint32_t base) } static void -push_interrupt_frame (scm_thread *thread) +push_interrupt_frame (scm_thread *thread, uint8_t *mra) { union scm_vm_stack_element *old_fp; + size_t frame_overhead = 2; size_t old_frame_size = frame_locals_count (thread); SCM proc = scm_i_async_pop (thread); /* No PUSH_CONTINUATION_HOOK, as we can't usefully POP_CONTINUATION_HOOK because there are no return values. */ - /* Three slots: two for RA and dynamic link, one for proc. */ - alloc_frame (thread, old_frame_size + 3); + /* Reserve space for frame and callee. */ + alloc_frame (thread, old_frame_size + frame_overhead + 1); old_fp = thread->vm.fp; - thread->vm.fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1); + thread->vm.fp = SCM_FRAME_SLOT (old_fp, old_frame_size + frame_overhead - 1); SCM_FRAME_SET_DYNAMIC_LINK (thread->vm.fp, old_fp); /* Arrange to return to the same handle-interrupts opcode to handle any additional interrupts. */ - SCM_FRAME_SET_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (thread->vm.fp, thread->vm.ip); SCM_FRAME_LOCAL (thread->vm.fp, 0) = proc; } @@ -1069,7 +1070,7 @@ reinstate_continuation_x (scm_thread *thread, SCM cont) scm_t_contregs *continuation = scm_i_contregs (cont); struct scm_vm *vp = &thread->vm; struct scm_vm_cont *cp; - size_t n; + size_t n, i, frame_overhead = 2; union scm_vm_stack_element *argv; struct return_to_continuation_data data; @@ -1091,11 +1092,11 @@ reinstate_continuation_x (scm_thread *thread, SCM cont) /* Now we have the continuation properly copied over. We just need to copy on an empty frame and the return values, as the continuation - expects. */ - vm_push_sp (vp, vp->sp - 3 - n); - vp->sp[n+2].as_scm = SCM_BOOL_F; - vp->sp[n+1].as_scm = SCM_BOOL_F; - vp->sp[n].as_scm = SCM_BOOL_F; + expects. The extra 1 is for the unused slot 0 that's part of the + multiple-value return convention. */ + vm_push_sp (vp, vp->sp - (frame_overhead + 1) - n); + for (i = 0; i < frame_overhead + 1; i++) + vp->sp[n+i].as_scm = SCM_BOOL_F; memcpy(vp->sp, argv, n * sizeof (union scm_vm_stack_element)); vp->ip = cp->ra; @@ -1111,7 +1112,7 @@ capture_continuation (scm_thread *thread) scm_i_vm_capture_stack (vp->stack_top, SCM_FRAME_DYNAMIC_LINK (vp->fp), SCM_FRAME_PREVIOUS_SP (vp->fp), - SCM_FRAME_RETURN_ADDRESS (vp->fp), + SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp), scm_dynstack_capture_all (&thread->dynstack), 0); return scm_i_make_continuation (thread, vm_cont); @@ -1397,14 +1398,14 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) call_fp = vp->sp + call_nlocals; return_fp = call_fp + frame_size + return_nlocals; - SCM_FRAME_SET_RETURN_ADDRESS (return_fp, vp->ip); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (return_fp, vp->ip); SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp); SCM_FRAME_LOCAL (return_fp, 0) = vm_boot_continuation; vp->ip = (uint32_t *) vm_boot_continuation_code; vp->fp = call_fp; - SCM_FRAME_SET_RETURN_ADDRESS (call_fp, vp->ip); + SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (call_fp, vp->ip); SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp); SCM_FRAME_LOCAL (call_fp, 0) = proc; for (i = 0; i < nargs; i++) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index a7a9ab57c..0febca59a 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -807,11 +807,13 @@ are comparable with eqv?. A tmp slot may be used." needs-slot) empty-intset))) + (define frame-size 2) + (define (empty-live-slots) #b0) (define (compute-call-proc-slot live-slots) - (+ 2 (find-first-trailing-zero live-slots))) + (+ frame-size (find-first-trailing-zero live-slots))) (define (compute-prompt-handler-proc-slot live-slots) (if (zero? live-slots) @@ -927,7 +929,7 @@ are comparable with eqv?. A tmp slot may be used." (length results)))) (allocate* results result-slots slots post-live))))) ((slot-map) (compute-slot-map slots (intmap-ref live-out label) - (- proc-slot 2))) + (- proc-slot frame-size))) ((call) (make-call-alloc proc-slot slot-map))) (values slots (intmap-add! call-allocs label call)))))) @@ -962,7 +964,7 @@ are comparable with eqv?. A tmp slot may be used." (((handler-live) (compute-live-in-slots slots handler)) ((proc-slot) (compute-prompt-handler-proc-slot handler-live)) ((slot-map) (compute-slot-map slots (intmap-ref live-in handler) - (- proc-slot 2))) + (- proc-slot frame-size))) ((result-vars) (match (get-cont kargs) (($ $kargs names vars) vars))) ((value-slots) (integers (1+ proc-slot) (length result-vars))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 2ab2bf575..f0b1a1076 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -615,9 +615,10 @@ address of that offset." (lambda () (disassemble-one code (/ pos 4))) (lambda (len elt) + (define frame-size 2) (match elt ((_ proc . _) - (let lp ((slot (- proc 2))) + (let lp ((slot (- proc frame-size))) (if (and nslots-in (< slot nslots-in)) (cons slot (lp (1+ slot))) '()))))))))) |