mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Multiple-value returns now start from slot 0, not slot 1

Browse source 
This should reduce frame sizes.

* libguile/vm-engine.c (halt): Adapt to multiple-values change.  Also
  adapt to not having the boot closure on the stack.
  (receive, receive-values, subr-call, foreign-call): Adapt to expect
  values one slot down.
  (prompt): Capture one less word for the values return.
* libguile/vm.c (vm_dispatch_pop_continuation_hook):
  (vm_dispatch_abort_hook): Adapt for where to expect values.
  (vm_builtin_values_code): Add a call to shuffle-down before
  returning.  This is more overhead than what existed before, but the
  hope is that the savings elsewhere pay off.
  (vm_builtin_values_code): Adapt to different values location.
  (reinstate_continuation_x, compose_continuation): Adapt to place
  resume args at right position.
  (capture_delimited_continuation): Remove unused sp and ip arguments.
  (abort_to_prompt): Adapt to capture_delimited_continuation change.
  (scm_call_n): Adapt to not reserve space for the boot closure.
* module/language/cps/compile-bytecode.scm (compile-function): When
  returning values, adapt reset-frame call for return calling convention
  change.  Adapt truncating or rest returns to expect values in the
  right place.
* module/language/cps/slot-allocation.scm (compute-shuffles):
  (allocate-lazy-vars, allocate-slots): Allocate values from the "proc
  slot", not proc-slot + 1.
* module/system/vm/assembler.scm (emit-init-constants): Reset the frame
  before returning so that the return value is in the right place.
* test-suite/tests/rtl.test: Update for return convention change.
* libguile/foreign.c (get_foreign_stub_code): Update for return calling
  convention change.
This commit is contained in:
Andy Wingo 2018-07-19 13:56:13 +02:00
parent 9b70129504
commit 950a762dc2
7 changed files with 76 additions and 75 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/foreign.c
View file

@ -844,7 +844,7 @@ get_foreign_stub_code (unsigned int nargs, int with_errno)
code[i++] = SCM_PACK_OP_12_12 (foreign_call, 0, 1);
code[i++] = SCM_PACK_OP_24 (handle_interrupts, 0);
if (!with_errno)
code[i++] = SCM_PACK_OP_24 (reset_frame, 2);
code[i++] = SCM_PACK_OP_24 (reset_frame, 1);
code[i++] = SCM_PACK_OP_24 (return_values, 0);
return code;

22
libguile/vm-engine.c
View file

@ -322,8 +322,8 @@ VM_NAME (scm_thread *thread)
VM_DEFINE_OP (0, halt, "halt", OP1 (X32))
{
size_t frame_size = 3;
/* Boot closure, then empty frame, then callee, then values. */
size_t first_value = 1 + frame_size + 1;
/* Empty frame, then values. */
size_t first_value = frame_size;
uint32_t nvals = FRAME_LOCALS_COUNT_FROM (first_value);
SCM ret;
@ -486,9 +486,9 @@ VM_NAME (scm_thread *thread)
uint32_t nlocals;
UNPACK_12_12 (op, dst, proc);
UNPACK_24 (ip[1], nlocals);
VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1,
VM_ASSERT (FRAME_LOCALS_COUNT () > proc,
CALL_INTRINSIC (error_no_values, ()));
FP_SET (dst, FP_REF (proc + 1));
FP_SET (dst, FP_REF (proc));
RESET_FRAME (nlocals);
NEXT (2);
}
@ -507,10 +507,10 @@ VM_NAME (scm_thread *thread)
UNPACK_24 (op, proc);
UNPACK_24 (ip[1], nvalues);
if (ip[1] & 0x1)
VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
VM_ASSERT (FRAME_LOCALS_COUNT () >= proc + nvalues,
CALL_INTRINSIC (error_not_enough_values, ()));
else
VM_ASSERT (FRAME_LOCALS_COUNT () == proc + 1 + nvalues,
VM_ASSERT (FRAME_LOCALS_COUNT () == proc + nvalues,
CALL_INTRINSIC (error_wrong_number_of_values, (nvalues)));
NEXT (2);
}
@ -585,14 +585,14 @@ VM_NAME (scm_thread *thread)
if (SCM_UNLIKELY (scm_is_values (ret)))
{
size_t n, nvals = scm_i_nvalues (ret);
ALLOC_FRAME (1 + nvals);
ALLOC_FRAME (nvals);
for (n = 0; n < nvals; n++)
FP_SET (n + 1, scm_i_value_ref (ret, n));
FP_SET (n, scm_i_value_ref (ret, n));
NEXT (1);
}
else
{
ALLOC_FRAME (2);
RESET_FRAME (1);
SP_SET (0, ret);
NEXT (1);
}
@ -621,7 +621,7 @@ VM_NAME (scm_thread *thread)
ret = CALL_INTRINSIC (foreign_call, (cif, pointer, &err, sp));
CACHE_SP ();
ALLOC_FRAME (3);
ALLOC_FRAME (2);
SP_SET (1, ret);
SP_SET (0, err);
@ -1612,7 +1612,7 @@ VM_NAME (scm_thread *thread)
/* Push the prompt onto the dynamic stack. */
SYNC_IP ();
CALL_INTRINSIC (push_prompt, (thread, escape_only_p, SP_REF (tag),
FP_SLOT (proc_slot), ip + offset));
VP->fp - proc_slot, ip + offset));
NEXT (3);
}

