0.pre7.86.flaky7:

[sbcl.git] / src / compiler / ir1opt.lisp

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 63c475e..c7b26e3 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -687,8 +687,8 @@
                    ;; cross-compiler doesn't know how to evaluate it.
                    #+sb-xc-host
                    (let* ((ref (continuation-use (combination-fun node)))
-                          (fun (leaf-name (ref-leaf ref))))
-                     (fboundp fun)))
+                          (fun-name (leaf-source-name (ref-leaf ref))))
+                     (fboundp fun-name)))
           (constant-fold-call node)
           (return-from ir1-optimize-combination)))
 
@@ -800,6 +800,10 @@
             (:inline t)
             (:no-chance nil)
             ((nil :maybe-inline) (policy call (zerop space))))
+          ;; FIXME: In sbcl-0.pre7.87, it looks as though we'll
+          ;; get here when LEAF is a GLOBAL-VAR (not a DEFINED-FUN)
+          ;; whenever (ZEROP SPACE), in which case we'll die with
+          ;; a type error when we try to access LEAF as a DEFINED-FUN.
           (defined-fun-inline-expansion leaf)
           (let ((fun (defined-fun-functional leaf)))
             (or (not fun)
@@ -821,10 +825,10 @@
       (values (ref-leaf (continuation-use (basic-combination-fun call)))
              nil))
      (t
-      (let* ((name (leaf-name leaf))
+      (let* ((name (leaf-source-name leaf))
             (info (info :function :info
                         (if (slot-accessor-p leaf)
-                            (if (consp name)
+                            (if (consp source-name) ; i.e. if SETF function
                                 '%slot-setter
                                 '%slot-accessor)
                             name))))
@@ -875,7 +879,7 @@
         (values nil nil))))
 
 ;;; This is called by IR1-OPTIMIZE when the function for a call has
-;;; changed. If the call is local, we try to let-convert it, and
+;;; changed. If the call is local, we try to LET-convert it, and
 ;;; derive the result type. If it is a :FULL call, we validate it
 ;;; against the type, which recognizes known calls, does inline
 ;;; expansion, etc. If a call to a predicate in a non-conditional
@@ -900,19 +904,30 @@
                 (continuation-use (basic-combination-fun call))
                 call))
               ((not leaf))
-              ((or (info :function :source-transform (leaf-name leaf))
+              ((or (info :function :source-transform (leaf-source-name leaf))
                    (and info
                         (ir1-attributep (function-info-attributes info)
                                         predicate)
                         (let ((dest (continuation-dest (node-cont call))))
                           (and dest (not (if-p dest))))))
-               (let ((name (leaf-name leaf)))
-                 (when (symbolp name)
-                   (let ((dums (make-gensym-list (length
-                                                  (combination-args call)))))
-                     (transform-call call
-                                     `(lambda ,dums
-                                        (,name ,@dums))))))))))))
+               (when (and (leaf-has-source-name-p leaf)
+                          ;; FIXME: This SYMBOLP is part of a literal
+                          ;; translation of a test in the old CMU CL
+                          ;; source, and it's not quite clear what
+                          ;; the old source meant. Did it mean "has a
+                          ;; valid name"? Or did it mean "is an
+                          ;; ordinary function name, not a SETF
+                          ;; function"? Either way, the old CMU CL
+                          ;; code probably didn't deal with SETF
+                          ;; functions correctly, and neither does
+                          ;; this new SBCL code, and that should be fixed.
+                          (symbolp (leaf-source-name leaf)))
+                 (let ((dummies (make-gensym-list (length
+                                                   (combination-args call)))))
+                   (transform-call call
+                                   `(lambda ,dummies
+                                      (,(leaf-source-name leaf)
+                                       ,@dummies)))))))))))
   (values))
 \f
 ;;;; known function optimization
@@ -1069,7 +1084,9 @@
 (defun transform-call (node res)
   (declare (type combination node) (list res))
   (with-ir1-environment node
-    (let ((new-fun (ir1-convert-inline-lambda res))
+    (let ((new-fun (ir1-convert-inline-lambda
+                   res
+                   :debug-name "<something inlined in TRANSFORM-CALL>"))
          (ref (continuation-use (combination-fun node))))
       (change-ref-leaf ref new-fun)
       (setf (combination-kind node) :full)
@@ -1079,7 +1096,7 @@
 ;;; Replace a call to a foldable function of constant arguments with
 ;;; the result of evaluating the form. We insert the resulting
 ;;; constant node after the call, stealing the call's continuation. We
-;;; give the call a continuation with no Dest, which should cause it
+;;; give the call a continuation with no DEST, which should cause it
 ;;; and its arguments to go away. If there is an error during the
 ;;; evaluation, we give a warning and leave the call alone, making the
 ;;; call a :ERROR call.
@@ -1090,10 +1107,10 @@
   (declare (type combination call))
   (let* ((args (mapcar #'continuation-value (combination-args call)))
         (ref (continuation-use (combination-fun call)))
-        (fun (leaf-name (ref-leaf ref))))
+        (fun-name (leaf-source-name (ref-leaf ref))))
 
     (multiple-value-bind (values win)
-       (careful-call fun args call "constant folding")
+       (careful-call fun-name args call "constant folding")
       (if (not win)
        (setf (combination-kind call) :error)
        (let ((dummies (make-gensym-list (length args))))