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

arm64: start implementing pass-through-call

Browse source 
Add only the VOPs in call.lisp
Unbreak the build where pass-through-call is disabled/unimplemented.
This commit is contained in:
Stas Boukarev 2026-09-04 17:46:30 +03:00
parent f2e1794438
commit 82fdbae144
4 changed files with 44 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
src/compiler/arm64/call.lisp
View file

@ -1053,7 +1053,7 @@
,@(when (memq return '(:fixed :unboxed))
'((:results (values :more t))))
(:save-p ,(if (eq return :tail) :compute-only t))
(:save-p ,(if (member return '(:tail :pass-through)) :compute-only t))
,@(unless (or (eq return :tail)
variable)
@ -1085,7 +1085,8 @@
(:fixed '(ocfp-temp))
(:unboxed '(ocfp-temp node values))
(:tail '(old-fp return-pc node))
(:unknown '(r0-temp))))))
(:unknown '(r0-temp))
(:pass-through '(node))))))
,@(unless (eq named :direct)
`((:temporary (:sc descriptor-reg :offset lexenv-offset
@ -1272,7 +1273,9 @@
((:unboxed)
'((when cur-nfp
(load-stack-tn cur-nfp nfp-save))))
((:tail))))))))
(:pass-through
'((note-this-location vop :unknown-return)))
(:tail)))))))
(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
@ -1290,6 +1293,14 @@
(define-full-call fixed-call-named t :fixed nil :fixed)
(define-full-call fixed-tail-call-named t :tail nil :fixed)
#+tls-based-mv-return
(progn
(define-full-call pass-through-call nil :pass-through nil)
(define-full-call pass-through-call-named t :pass-through nil)
(define-full-call fixed-pass-through-call-named t :pass-through nil :fixed)
(define-full-call pass-through-call-variable nil :pass-through t))
(define-full-call unboxed-call-named t :unboxed nil)
(define-full-call fixed-unboxed-call-named t :unboxed nil :fixed)
(define-full-call fixed-multiple-call-named t :unknown nil :fixed)
@ -1383,6 +1394,10 @@
(move csp-tn cfp-tn)
(lisp-return lr :single-value t)))
(define-vop (return-pass-through return-single)
(:args (old-fp)
(return-pc)))
;;; Do unknown-values return of a fixed number of values. The Values are
;;; required to be set up in the standard passing locations. Nvals is the
;;; number of values returned.

7
src/compiler/ir2tran.lisp
View file

@ -1424,6 +1424,7 @@
(emit-step-p node)))))))))))
(values))
#+(and x86-64 tls-based-mv-return)
(defun ir2-convert-pass-through-full-call (node block)
(declare (type combination node) (type ir2-block block))
(multiple-value-bind (fp args arg-locs nargs fixed-args-p)
@ -1548,6 +1549,7 @@
(ponder-full-call node)
(cond ((node-tail-p node)
(ir2-convert-tail-full-call node block))
#+(and x86-64 tls-based-mv-return)
((let ((lvar (node-lvar node)))
(and lvar
(eq (ir2-lvar-kind (lvar-info lvar)) :pass-through)))
@ -1821,6 +1823,7 @@
(old-fp return-pc (reference-tn-list locs nil))
(nil)
nvals))))
#+(and x86-64 tls-based-mv-return)
((eq lvar-kind :pass-through)
(vop sb-vm::return-pass-through node block old-fp return-pc))
(t
@ -1929,6 +1932,7 @@
(vop tail-call-variable node block start fun
(ir2-environment-old-fp env)
(ir2-environment-return-pc env))))
#+(and x86-64 tls-based-mv-return)
((and 2lvar
(eq (ir2-lvar-kind 2lvar) :pass-through))
(vop* sb-vm::pass-through-call-variable node block (start fun nil)
@ -2322,7 +2326,8 @@
(start-loc (make-nlx-entry-arg-start-location))
(count-loc (make-arg-count-location))
(2lvar (and lvar (lvar-info lvar))))
(cond ((and 2lvar (eq (ir2-lvar-kind 2lvar) :pass-through))
(cond #+(and x86-64 tls-based-mv-return)
((and 2lvar (eq (ir2-lvar-kind 2lvar) :pass-through))
(vop* sb-vm::nlx-entry-pass-through node block
(start-loc count-loc nil)
(nil)

8
src/compiler/ltn.lisp
View file

@ -425,9 +425,11 @@
(values nil :unknown)
(values-types int))
(if (eq kind :unknown)
(if (return-pass-through-p node lvar)
(annotate-pass-through-values-lvar lvar)
(annotate-unknown-values-lvar lvar))
(cond #+(and x86-64 tls-based-mv-return)
((return-pass-through-p node lvar)
(annotate-pass-through-values-lvar lvar))
(t
(annotate-unknown-values-lvar lvar)))
(annotate-fixed-values-lvar
lvar (mapcar #'primitive-type types)
types)))))

20
src/compiler/meta-vmdef.lisp
View file

@ -1037,7 +1037,8 @@
arg-refs
arg-refs-p
result-refs
result-refs-p)
result-refs-p
(inherited-ignore (vop-parse-ignores parse)))
(dolist (spec specs)
(unless (consp spec)
(error "malformed option specification: ~S" spec))
@ -1144,9 +1145,9 @@
(cond (result-refs-p
(loop with refs = result-refs
for result in (if results-p
(vop-parse-results parse)
(setf (vop-parse-results parse)
(mapcar #'copy-structure (vop-parse-results parse))))
(vop-parse-results parse)
(setf (vop-parse-results parse)
(mapcar #'copy-structure (vop-parse-results parse))))
for ref = (pop refs)
when ref
do (setf (operand-parse-temp result) ref)))
@ -1156,6 +1157,16 @@
for result in (vop-parse-results parse)
do (setf (operand-parse-temp result)
(operand-parse-temp inherited-result)))))
(set-vop-parse-operands parse)
(setf (vop-parse-ignores parse)
;; remove inherited ignores for not inherited operands
(remove-if
(lambda (ignore)
(and (member ignore inherited-ignore)
(not (or
(member ignore (vop-parse-info-args parse))
(member ignore (vop-parse-operands parse) :key #'operand-parse-name)))))
(vop-parse-ignores parse)))
(values)))
;;;; making costs and restrictions
@ -1774,7 +1785,6 @@
(setf (vop-parse-inherits parse) inherits)
(parse-define-vop parse specs inherited-parse)
(set-vop-parse-operands parse)
(check-operand-types parse
(vop-parse-args parse)
(vop-parse-more-args parse)