0.pre7.86.flaky7.2:

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

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index ba40a14..ed1bff3 100644 (file)
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -78,7 +78,7 @@
 ;;; values cannot, since we must preserve EQLness.
 (defun legal-immediate-constant-p (leaf)
   (declare (type constant leaf))
-  (or (null (leaf-name leaf))
+  (or (not (leaf-has-source-name-p leaf))
       (typecase (constant-value leaf)
        ((or number character) t)
        (symbol (symbol-package (constant-value leaf)))
@@ -152,7 +152,7 @@
                         (continuation-proven-type cont)))))
         (info (make-ir2-continuation ptype)))
     (setf (continuation-info cont) info)
-    (let ((name (continuation-function-name cont t)))
+    (let ((name (continuation-fun-name cont t)))
       (if (and delay name)
          (setf (ir2-continuation-kind info) :delayed)
          (setf (ir2-continuation-locs info)
@@ -300,9 +300,9 @@
 ;;; Annotate the result continuation for a function. We use the
 ;;; RETURN-INFO computed by GTN to determine how to represent the
 ;;; return values within the function:
-;;; ---- If the tail-set has a fixed values count, then use that
+;;;  * If the TAIL-SET has a fixed values count, then use that
 ;;;    many values.
-;;; ---- If the actual uses of the result continuation in this function
+;;;  * If the actual uses of the result continuation in this function
 ;;;    have a fixed number of values (after intersection with the
 ;;;    assertion), then use that number. We throw out TAIL-P :FULL
 ;;;    and :LOCAL calls, since we know they will truly end up as TR
@@ -316,7 +316,7 @@
 ;;;    the result continuation before it reaches the RETURN. In
 ;;;    perverse code, we may annotate for unknown values when we
 ;;;    didn't have to.
-;;; ---- Otherwise, we must annotate the continuation for unknown values.
+;;; * Otherwise, we must annotate the continuation for unknown values.
 (defun ltn-analyze-return (node ltn-policy)
   (declare (type creturn node) (type ltn-policy ltn-policy))
   (let* ((cont (return-result node))
@@ -382,7 +382,7 @@
   (declare (type mv-combination call) (type ltn-policy ltn-policy))
   (let ((fun (basic-combination-fun call))
        (args (basic-combination-args call)))
-    (cond ((eq (continuation-function-name fun) '%throw)
+    (cond ((eq (continuation-fun-name fun) '%throw)
           (setf (basic-combination-info call) :funny)
           (annotate-ordinary-continuation (first args) ltn-policy)
           (annotate-unknown-values-continuation (second args) ltn-policy)
@@ -424,7 +424,7 @@
     (node-ends-block call)
     (let ((block (node-block call)))
       (unlink-blocks block (first (block-succ block)))
-      (link-blocks block (node-block (lambda-bind callee)))))
+      (link-blocks block (lambda-block callee))))
   (values))
 
 ;;; Annotate the value continuation.
@@ -793,8 +793,9 @@
                         (and (template-note try)
                              (valid-function-use
                               call (template-type try)
-                              :argument-test #'types-intersect
-                              :result-test #'values-types-intersect))))
+                              :argument-test #'types-equal-or-intersect
+                              :result-test
+                              #'values-types-equal-or-intersect))))
            (losers try)))))
 
     (when (losers)
@@ -894,14 +895,14 @@
       ;; to implement an out-of-line version in terms of inline
       ;; transforms or VOPs or whatever.
       (unless template
-       (when (and (eq (continuation-function-name (combination-fun call))
-                      (leaf-name
-                       (environment-function
-                        (node-environment call))))
-                  (let ((info (basic-combination-kind call)))
-                    (not (or (function-info-ir2-convert info)
-                             (ir1-attributep (function-info-attributes info)
-                                             recursive)))))
+       (when (let ((funleaf (physenv-function (node-physenv call))))
+               (and (leaf-has-source-name-p funleaf)
+                    (eq (continuation-fun-name (combination-fun call))
+                        (leaf-source-name funleaf))
+                    (let ((info (basic-combination-kind call)))
+                      (not (or (function-info-ir2-convert info)
+                               (ir1-attributep (function-info-attributes info)
+                                               recursive))))))
          (let ((*compiler-error-context* call))
            (compiler-warning "~@<recursion in known function definition~2I ~
                                ~_policy=~S ~_arg types=~S~:>"
@@ -964,7 +965,7 @@
 ;;; Loop over the blocks in COMPONENT, doing stuff to nodes that
 ;;; receive values. In addition to the stuff done by FROB, we also see
 ;;; whether there are any unknown values receivers, making notations
-;;; in the components Generators and Receivers as appropriate.
+;;; in the components' GENERATORS and RECEIVERS as appropriate.
 ;;;
 ;;; If any unknown-values continations are received by this block (as
 ;;; indicated by IR2-BLOCK-POPPED), then we add the block to the
@@ -976,6 +977,10 @@
   (declare (type component component))
   (let ((2comp (component-info component)))
     (do-blocks (block component)
+      ;; This assertion seems to protect us from compiling a component
+      ;; twice. As noted above, "this is where we allocate IR2-BLOCKS
+      ;; because it is the first place we need them", so if one is
+      ;; already allocated here, something is wrong. -- WHN 2001-09-14
       (aver (not (block-info block)))
       (let ((2block (make-ir2-block block)))
        (setf (block-info block) 2block)