30
libguile/vm.c
View file

@ -292,7 +292,7 @@ static void vm_dispatch_pop_continuation_hook (scm_thread *thread,
union scm_vm_stack_element *old_fp)
{
return vm_dispatch_hook (thread, SCM_VM_POP_CONTINUATION_HOOK,
SCM_FRAME_NUM_LOCALS (old_fp, thread->vm.sp) - 1);
SCM_FRAME_NUM_LOCALS (old_fp, thread->vm.sp));
}
static void vm_dispatch_next_hook (scm_thread *thread)
{
@ -301,7 +301,7 @@ static void vm_dispatch_next_hook (scm_thread *thread)
static void vm_dispatch_abort_hook (scm_thread *thread)
{
return vm_dispatch_hook (thread, SCM_VM_ABORT_CONTINUATION_HOOK,
SCM_FRAME_NUM_LOCALS (thread->vm.fp, thread->vm.sp) - 1);
SCM_FRAME_NUM_LOCALS (thread->vm.fp, thread->vm.sp));
}
@ -341,6 +341,7 @@ static const uint32_t vm_builtin_apply_code[] = {
};
static const uint32_t vm_builtin_values_code[] = {
SCM_PACK_OP_12_12 (shuffle_down, 1, 0),
SCM_PACK_OP_24 (return_values, 0)
};
@ -348,7 +349,7 @@ static const uint32_t vm_builtin_abort_to_prompt_code[] = {
SCM_PACK_OP_24 (assert_nargs_ge, 2),
SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
/* FIXME: Partial continuation should capture caller regs. */
SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
SCM_PACK_OP_24 (return_values, 0) /* vals from r0 */
};
static const uint32_t vm_builtin_call_with_values_code[] = {
@ -357,7 +358,7 @@ static const uint32_t vm_builtin_call_with_values_code[] = {
SCM_PACK_OP_12_12 (mov, 0, 6),
SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1),
SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2),
SCM_PACK_OP_12_12 (shuffle_down, 8, 1),
SCM_PACK_OP_12_12 (shuffle_down, 7, 1),
SCM_PACK_OP_24 (tail_call, 0)
};
@ -1096,10 +1097,9 @@ 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. 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++)
expects. */
vm_push_sp (vp, vp->sp - frame_overhead - n);
for (i = 0; i < frame_overhead; i++)
vp->sp[n+i].as_scm = SCM_BOOL_F;
memcpy(vp->sp, argv, n * sizeof (union scm_vm_stack_element));
@ -1166,16 +1166,14 @@ compose_continuation (scm_thread *thread, SCM cont)
old_fp_offset = vp->stack_top - vp->fp;
vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1));
vm_push_sp (vp, vp->fp - (cp->stack_size + nargs));
data.vp = vp;
data.cp = cp;
GC_call_with_alloc_lock (compose_continuation_inner, &data);
/* The resumed continuation will expect ARGS on the stack as if from a
multiple-value return. Fill in the closure slot with #f, and copy
the arguments into place. */
vp->sp[nargs].as_scm = SCM_BOOL_F;
multiple-value return. */
memcpy (vp->sp, args, nargs * sizeof (*args));
/* The prompt captured a slice of the dynamic stack. Here we wind
@ -1214,8 +1212,6 @@ rest_arg_length (SCM x)
static SCM
capture_delimited_continuation (struct scm_vm *vp,
union scm_vm_stack_element *saved_fp,
union scm_vm_stack_element *saved_sp,
uint32_t *saved_ip,
jmp_buf *saved_registers,
scm_t_dynstack *dynstack,
jmp_buf *current_registers)
@ -1298,13 +1294,14 @@ abort_to_prompt (scm_thread *thread)
scm_t_dynstack *captured;
captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
cont = capture_delimited_continuation (vp, fp, sp, ip, registers, captured,
cont = capture_delimited_continuation (vp, fp, registers, captured,
thread->vm.registers);
}
/* Unwind. */
scm_dynstack_unwind (dynstack, prompt);
/* Continuation gets nargs+1 values: the one more is for the cont. */
sp = sp - nargs - 1;
/* Shuffle abort arguments down to the prompt continuation. We have
@ -1378,7 +1375,7 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
elements and each element is at least 4 bytes, nargs will not be
greater than INTMAX/2 and therefore we don't have to check for
overflow here or below. */
size_t return_nlocals = 1, call_nlocals = nargs + 1, frame_size = 3;
size_t return_nlocals = 0, call_nlocals = nargs + 1, frame_size = 3;
ptrdiff_t stack_reserve_words;
size_t i;
@ -1405,7 +1402,6 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
SCM_FRAME_SET_VIRTUAL_RETURN_ADDRESS (return_fp, vp->ip);
SCM_FRAME_SET_MACHINE_RETURN_ADDRESS (return_fp, 0);
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;

