master: Avoid a metacircle when finding component names

The branch "master" has been updated in SBCL:
       via  828b918e052cbdf7d039c328beffa880cca0d8f0 (commit)
      from  8d1ca5121c8a95baa7747753c2e7245eb8980205 (commit)

- Log -----------------------------------------------------------------
commit 828b918e052cbdf7d039c328beffa880cca0d8f0
Author: Stas Boukarev <[email protected]>
Date:   Fri May 22 00:44:48 2026 +0300

    Avoid a metacircle when finding component names
    
    Don't turn them into strings. Printing can produce a pcl cache miss
    that won't get resolved because it will try to print the name of the
    new dispatch function.
---
 src/compiler/ir1report.lisp | 25 ++++++++-----------------
 1 file changed, 8 insertions(+), 17 deletions(-)

diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp
index 7be94795d..b84e49128 100644
--- a/src/compiler/ir1report.lisp
+++ b/src/compiler/ir1report.lisp
@@ -513,24 +513,15 @@ has written, having proved that it is unreachable."))
     (force-output stream)
     (values)))
 
-;;; Return a string that somehow names the code in COMPONENT. We use
-;;; the source path for the bind node for an arbitrary entry point to
-;;; find the source context, then return that as a string.
-(declaim (ftype (function (component) simple-string) find-component-name))
+;;; We use the source path for the bind node for an arbitrary entry
+;;; point to find the source context.
+(declaim (ftype (sfunction (component) t) find-component-name))
 (defun find-component-name (component)
-  (let ((ep (first (block-succ (component-head component)))))
-    (aver ep) ; else no entry points??
-    (multiple-value-bind (form context)
-        (find-original-source (node-source-path (block-start-node ep)))
-      (declare (ignore form))
-      (let ((*print-level* 2)
-            (*print-pretty* nil))
-        ;; It's arbitrary how this name is stringified.
-        ;; Using ~A in lieu of ~S prevents "SB-" strings from getting in.
-        (format nil
-                "~{~{~A~^ ~}~^ => ~}"
-                #+sb-xc-host (list (list (caar context)))
-                #-sb-xc-host context)))))
+  (let* ((ep (first (block-succ (component-head component))))
+         (context (nth-value 1
+                             (find-original-source (node-source-path (block-start-node ep))))))
+
+    (car context)))
 
 ;;;; condition system interface
 

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


hooks/post-receive
-- 
SBCL