X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=fe648019e1a32f59546ad58e3de843ec6639f9ab;hb=d40a76606c86722b0aef8179155f9f2840739b72;hp=438102b160f780ab65be366065976c0ed6d187a0;hpb=41de6817aef4ccf69b0780969ad79e232c3a798c;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 438102b..fe64801 100644
--- 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)))
@@ -105,7 +105,7 @@
 (defun annotate-1-value-continuation (cont)
   (declare (type continuation cont))
   (let ((info (continuation-info cont)))
-    (assert (eq (ir2-continuation-kind info) :fixed))
+    (aver (eq (ir2-continuation-kind info) :fixed))
     (cond
      ((continuation-delayed-leaf cont)
       (setf (ir2-continuation-kind info) :delayed))
@@ -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)
@@ -276,8 +276,8 @@
   (let ((res (make-ir2-continuation nil)))
     (if (member (continuation-type-check cont) '(:deleted nil))
 	(setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
-	(let* ((proven (mapcar #'(lambda (x)
-				   (make-normal-tn (primitive-type x)))
+	(let* ((proven (mapcar (lambda (x)
+				 (make-normal-tn (primitive-type x)))
 			       (values-types
 				(continuation-proven-type cont))))
 	       (num-proven (length proven))
@@ -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)
@@ -419,12 +419,12 @@
 (defun set-tail-local-call-successor (call)
   (let ((caller (node-home-lambda call))
 	(callee (combination-lambda call)))
-    (assert (eq (lambda-tail-set caller)
-		(lambda-tail-set (lambda-home callee))))
+    (aver (eq (lambda-tail-set caller)
+	      (lambda-tail-set (lambda-home callee))))
     (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.
@@ -721,7 +721,7 @@
   (funcall frob "This shouldn't happen!  Bug?")
   (multiple-value-bind (win why)
       (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
-    (assert (not win))
+    (aver (not win))
     (ecase why
       (:guard
        (funcall frob "template guard failed"))
@@ -730,18 +730,18 @@
       (:arg-types
        (funcall frob "argument types invalid")
        (funcall frob "argument primitive types:~%  ~S"
-		(mapcar #'(lambda (x)
-			    (primitive-type-name
-			     (continuation-ptype x)))
+		(mapcar (lambda (x)
+			  (primitive-type-name
+			   (continuation-ptype x)))
 			(combination-args call)))
        (funcall frob "argument type assertions:~%  ~S"
-		(mapcar #'(lambda (x)
-			    (if (atom x)
-				x
-				(ecase (car x)
-				  (:or `(:or .,(mapcar #'primitive-type-name
-						       (cdr x))))
-				  (:constant `(:constant ,(third x))))))
+		(mapcar (lambda (x)
+			  (if (atom x)
+			      x
+			      (ecase (car x)
+				(:or `(:or .,(mapcar #'primitive-type-name
+						     (cdr x))))
+				(:constant `(:constant ,(third x))))))
 			(template-arg-types template))))
       (:conditional
        (funcall frob "conditional in a non-conditional context"))
@@ -793,44 +793,45 @@
 			 (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)
       (collect ((messages)
 		(count 0 +))
-	(flet ((frob (string &rest stuff)
+	(flet ((lose1 (string &rest stuff)
 		 (messages string)
 		 (messages stuff)))
 	  (dolist (loser (losers))
 	    (when (and *efficiency-note-limit*
 		       (>= (count) *efficiency-note-limit*))
-	      (frob "etc.")
+	      (lose1 "etc.")
 	      (return))
 	    (let* ((type (template-type loser))
 		   (valid (valid-function-use call type))
 		   (strict-valid (valid-function-use call type
 						     :strict-result t)))
-	      (frob "unable to do ~A (cost ~D) because:"
-		    (or (template-note loser) (template-name loser))
-		    (template-cost loser))
+	      (lose1 "unable to do ~A (cost ~W) because:"
+		     (or (template-note loser) (template-name loser))
+		     (template-cost loser))
 	      (cond
 	       ((and valid strict-valid)
-		(strange-template-failure loser call ltn-policy #'frob))
+		(strange-template-failure loser call ltn-policy #'lose1))
 	       ((not valid)
-		(assert (not (valid-function-use call type
-						 :error-function #'frob
-						 :warning-function #'frob))))
+		(aver (not (valid-function-use call type
+					       :lossage-fun #'lose1
+					       :unwinnage-fun #'lose1))))
 	       (t
-		(assert (ltn-policy-safe-p ltn-policy))
-		(frob "can't trust output type assertion under safe policy")))
+		(aver (ltn-policy-safe-p ltn-policy))
+		(lose1 "can't trust output type assertion under safe policy")))
 	      (count 1))))
 
 	(let ((*compiler-error-context* call))
 	  (compiler-note "~{~?~^~&~6T~}"
 			 (if template
-			     `("forced to do ~A (cost ~D)"
+			     `("forced to do ~A (cost ~W)"
 			       (,(or (template-note template)
 				     (template-name template))
 				,(template-cost template))
@@ -894,22 +895,21 @@
       ;; 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-lambda (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"
-			      (lexenv-policy (node-lexenv call))
-			      (mapcar (lambda (arg)
-					(type-specifier (continuation-type
-							 arg)))
-				      args))))
+	    (compiler-warn "~@<recursion in known function definition~2I ~
+                            ~_policy=~S ~_arg types=~S~:>"
+			   (lexenv-policy (node-lexenv call))
+			   (mapcar (lambda (arg)
+				     (type-specifier (continuation-type arg)))
+				   args))))
 	(ltn-default-call call ltn-policy)
 	(return-from ltn-analyze-known-call (values)))
       (setf (basic-combination-info call) template)
@@ -964,7 +964,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,7 +976,11 @@
   (declare (type component component))
   (let ((2comp (component-info component)))
     (do-blocks (block component)
-      (assert (not (block-info block)))
+      ;; 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)
 	(ltn-analyze-block block)
@@ -992,6 +996,6 @@
 (defun ltn-analyze-belated-block (block)
   (declare (type cblock block))
   (ltn-analyze-block block)
-  (assert (not (ir2-block-popped (block-info block))))
+  (aver (not (ir2-block-popped (block-info block))))
   (values))