8
module/language/cps/compile-bytecode.scm
View file

@ -130,7 +130,7 @@
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(maybe-reset-frame (1+ (length args)))
(maybe-reset-frame (length args))
(emit-return-values asm))))
(define (compile-value label exp dst)
@ -391,7 +391,7 @@
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(emit-bind-rest asm (+ proc-slot nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves kh allocation))
@ -525,7 +525,7 @@
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)
((((? (lambda (src) (= src (1+ proc-slot))) src)
((((? (lambda (src) (= src proc-slot)) src)
. dst)) dst)
(_ #f)))
;; The usual case: one required live return value, ignoring
@ -536,7 +536,7 @@
(unless (and (zero? nreq) rest-var)
(emit-receive-values asm proc-slot (->bool rest-var) nreq))
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(emit-bind-rest asm (+ proc-slot nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves k allocation))

14
module/language/cps/slot-allocation.scm
View file

@ -528,7 +528,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kreceive arity kargs)
(let* ((results (match (get-cont kargs)
(($ $kargs names vars) vars)))
(value-slots (integers (1+ proc-slot) (length results)))
(value-slots (integers proc-slot (length results)))
(result-slots (get-slots results))
;; Filter out unused results.
(value-slots (filter-map (lambda (val result) (and result val))
@ -563,7 +563,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $ktail)
(let* ((live (compute-live-slots label))
(src-slots (get-slots args))
(dst-slots (integers 1 (length args)))
(dst-slots (integers 0 (length args)))
(moves (parallel-move src-slots dst-slots
(compute-tmp-slot live dst-slots))))
(intmap-add! shuffles label moves)))
@ -705,7 +705,7 @@ are comparable with eqv?. A tmp slot may be used."
(define (allocate-values label k args slots)
(match (intmap-ref cps k)
(($ $ktail)
(allocate* args (integers 1 (length args))
(allocate* args (integers 0 (length args))
slots (compute-live-slots slots label)))
(($ $kargs names vars)
(allocate* args
@ -816,9 +816,7 @@ are comparable with eqv?. A tmp slot may be used."
(+ frame-size (find-first-trailing-zero live-slots)))
(define (compute-prompt-handler-proc-slot live-slots)
(if (zero? live-slots)
0
(1- (find-first-trailing-zero live-slots))))
(find-first-trailing-zero live-slots))
(define (get-cont label)
(intmap-ref cps label))
@ -925,7 +923,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kargs () ())
(values slots post-live))
(($ $kargs (_ . _) (_ . results))
(let ((result-slots (integers (+ proc-slot 2)
(let ((result-slots (integers (+ proc-slot 1)
(length results))))
(allocate* results result-slots slots post-live)))))
((slot-map) (compute-slot-map slots (intmap-ref live-out label)
@ -967,7 +965,7 @@ are comparable with eqv?. A tmp slot may be used."
(- proc-slot frame-size)))
((result-vars) (match (get-cont kargs)
(($ $kargs names vars) vars)))
((value-slots) (integers (1+ proc-slot) (length result-vars)))
((value-slots) (integers proc-slot (length result-vars)))
((slots result-live) (allocate* result-vars value-slots
slots handler-live)))
(values slots

1
module/system/vm/assembler.scm
View file

@ -1560,6 +1560,7 @@ a procedure to do that and return its label. Otherwise return
`((begin-program ,label ())
(assert-nargs-ee/locals 1 1)
,@(reverse inits)
(reset-frame 1)
(load-constant 0 ,*unspecified*)
(return-values)
(end-program)))

74
test-suite/tests/rtl.test
View file

@ -39,9 +39,9 @@ a procedure."
(define (return-constant val)
(assemble-program `((begin-program foo
((name . foo)))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 ,val)
(return-values 2)
(return-values)
(end-arity)
(end-program))))
@ -91,16 +91,16 @@ a procedure."
(assert-equal 42
(((assemble-program `((begin-program foo
((name . foo)))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-static-procedure 0 bar)
(return-values 2)
(return-values)
(end-arity)
(end-program)
(begin-program bar
((name . bar)))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program)))))))
@ -128,8 +128,9 @@ a procedure."
(load-constant 0 0)
(j loop-head)
(label out)
(mov 2 0)
(return-values 2)
(mov 3 0)
(reset-frame 1)
(return-values)
(end-arity)
(end-program)))))
(sumto 1000))))
@ -145,8 +146,9 @@ a procedure."
(definition f 1 scm)
(mov 1 5)
(call 5 1)
(receive 1 5 7)
(return-values 2)
(receive 0 5 7)
(reset-frame 1)
(return-values)
(end-arity)
(end-program)))))
(call (lambda () 42))))
@ -162,8 +164,9 @@ a procedure."
(mov 1 5)
(load-constant 0 3)
(call 5 2)
(receive 1 5 7)
(return-values 2)
(receive 0 5 7)
(reset-frame 1)
(return-values)
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@ -178,7 +181,8 @@ a procedure."
(definition closure 0 scm)
(definition f 1 scm)
(mov 1 0)
(tail-call 1)
(reset-frame 1)
(tail-call)
(end-arity)
(end-program)))))
(call (lambda () 3))))
@ -193,7 +197,7 @@ a procedure."
(definition f 1 scm)
(mov 1 0) ;; R0 <- R1
(load-constant 0 3) ;; R1 <- 3
(tail-call 2)
(tail-call)
(end-arity)
(end-program)))))
(call-with-3 (lambda (x) (* x 2))))))
@ -201,9 +205,9 @@ a procedure."
(with-test-prefix "debug contexts"
(let ((return-3 (assemble-program
'((begin-program return-3 ((name . return-3)))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 3)
(return-values 2)
(return-values)
(end-arity)
(end-program)))))
(pass-if "program name"
@ -223,9 +227,9 @@ a procedure."
(procedure-name
(assemble-program
'((begin-program foo ((name . foo)))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program))))))
@ -234,10 +238,10 @@ a procedure."
(object->string
(assemble-program
'((begin-program foo ((name . foo)))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(definition closure 0 scm)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program)))))
(pass-if-equal "#<procedure foo (x y)>"
@ -248,8 +252,9 @@ a procedure."
(definition closure 0 scm)
(definition x 1 scm)
(definition y 2 scm)
(load-constant 1 42)
(return-values 2)
(load-constant 2 42)
(reset-frame 1)
(return-values)
(end-arity)
(end-program)))))
@ -262,8 +267,9 @@ a procedure."
(definition x 1 scm)
(definition y 2 scm)
(definition z 3 scm)
(load-constant 2 42)
(return-values 2)
(load-constant 3 42)
(reset-frame 1)
(return-values)
(end-arity)
(end-program))))))
@ -272,9 +278,9 @@ a procedure."
(procedure-documentation
(assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux")))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program))))))
@ -284,9 +290,9 @@ a procedure."
(procedure-properties
(assemble-program
'((begin-program foo ())
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program)))))
@ -296,9 +302,9 @@ a procedure."
(procedure-properties
(assemble-program
'((begin-program foo ((name . foo) (documentation . "qux qux")))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program)))))
@ -311,9 +317,9 @@ a procedure."
'((begin-program foo ((name . foo)
(documentation . "qux qux")
(moo . "mooooooooooooo")))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program)))))
@ -324,8 +330,8 @@ a procedure."
'((begin-program foo ((name . foo)
(documentation . "qux qux")
(moo . "mooooooooooooo")))
(begin-standard-arity () 2 #f)
(begin-standard-arity () 1 #f)
(load-constant 0 42)
(return-values 2)
(return-values)
(end-arity)
(end-program))))))