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: fix undefined restarts for call-symbol

Browse source
This commit is contained in:
Stas Boukarev 2026-04-18 22:02:27 +03:00
parent ca4a747664
commit 828810aa33
4 changed files with 35 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/assembly/arm64/assem-rtns.lisp
View file

@ -283,14 +283,14 @@
(inst b :ne not-callable)
(loadw temp fun symbol-fdefn-slot other-pointer-lowtag)
(inst cbz temp (make-fixup 'undefined-tramp :assembly-routine))
(inst cbz temp (make-fixup 'undefined-tramp :assembly-routine 1))
(move fun temp)
(loadw lr-tn fun fdefn-raw-addr-slot other-pointer-lowtag)
(inst add lr-tn lr-tn 4)
(inst br lr-tn)
NOT-CALLABLE
(inst cmp fun null-tn) ;; NIL doesn't have SYMBOL-WIDETAG
(inst b :eq (make-fixup 'undefined-tramp :assembly-routine))
(inst b :eq (make-fixup 'undefined-tramp :assembly-routine 1))
(cerror-call nil 'sb-kernel::object-not-callable-error fun)
(inst and temp fun lowtag-mask)
(inst cmp temp fun-pointer-lowtag)

25
src/assembly/assemfile.lisp
View file

@ -137,18 +137,33 @@
;; changed to labels. For now, restrict to control transfers.
(binding* ((patch
(when (member (stmt-mnemonic statement)
'("B" "BEQ" "JMP" "CALL") ; KLUDGE
'("B" "BEQ" "JMP" "CALL" "CBZ" "CBNZ" "TBZ" "TBNZ") ; KLUDGE
:test 'string=)
(member-if (lambda (x)
(and (typep x 'fixup)
(eq (fixup-flavor x) :assembly-routine)
(eql (fixup-offset x) 0)))
(eq (fixup-flavor x) :assembly-routine)))
(stmt-operands statement)))
:exit-if-null)
(ep (assoc (fixup-name (car patch)) *entry-points*)))
(fixup (car patch))
(ep (assoc (fixup-name fixup) *entry-points*)))
;; oy. what is (third ep) ? An offset?
(aver (and ep (= (third ep) 0)))
(rplaca patch (second ep)))))
(let ((label (second ep)))
;; Make a new label for fixup-offset
(unless (eql (fixup-offset fixup) 0)
(let* ((target (do ((stmt (stmt-next (section-start section)) (stmt-next stmt)))
((null stmt)
(error "Label for ~a not found" ep))
(when (eq label (stmt-labels stmt))
(return stmt))))
(new-target
(loop for i from 1
for stmt = (stmt-next target) then (stmt-next stmt)
when (= (fixup-offset fixup) i)
return stmt)))
(setf label (gen-label))
(add-stmt-labels new-target (list label))))
(rplaca patch label)))))
(defun expand-align-option (align)
(when align

2
src/compiler/arm64/insts.lisp
View file

@ -1867,7 +1867,7 @@
(note-fixup segment :uncond-branch cond-or-label)
(emit-uncond-branch segment 0 0))
((fixup-p label)
(note-fixup segment :cond-branch cond-or-label)
(note-fixup segment :cond-branch label)
(emit-cond-branch segment 0 (conditional-opcode cond-or-label)))
(t
(emit-back-patch segment 4

13
tests/condition-2.pure.lisp
View file

@ -509,7 +509,7 @@
(defun (setf thing) (a b) (declare (ignore b)) a)
(with-test (:name :undefined-restart
:skipped-on (not :undefined-fun-restarts))
:implemented-on :undefined-fun-restarts)
(let* ((name (gensym))
(tail-call (checked-compile `(lambda () (,name)) :allow-style-warnings t))
(call (checked-compile `(lambda () (1+ (,name))) :allow-style-warnings t))
@ -540,6 +540,17 @@
(assert (eq (test-use-value return '(setf thing)) #'(setf thing)))
(assert (eq (test-use-value return #'(setf thing)) #'(setf thing))))))
(with-test (:name :undefined-restart-call-symbol
:implemented-on :undefined-fun-restarts)
(handler-bind ((undefined-function (lambda (c) (use-value '- c))))
(let ((f (checked-compile `(lambda (m)
(- (funcall m 2))))))
(assert (= (funcall f (gensym)) 2))))
(handler-bind ((undefined-function (lambda (c) (use-value '- c))))
(let ((f (checked-compile `(lambda (m)
(funcall m 3)))))
(assert (= (funcall f (gensym)) -3)))))
;;; Assert that the USE-VALUE restart for SYMBOL-FUNCTION
;;; lets you specify any function.
(with-test (:name :undefined-restart-symbol-function)