master: arm64: fix undefined restarts for call-symbol

The branch "master" has been updated in SBCL:
       via  828810aa336a4df55433fc26c54651c87d463ac7 (commit)
      from  ca4a7476645288c0370d52ec87a3b01ad88b29d4 (commit)

- Log -----------------------------------------------------------------
commit 828810aa336a4df55433fc26c54651c87d463ac7
Author: Stas Boukarev <[email protected]>
Date:   Sat Apr 18 22:02:27 2026 +0300

    arm64: fix undefined restarts for call-symbol
---
 src/assembly/arm64/assem-rtns.lisp |  4 ++--
 src/assembly/assemfile.lisp        | 25 ++++++++++++++++++++-----
 src/compiler/arm64/insts.lisp      |  2 +-
 tests/condition-2.pure.lisp        | 13 ++++++++++++-
 4 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/src/assembly/arm64/assem-rtns.lisp b/src/assembly/arm64/assem-rtns.lisp
index dc7b03744..141cf1d73 100644
--- a/src/assembly/arm64/assem-rtns.lisp
+++ b/src/assembly/arm64/assem-rtns.lisp
@@ -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)
diff --git a/src/assembly/assemfile.lisp b/src/assembly/assemfile.lisp
index a4e48bdb7..3a794a59f 100644
--- a/src/assembly/assemfile.lisp
+++ b/src/assembly/assemfile.lisp
@@ -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
diff --git a/src/compiler/arm64/insts.lisp b/src/compiler/arm64/insts.lisp
index b4561c6c7..ace10478e 100644
--- a/src/compiler/arm64/insts.lisp
+++ b/src/compiler/arm64/insts.lisp
@@ -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
diff --git a/tests/condition-2.pure.lisp b/tests/condition-2.pure.lisp
index 74d3f0148..8ed0621f5 100644
--- a/tests/condition-2.pure.lisp
+++ b/tests/condition-2.pure.lisp
@@ -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)

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL