common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

x86-64: Implement "possible win" cited in calling-convention.texinfo

Browse source 
Create a dedicated area of 'struct thread' to return multiple-values in excess
of the arg-passing registers. Gating feature is :TLS-BASED-MV-RETURN and not
enabled by default. The limit of 64 (inclusive) values is the minimum to get
most existing tests to pass unchanged.  After the optimizations outlined below
are done, the feature will be more compelling, and we can see about making it
opt-out rather than opt-in, or making MULTIPLE-VALUES-LIMIT configurable.
(I'm sure that some user will claim to need 1000 values.)

The benefit will be fully realized in some subsequent changes, namely:
freeing a DX alloc, unbinding a special var, and breaking up a catch block
will all return from their frame without invoking RETURN-MULTIPLE. Similarly,
some "simple" unwind-protect forms such as release-mutex could too- anything
that does not clobber the thread-local area during a cleanup.
Also this alleviates a big impediment to creating an LLVM-based backend
which could explore performance differences among the call conventions
offered, since micro-management of the stack becomes less critical.

Co-authored with Antigravity
This commit is contained in:
Douglas Katzman 2026-08-30 15:51:25 -04:00
parent b36bdc5855
commit 4abf6ef5f7
22 changed files with 511 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

192
src/assembly/x86-64/assem-rtns.lisp
View file

@ -17,7 +17,7 @@
;;; the frame for the function that is returning to the end of the
;;; frame for the function being returned to.
#+sb-assembling ;; We don't want a vop for this one.
#+(and (not tls-based-mv-return) sb-assembling) ;; We don't want a vop for this one.
(define-assembly-routine
(return-multiple (:return-style :none))
(;; These are really arguments.
@ -382,6 +382,7 @@
(with-registers-preserved (lisp :except #.(first register-arg-names))
(call-lisp-fun 'sb-impl:install-hash-table-lock 1)))
#-tls-based-mv-return
(define-assembly-routine
(return-values-list (:return-style :none))
((:arg list descriptor-reg rax-offset)
@ -465,6 +466,195 @@
(inst leave)
(inst ret))))
#+tls-based-mv-return
(progn
(defmacro check-and-save-mv-count (count)
`(progn
(inst cmp :dword ,count (fixnumize multiple-values-limit))
(inst jmp :ae (assemble (:elsewhere)
TOO-MANY-VALUES ; could make this continuable (for no good reason)
(error-call nil 'too-many-return-values-error
(make-random-tn (sc-or-lose 'any-reg) (tn-offset ,count)))
(progn TOO-MANY-VALUES)))
(inst mov :byte (thread-mv-count) ,count)))
#+sb-assembling ;; We don't want a vop for this one.
(define-assembly-routine
(return-multiple (:return-style :none))
(;; These are really arguments.
(:temp rcx unsigned-reg rcx-offset)
(:temp rsi unsigned-reg rsi-offset)
;; These we need as temporaries.
(:temp rax unsigned-reg rax-offset)
(:temp rbx unsigned-reg rbx-offset)
(:temp a0 unsigned-reg (:lisp-reg 0))
(:temp a1 unsigned-reg (:lisp-reg 1))
(:temp a2 unsigned-reg (:lisp-reg 2))
(:temp temp unsigned-reg r8-offset)
(:temp loop-index unsigned-reg r9-offset))
;; Save values base pointer in temp (r8) so loading a1 (rsi) won't clobber it
(inst mov temp rsi)
;; Pick off the cases where everything fits in register args.
(inst cmp :dword rcx (fixnumize 1))
(inst jmp :e ONE-VALUE)
(inst jmp :b ZERO-VALUES)
(inst cmp :dword rcx (fixnumize 3))
(inst jmp :b TWO-VALUES)
(inst jmp :e THREE-VALUES)
;; Values > 3:
;; Do not remove this check! Even though the compiler checks fixed return counts
;; statically, any "dynamic" multiple-values use (e.g. returning out of CATCH) funnels
;; unknown values through here. Enforcing the limit is critical to avoid stomping on
;; the thread structure. It could be claimed that the VALUES vop is at fault for
;; allowing too many on-stack values, howver this routine is the ultimate gatekeeper.
(check-and-save-mv-count rcx)
;; Load register values a0 (rdi), a1 (rsi), a2 (rdx)
(loadw a0 temp -1)
(loadw a1 temp -2)
(loadw a2 temp -3)
;; Copy remaining values (from temp - 32 downward) to thread-mv-return-values (upward)
(inst sub temp (* 4 n-word-bytes))
(inst lea :dword rax (ea (fixnumize -3) rcx)) ; number of values to copy
(zeroize loop-index)
LOOP
(inst mov rbx (ea 0 temp))
(inst mov (ea (+ (ash thread-mv-return-values-slot word-shift)) thread-tn loop-index) rbx)
;; this loop could be slightly improved if we consumed cells of the mv area from the
;; highest address downward. Then we wouldn't need to step three registers each iteration.
(inst sub temp n-word-bytes)
(inst add loop-index n-word-bytes)
(inst sub :dword rax (fixnumize 1))
(inst jmp :nz LOOP)
(inst stc)
(inst leave)
(inst ret)
;; Handle the register arg cases.
ZERO-VALUES
(inst mov a0 null-tn)
(inst mov a1 null-tn)
(inst mov a2 null-tn)
(inst stc)
(inst leave)
(inst ret)
;; Note: we can get this, because the return-multiple vop doesn't
;; check for this case when size > speed.
ONE-VALUE
(loadw a0 temp -1)
(inst clc)
(inst leave)
(inst ret)
TWO-VALUES
(loadw a0 temp -1)
(loadw a1 temp -2)
(inst mov a2 null-tn)
(inst stc)
(inst leave)
(inst ret)
THREE-VALUES
(loadw a0 temp -1)
(loadw a1 temp -2)
(loadw a2 temp -3)
(inst stc)
(inst leave)
(inst ret))
(define-assembly-routine
(return-values-list (:return-style :none))
((:arg list descriptor-reg rax-offset)
(:temp a0 unsigned-reg (:lisp-reg 0))
(:temp a1 unsigned-reg (:lisp-reg 1))
(:temp a2 unsigned-reg (:lisp-reg 2))
(:temp count unsigned-reg rcx-offset)
(:temp temp unsigned-reg r9-offset))
(flet ((check (label)
(assemble ()
(%test-lowtag list temp skip nil list-pointer-lowtag)
(cerror-call nil 'bogus-arg-to-values-list-error list)
(inst jmp label)
skip)))
(assemble ()
(%test-lowtag list temp ZERO-VALUES-ERROR t list-pointer-lowtag)
(inst cmp list null-tn)
(inst jmp :e ZERO-VALUES)
(loadw a0 list cons-car-slot list-pointer-lowtag)
(loadw list list cons-cdr-slot list-pointer-lowtag)
(inst cmp list null-tn)
(inst jmp :ne CONTINUE)
ONE-VALUE
(inst clc)
(inst leave)
(inst ret)
CONTINUE
(check ONE-VALUE)
(inst mov count (fixnumize 2))
(loadw a1 list cons-car-slot list-pointer-lowtag)
(loadw list list cons-cdr-slot list-pointer-lowtag)
(inst cmp list null-tn)
(inst jmp :e TWO-VALUES)
(check TWO-VALUES)
(inst mov count (fixnumize 3))
(loadw a2 list cons-car-slot list-pointer-lowtag)
(loadw list list cons-cdr-slot list-pointer-lowtag)
(inst cmp list null-tn)
(inst jmp :e THREE-VALUES)
(check THREE-VALUES)
;; Perform one pass over the list to count its length, pushing each value.
;; Then do a second pass popping the values into TLS. It could be done in one pass,
;; with an extra comparison and branch per iteration (and difficulty reporting
;; the actual count in the error message if the loop is exited early)
LOOP
(inst add :dword count (fixnumize 1))
(pushw list cons-car-slot list-pointer-lowtag)
(loadw list list cons-cdr-slot list-pointer-lowtag)
(check DONE)
(inst cmp list null-tn)
(inst jmp :ne LOOP)
DONE
(check-and-save-mv-count count)
(inst lea list (thread-slot-ea thread-mv-return-values-slot))
(inst sub :dword count (fixnumize 3)) ; number of values in registers
COPY
(inst sub :dword count (fixnumize 1))
(inst pop (ea list count (ash 1 (- word-shift n-fixnum-tag-bits))))
(inst jmp :nz COPY)
(inst mov :byte count (thread-mv-count)) ; restore RCX
(inst stc)
(inst leave)
(inst ret)
ZERO-VALUES-ERROR
(cerror-call nil 'bogus-arg-to-values-list-error list)
ZERO-VALUES
(zeroize count)
(inst mov a0 null-tn)
(inst mov a1 null-tn)
TWO-VALUES
(inst mov a2 null-tn)
THREE-VALUES
(inst stc)
(inst leave)
(inst ret))))
) ; end #+tls-based-mv-return
#+(and immobile-space sb-assembling)
(define-assembly-routine (mark-symbol-card
(:return-style :none)

1
src/assembly/x86-64/support.lisp
View file

@ -234,6 +234,7 @@
;; that 4-valued return is suboptimal because it didn't use 2 instructions to do the job of 1.
;; But if a microbenchmark can show that to be true, it suffices to change it only here
;; instead of in a few places.
#-tls-based-mv-return
(defmacro emit-mv-return (reg/mem &optional emit-stc)
;; All mv returns (incl. 0) need CF set, but it could occur outside (before) the macro
`(progn ,@(if emit-stc '((inst stc)))

15
src/code/debug-int.lisp
View file

@ -3634,10 +3634,25 @@
(compiled-debug-fun-compiler-debug-fun
(breakpoint-what bpt))))
(results nil))
#+tls-based-mv-return (declare (ignorable ocfp))
(case returns
(:standard
(let ((nargs (boxed-context-register scp sb-vm::nargs-offset))
(reg-arg-offsets '#.sb-vm::*register-arg-offsets*))
#+tls-based-mv-return
(let* ((misc (sb-vm::current-thread-offset-sap sb-vm::thread-breakpoint-misc-slot))
(mv-sap (if (zerop (sap-int misc))
(sap+ (sb-thread::current-thread-sap)
(ash sb-vm::thread-mv-return-values-slot sb-vm:word-shift))
misc)))
(dotimes (arg-num nargs)
(push (if reg-arg-offsets
(boxed-context-register scp (pop reg-arg-offsets))
(sap-ref-lispobj mv-sap
(ash (- arg-num sb-vm::register-arg-count)
sb-vm:word-shift)))
results)))
#-tls-based-mv-return
(dotimes (arg-num nargs)
(push (if reg-arg-offsets
(boxed-context-register scp (pop reg-arg-offsets))

3
src/code/interr.lisp
View file

@ -230,6 +230,9 @@
(with-simple-restart (continue "Ignore the last CDR")
(error 'values-list-argument-error :datum list :expected-type 'list)))
(deferr too-many-return-values-error (count)
(%program-error "Can not return ~D values (MULTIPLE-VALUES-LIMIT exceeded)" count))
(defun restart-unbound (symbol condition context)
(multiple-value-bind (tn-offset pc-offset)
(sb-c::decode-restart-location context)

1
src/cold/exports.lisp
View file

@ -2022,6 +2022,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
"%INSTANCE-SET"
"TESTABLE-TYPE-P"
"TLS-EXHAUSTED-ERROR"
"TOO-MANY-RETURN-VALUES-ERROR"
"*TOP-LEVEL-FORM-P*"
"TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/"
"TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-="

2
src/cold/shared.lisp
View file

@ -319,6 +319,8 @@
(push :os-thread-stack sb-xc:*features*))
(when (target-featurep '(:and :sb-thread :x86-64))
(push :tls-load-indirect sb-xc:*features*))
#+nil (when (target-featurep ':x86-64) ; not yet
(push :tls-based-mv-return sb-xc:*features*))
(when (target-featurep '(:and :x86 :int4-breakpoints))
;; 0xCE is a perfectly good 32-bit instruction,
;; unlike on x86-64 where it is illegal. It's therefore

7
src/compiler/early-c.lisp
View file

@ -31,7 +31,12 @@
"The exclusive upper bound on the number of parameters which may be specified
in a given lambda list. This is actually the limit on required and &OPTIONAL
parameters. With &KEY and &AUX you can get more.")
(defconstant multiple-values-limit call-arguments-limit
(defconstant multiple-values-limit
#-tls-based-mv-return call-arguments-limit
;; Careful: currently 1 byte of the thread state word stores the multiple-value count
;; as a tagged fixnum. There is a small bit of headroom to raise this limit to 128
;; (max count of 127) but any more needs a new thread slot.
#+tls-based-mv-return 65
"The exclusive upper bound on the number of multiple VALUES that you can
return.")

5
src/compiler/generic/genesis.lisp
View file

@ -3485,7 +3485,7 @@ struct thread_state_word {
// - control_stack_guard_page_protected is referenced from
// hand-written assembly code. (grep 'THREAD_STATE_WORD_OFFSET')
char control_stack_guard_page_protected;
char unused;
unsigned char ~:[unused~;mv_count~];
char state;
char user_thread_p; // opposite of lisp's ephemeral-p
char alien_stack_guard_page_protected;
@ -3495,7 +3495,8 @@ struct thread_state_word {
;; autogenerated files can use full paths to other inclusions
;; (in case your build system disfavors use of -I compiler options)
(namestring (merge-pathnames "gencgc-alloc-region.h" (lispobj-dot-h)))
sb-thread::alloc-histogram-words))
sb-thread::alloc-histogram-words
(or #+tls-based-mv-return t)))
(defun write-weak-pointer-manipulators ()
(format t "extern struct weak_pointer *weak_pointer_chain;~%")

1
src/compiler/generic/interr.lisp
View file

@ -104,6 +104,7 @@
("invalid argument count" invalid-arg-count 1)
("invalid argument count" local-invalid-arg-count 2)
("bogus argument to VALUES-LIST" bogus-arg-to-values-list 1)
("attempt to return too many values" too-many-return-values 1)
("An attempt was made to use an undefined SYMBOL-VALUE." unbound-symbol 1)
("attempt to RETURN-FROM a block that no longer exists" invalid-unwind 0)
("attempt to THROW to a non-existent tag" unseen-throw-tag 1)

6
src/compiler/generic/objdef.lisp
View file

@ -602,6 +602,12 @@ during backtrace.
(slow-path-allocs)
(et-find-freeish-page)
(et-bzeroing)
#+tls-based-mv-return ; An array of lispobj for multiple values
;; HACK - SB-VM::REGISTER-ARG-COUNT is not defined yet (it's in the "vm" file
;; but it could maybe be moved to the "parms" file). So our choices are to
;; hardcode a 3 here or oversize the array and let confusion reign.
;; Also remember, limit is an exclusive upper bound so "size" is 1 less.
(mv-return-values :length #.(- (1- sb-xc:multiple-values-limit) 3))
;; The *current-thread* MUST be the last slot in the C thread structure.
;; It it the only slot that needs to be noticed by the garbage collector.
(lisp-thread :pointer t :special sb-thread:*current-thread*))

29
src/compiler/ir2tran.lisp
View file

@ -1691,6 +1691,35 @@
(nil)
(return-info-locations returns))))
((eq lvar-kind :fixed)
#+tls-based-mv-return
(let* ((types (loop for tn in (ir2-lvar-locs 2lvar)
for i from 0
collect
;; TLS MV area requires boxed values.
;; Only call tn-primitive-type for the register results.
(if (< i sb-vm::register-arg-count)
(tn-primitive-type tn)
*backend-t-primitive-type*)))
(lvar-locs (lvar-tns node block lvar types))
(nvals (length lvar-locs))
(nregs (min nvals sb-vm::register-arg-count))
(reg-locs (make-standard-value-tns nregs)))
(when (>= nvals multiple-values-limit)
(compiler-warn "Can not return ~D values" nvals))
;; Calling MAKE-STANDARD-VALUE-TNS for more than the number of result-passing regs
;; would go wrong because the standard location of the excess results is the stack.
;; We also can't call EMIT-MOVE. RETURN vop will deal with some LVAR-LOCS as-is
(mapc (lambda (val loc) (emit-move node block val loc)) lvar-locs reg-locs)
;; +/-tls-based are the nearly the same from here down
;; but I don't see how to easily share the code.
(if (= nvals 1)
(vop return-single node block old-fp return-pc (car reg-locs))
(let ((locs (append reg-locs (nthcdr nregs lvar-locs))))
(vop* return node block
(old-fp return-pc (reference-tn-list locs nil))
(nil)
nvals))))
#-tls-based-mv-return
(let* ((types (mapcar #'tn-primitive-type (ir2-lvar-locs 2lvar)))
(lvar-locs (lvar-tns node block lvar types))
(nvals (length lvar-locs))

119
src/compiler/x86-64/call.lisp
View file

@ -279,7 +279,8 @@
;;; returned, regardless of the number of values desired.
(defun default-unknown-values (vop values nvals node rbx move-temp)
(declare (type (or tn-ref null) values)
(type unsigned-byte nvals))
(type unsigned-byte nvals)
#+tls-based-mv-return (ignore rbx))
(multiple-value-bind (type name leaf) (sb-c::lvar-fun-type (sb-c::basic-combination-fun node))
(let* ((verify (and leaf
(policy node (and (>= safety 1)
@ -333,9 +334,9 @@
register-arg-count)))
((and trust
(not (sb-kernel:values-type-may-be-single-value-p type)))
(inst mov rsp-tn rbx))
#-tls-based-mv-return (inst mov rsp-tn rbx))
(t
(inst cmov :c rsp-tn rbx)
#-tls-based-mv-return (inst cmov :c rsp-tn rbx)
(unless trust
(inst mov move-temp (fixnumize 1))
(inst cmov :nc rcx-tn move-temp)
@ -363,9 +364,10 @@
do
(inst mov (tn-ref-tn tn-ref)
(if 2nd-tn-live 2nd-tn null-tn)))))
(inst mov rbx rsp-tn)
#-tls-based-mv-return (inst mov rbx rsp-tn)
regs-defaulted))
#-tls-based-mv-return
(when (or (not trust)
(< register-arg-count
(sb-kernel:values-type-max-value-count type)))
@ -417,6 +419,13 @@
;; is assumed to fit in a :dword register.
(inst cmp :dword rcx-tn (fixnumize i))
(inst jmp :be default-lab)))
#+tls-based-mv-return
(let ((src (thread-slot-ea (+ thread-mv-return-values-slot
(- i register-arg-count)))))
(inst mov tn (sc-case tn
(control-stack (inst mov move-temp src) move-temp)
(t src))))
#-tls-based-mv-return
(sc-case tn
(control-stack
(loadw move-temp rbx (frame-word-offset (+ sp->fp-offset i)))
@ -424,7 +433,7 @@
(t
(loadw tn rbx (frame-word-offset (+ sp->fp-offset i))))))))
DEFAULTING-DONE
(move rsp-tn rbx)
#-tls-based-mv-return (move rsp-tn rbx)
(unless trust
(check-nargs))
DONE
@ -436,7 +445,7 @@
(emit-label default-stack-slots)
(loop for reg in used-registers
do (inst mov reg null-tn))
(move rbx rsp-tn))
#-tls-based-mv-return (move rbx rsp-tn))
(dolist (default defaults)
(emit-label (car default))
(inst mov (cdr default) null-tn))
@ -463,6 +472,7 @@
;;; them.)
(defun receive-unknown-values (args nargs start count node)
(declare (type tn args nargs start count))
#-tls-based-mv-return ;; Old way
(let ((type (sb-c::basic-combination-derived-type node))
(variable-values (gen-label))
(stack-values (gen-label))
@ -507,6 +517,66 @@
(move count nargs))
(emit-label done))
#+tls-based-mv-return ;; New way
(let ((type (sb-c::basic-combination-derived-type node))
(variable-values (gen-label))
(done (gen-label))
(unused-count-p (eq (tn-kind count) :unused)))
(when (sb-kernel:values-type-may-be-single-value-p type)
(inst jmp :c variable-values)
(cond ((eq (tn-kind start) :unused)
(inst push (first *register-arg-tns*)))
((location= start (first *register-arg-tns*))
(inst push (first *register-arg-tns*))
(inst lea start (ea n-word-bytes rsp-tn)))
(t (inst mov start rsp-tn)
(inst push (first *register-arg-tns*))))
(unless unused-count-p
(inst mov count (fixnumize 1)))
(inst jmp done)
(emit-label variable-values))
;; Save current rsp into args (values-start) before allocating stack space
(inst mov args rsp-tn)
;; Allocate stack space for nargs values
(let ((delta rax-tn))
(inst mov :dword delta nargs)
(inst shl :dword delta (- word-shift n-fixnum-tag-bits))
(inst sub rsp-tn delta))
;; Store register args onto stack
(loop
for arg in *register-arg-tns*
for i downfrom -1
for j below (sb-kernel:values-type-max-value-count type)
do (storew arg args i))
;; If > 3 values, copy thread-mv-return-values onto stack
(when (> (sb-kernel:values-type-max-value-count type) register-arg-count)
(let ((countdown rsi-tn)
(index rax-tn)
(stack-ptr rdi-tn)
(scratch rdx-tn))
(assemble ()
(inst cmp :dword nargs (fixnumize register-arg-count))
(inst jmp :le copy-done)
(inst lea :dword countdown (ea (fixnumize (- register-arg-count)) nargs))
(inst lea stack-ptr (ea (- (* (1+ register-arg-count) n-word-bytes)) args))
(zeroize index)
COPY-LOOP
(inst mov scratch
(ea (+ (ash thread-mv-return-values-slot word-shift)) thread-tn index 8))
(inst mov (ea stack-ptr) scratch)
(inst sub stack-ptr n-word-bytes)
(inst inc :dword index)
(inst sub :dword countdown (fixnumize 1))
(inst jmp :nz copy-loop)
;; Restore a0 (rdi) from [args - 8]
(loadw (first *register-arg-tns*) args -1)
COPY-DONE)))
(unless (eq (tn-kind start) :unused)
(move start args))
(unless unused-count-p
(move count nargs))
(emit-label done))
(values))
;;; VOP that can be inherited by unknown values receivers. The main thing this
@ -1012,12 +1082,13 @@
(:args (old-fp)
(return-pc :to (:eval 1))
(values :more t))
(:ignore values)
#-tls-based-mv-return (:ignore values)
(:vop-var vop)
(:info nvals)
;; In the case of other than one value, we need these registers to
;; tell the caller where they are and how many there are.
(:temporary (:sc unsigned-reg :offset rbx-offset) rbx)
(:temporary (:sc unsigned-reg :offset rcx-offset) rcx)
(:temporary (:sc any-reg :offset rcx-offset) rcx)
;; We need to stretch the lifetime of return-pc past the argument
;; registers so that we can default the argument registers without
;; trashing return-pc.
@ -1034,7 +1105,7 @@
;; This is handled in RETURN-SINGLE.
(error "nvalues is 1"))
;; Establish the values pointer and values count.
(inst lea rbx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
#-tls-based-mv-return (inst lea rbx (ea (* sp->fp-offset n-word-bytes) rbp-tn))
(if (zerop nvals)
(zeroize rcx) ; smaller
(inst mov rcx (fixnumize nvals)))
@ -1042,6 +1113,8 @@
(when (< nvals register-arg-count)
(dolist (tn (nthcdr nvals (list a0 a1 a2)))
(move tn null-tn)))
#-tls-based-mv-return
(progn
;; Set the multiple value return flag.
(inst stc)
;; And away we go. Except that return-pc is still on the
@ -1061,7 +1134,33 @@
(ea (frame-byte-offset (1- nvals)) rbp-tn))
(move rbp-tn old-fp)
(emit-mv-return
(ea (frame-byte-offset (+ sp->fp-offset (tn-offset return-pc))) rbx))))))
(ea (frame-byte-offset (+ sp->fp-offset (tn-offset return-pc))) rbx)))))
#+tls-based-mv-return
(cond
((>= nvals multiple-values-limit)
(error-call vop 'too-many-return-values-error rcx))
(t
;; If nvals > register-arg-count, copy the extras to thread->mv_return_values.
;; Compared to #-tls-based-mv-return this looks like it's doing more, but that's
;; only because ir2-convert-return did not move results to the receiving frame.
(when (> nvals register-arg-count)
(do ((tn-ref (do ((i register-arg-count (1- i)) ; skip over this many
(ref values (tn-ref-across ref)))
((zerop i) ref))
(tn-ref-across tn-ref))
(slot 0 (1+ slot)))
((null tn-ref))
(inst mov (thread-slot-ea (+ thread-mv-return-values-slot slot))
(let ((tn (tn-ref-tn tn-ref)))
(cond ((sc-is tn immediate) (immediate-tn-repr tn))
((sc-is tn any-reg descriptor-reg) tn)
(t (inst mov rbx tn) rbx))))) ; use RBX as a scratch reg
;; Inform GC of the high water mark so it can clear below. If a function returns a huge
;; object as its 39th value, the next function to store a smaller number of values
;; grants permission to smash the huge object. Maybe always do this store?
(inst mov :byte (thread-mv-count) (fixnumize nvals)))
(inst stc) ; multiple value return flag
(inst leave) (inst ret)))))
;;; Do unknown-values return of an arbitrary number of values (passed
;;; on the stack.) We check for the common case of a single return

5
src/compiler/x86-64/macros.lisp
View file

@ -108,6 +108,11 @@
(let (#+gs-seg (thread-tn nil))
(ea thread-segment-reg (ash slot-index word-shift) thread-tn))))
#+tls-based-mv-return
(defmacro thread-mv-count ()
;; This is byte index 1 of thread_state_word
'(ea (1+ (ash thread-state-word-slot word-shift)) thread-tn))
;;; Similar to thread-slot-ea, but INDEX in this case does not signify the Nth slot {0,1,2,..}
;;; but rather the displacement into the thread's storage, added to the thread base address.
(defun thread-tls-ea (index)

13
src/runtime/breakpoint.c
View file

@ -136,6 +136,14 @@ void *handle_fun_end_breakpoint(os_context_t *context)
lispobj code, lra;
struct code *codeptr;
DX_ALLOC_SAP(context_sap, context);
#ifdef LISP_FEATURE_TLS_BASED_MV_RETURN
struct thread *th = get_sb_vm_thread();
__typeof__(th->mv_return_values) saved_mv_return_values;
memcpy(saved_mv_return_values, th->mv_return_values, sizeof saved_mv_return_values);
unsigned char saved_mv_count = th->state_word.mv_count;
void *old_misc = th->breakpoint_misc;
th->breakpoint_misc = saved_mv_return_values;
#endif
fake_foreign_function_call(context);
@ -177,6 +185,11 @@ void *handle_fun_end_breakpoint(os_context_t *context)
undo_fake_foreign_function_call(context);
#ifdef LISP_FEATURE_TLS_BASED_MV_RETURN
memcpy(th->mv_return_values, saved_mv_return_values, sizeof saved_mv_return_values);
th->state_word.mv_count = saved_mv_count;
th->breakpoint_misc = old_misc;
#endif
#ifdef reg_LRA
return (void *)(lra-OTHER_POINTER_LOWTAG+sizeof(lispobj));
#else

16
src/runtime/gc-common.c
View file

@ -3309,3 +3309,19 @@ char* vm_thread_name(struct thread* th)
if (simple_base_string_p(name)) return vector_sap(name);
return "?";
}
#ifdef LISP_FEATURE_TLS_BASED_MV_RETURN
int thread_multiple_value_hwm(struct thread* th)
{
int limit = (int)(sizeof th->mv_return_values / sizeof (lispobj));
// ASSUMPTION: 3 of the multiple-values can go in registers so the thread-local
// area is only used if at least 4 values were returned from some function.
int count = fixnum_value(th->state_word.mv_count) - 3;
if (count > limit) count = limit;
if (count < 0) count = 0;
// scrub unused cells
memset(&th->mv_return_values[count], 0, (limit-count)<<WORD_SHIFT);
// Return the inclusive bound of the last cell used. -1 is acceptable
return count - 1;
}
#endif

11
src/runtime/gencgc.c
View file

@ -3266,6 +3266,17 @@ conservative_stack_scan(struct thread* th,
preserve_pointer(word, 0);
}
}
#ifdef LISP_FEATURE_TLS_BASED_MV_RETURN
// Scavenging would be better than pinning, however we can not move objects
// yet at this point because not all threads have completed their stack scan,
// so we don't know what to actually pin. It would demand two passes.
for (int i = thread_multiple_value_hwm(th); i >= 0 ; --i) {
lispobj word = th->mv_return_values[i];
if (word >= BACKEND_PAGE_BYTES && potential_heap_pointer(word)) {
preserve_pointer(word, 0);
}
}
#endif
}
#endif

8
src/runtime/pmrgc.c
View file

@ -727,6 +727,14 @@ conservative_stack_scan(struct thread* th,
preserve_pointer(word, 0);
}
}
#ifdef LISP_FEATURE_TLS_BASED_MV_RETURN
for (int i = thread_multiple_value_hwm(th); i >= 0 ; --i) {
lispobj word = th->mv_return_values[i];
if (word >= BACKEND_PAGE_BYTES && potential_heap_pointer(word)) {
preserve_pointer(word, 0);
}
}
#endif
}
#endif

3
src/runtime/thread.h
View file

@ -366,4 +366,7 @@ extern int handle_tls_deref_trap(os_context_t*, os_vm_address_t);
# define bytes_per_tls_symbol N_WORD_BYTES
#endif
// Return the high-water-mark of the multiple-value return area
extern int thread_multiple_value_hwm(struct thread*);
#endif /* _INCLUDE_THREAD_H_ */

2
src/runtime/x86-64-assem.S
View file

@ -212,11 +212,13 @@ Lcall:
sub NIL_CARDTABLE_DISP, reg_NULL
call *CLOSURE_FUN_OFFSET(%rax)
#ifndef LISP_FEATURE_TLS_BASED_MV_RETURN
/* If the function returned multiple values, the carry flag will be set.
Lose them */
jnc LsingleValue
mov %rbx, %rsp
LsingleValue:
#endif
#ifdef LISP_FEATURE_NONSTOP_FOREIGN_CALL
pop %r8

8
tests/compiler-2.pure.lisp
View file

@ -118,9 +118,10 @@
(with-test (:name (nth-value :huge-n :works))
(flet ((return-a-ton-of-values ()
(values-list (loop for i below 5000 collect i))))
(values-list (loop for i below (min 5000 (1- multiple-values-limit)) collect i))))
(assert (= (nth-value 1 (return-a-ton-of-values)) 1))
(assert (= (nth-value 4000 (return-a-ton-of-values)) 4000))))
(let ((n (min 4000 (- multiple-values-limit 2))))
(assert (= (nth-value n (return-a-ton-of-values)) n)))))
(with-test (:name :internal-name-p :skipped-on :sb-xref-for-internals)
(assert (sb-c::internal-name-p 'sb-int:neq)))
@ -824,7 +825,8 @@
`(lambda (n x)
(declare (sb-vm:word n))
(log (float n))
(nth-value 33 (funcall x . #.(loop for i to 350 collect i))))
(nth-value 33 (funcall x . #.(loop for i to (min 350 (- multiple-values-limit 2))
collect i))))
((10 (lambda (&rest args) (values-list args))) 33)))
(with-test (:name (dynamic-extent :recursive-local-functions))

5
tests/compiler.impure-cload.lisp
View file

@ -350,6 +350,7 @@
;;; failed on Alpha prior to sbcl-0.8.10.30
(defun lotso-values ()
#.(let ((form ' ; tries to return 100 values
(values 0 1 2 3 4 5 6 7 8 9
0 1 2 3 4 5 6 7 8 9
0 1 2 3 4 5 6 7 8 9
@ -360,6 +361,10 @@
0 1 2 3 4 5 6 7 8 9
0 1 2 3 4 5 6 7 8 9
0 1 2 3 4 5 6 7 8 9))
)
(if (>= multiple-values-limit 101) ; required M-V-LIMIT for the test to pass
form ; as it was originally written
(subseq form 0 multiple-values-limit))))
;;; bug 313: source transforms were "lisp-1"
(defun srctran-lisp1-1 (cadr) (if (functionp cadr) (funcall cadr 1) nil))

76
tests/mv-return.pure.lisp Normal file
View file

@ -0,0 +1,76 @@
#-tls-based-mv-return (invoke-restart 'run-tests::skip-file)
(with-test (:name :too-many-values-compile-time-error)
(assert (nth-value 1
(checked-compile
`(lambda ()
(values ,@(loop for i from 10 repeat multiple-values-limit collect i)))
:allow-warnings t))))
(with-test (:name :values-list-too-many-values-safely-fails)
(let ((fn (checked-compile `(lambda ()
(values-list
(opaque-identity (make-list multiple-values-limit
:initial-element #\x)))))))
(assert (eq :failed-safely
(handler-case (funcall fn)
(program-error () :failed-safely))))))
;; Non-tail values-list returning out of a CATCH
(with-test (:name :return-multiple-too-many-values-in-catch)
(let ((fn (checked-compile
`(lambda ()
(catch 'done
(values-list
(opaque-identity (make-list multiple-values-limit
:initial-element #\x))))))))
(assert (eq :failed-safely
(handler-case (funcall fn)
(program-error () :failed-safely))))))
;; Non-tail values-list returning out of an UNWIND-PROTECT
(with-test (:name :return-multiple-too-many-values-in-unwind-protect)
(let ((fn (checked-compile
`(lambda ()
(unwind-protect
(values-list
(opaque-identity (make-list multiple-values-limit
:initial-element #\y)))
(opaque-identity nil))))))
(assert (eq :failed-safely
(handler-case (funcall fn)
(program-error () :failed-safely))))))
;; Valid MULTIPLE-VALUE-CALL exceeding multiple-values-limit
;; (VALUES-LIST as an argument producer is not erroneously capped)
(with-test (:name :multiple-value-call-exceeds-mv-limit-ok)
(let ((fn (checked-compile
`(lambda ()
(multiple-value-call #'list
(values-list (make-list 40 :initial-element 1))
(values-list (make-list 40 :initial-element 2)))))))
(assert (= (length (funcall fn)) 80))))
;;;
(defun get-mv-return-count ()
(let ((word (sb-sys:sap-int (sb-vm::current-thread-offset-sap sb-vm:thread-state-word-slot))))
;; assumes little-endian
(ash (ldb (byte 8 8) word) (- sb-vm:n-fixnum-tag-bits))))
(defun hairy-result ()
(loop for i from 0 repeat 32 collect (list 'massive-structure i)))
(with-test (:name :mv-area-gc-scrubbing :fails-on :interpreter)
(let ((f1 (checked-compile `(lambda () (values-list (hairy-result)))))
(f2 (checked-compile `(lambda () (values-list (list 'a 'b 'c 'd 'e))))))
(funcall f1)
(funcall f2)
(gc :full t)
(let ((mv-count (get-mv-return-count)))
(assert (= mv-count 5))
(loop for i from (+ sb-vm::thread-mv-return-values-slot 2)
for word = (sb-sys:sap-int (sb-vm::current-thread-offset-sap i))
repeat 30 ; arb
do (assert (zerop word))))))