X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=7e9171b7c5fd3bfddc93ee018be1675fa60d22ba;hb=b387f6ae447b55e203f47fc40af4a36e756fe345;hp=ba40a142f093a4e444b1c8207bbcb6f64e810252;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index ba40a14..7e9171b 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)))
@@ -140,7 +140,7 @@
 ;;; Unlike for an argument, we only clear the type check flag when the
 ;;; LTN-POLICY is unsafe, since the check for a valid function
 ;;; object must be done before the call.
-(defun annotate-function-continuation (cont ltn-policy &optional (delay t))
+(defun annotate-fun-continuation (cont ltn-policy &optional (delay t))
   (declare (type continuation cont) (type ltn-policy ltn-policy))
   (unless (ltn-policy-safe-p ltn-policy)
     (flush-type-check cont))
@@ -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)
@@ -184,20 +184,19 @@
 ;;; deliver values normally. We still annotate the function continuation,
 ;;; since IR2tran might decide to call after all.
 ;;;
-;;; If not funny, we always flush arg type checks, but do it after
-;;; annotation when the LTN-POLICY is safe, since we don't want to
-;;; choose the TNs according to a type assertions that may not hold.
+;;; If not funny, we flush arg type checks, when LTN-POLICY is not
+;;; safe.
 ;;;
 ;;; Note that args may already be annotated because template selection can
 ;;; bail out to here.
 (defun ltn-default-call (call ltn-policy)
   (declare (type combination call) (type ltn-policy ltn-policy))
   (let ((kind (basic-combination-kind call)))
-    (annotate-function-continuation (basic-combination-fun call) ltn-policy)
+    (annotate-fun-continuation (basic-combination-fun call) ltn-policy)
 
     (cond
-     ((and (function-info-p kind)
-	   (function-info-ir2-convert kind))
+     ((and (fun-info-p kind)
+	   (fun-info-ir2-convert kind))
       (setf (basic-combination-info call) :funny)
       (setf (node-tail-p call) nil)
       (dolist (arg (basic-combination-args call))
@@ -216,8 +215,7 @@
 		  (make-ir2-continuation
 		   (primitive-type
 		    (continuation-type arg)))))
-	  (annotate-1-value-continuation arg)
-	  (when safe-p (flush-type-check arg))))
+	  (annotate-1-value-continuation arg)))
       (when (eq kind :error)
 	(setf (basic-combination-kind call) :full))
       (setf (basic-combination-info call) :full)
@@ -270,14 +268,14 @@
 ;;; we annotate for the number of values indicated by TYPES, but only
 ;;; use proven type information.
 (defun annotate-fixed-values-continuation (cont ltn-policy types)
-  (declare (continuation cont) (ltn-policy ltn-policy) (list types))
+  (declare (type continuation cont) (type ltn-policy ltn-policy) (list types))
   (unless (ltn-policy-safe-p ltn-policy)
     (flush-type-check cont))
   (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 +298,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 +314,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,16 +380,16 @@
   (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)
 	   (setf (node-tail-p call) nil))
 	  (t
 	   (setf (basic-combination-info call) :full)
-	   (annotate-function-continuation (basic-combination-fun call)
-					   ltn-policy
-					   nil)
+	   (annotate-fun-continuation (basic-combination-fun call)
+				      ltn-policy
+				      nil)
 	   (dolist (arg (reverse args))
 	     (annotate-unknown-values-continuation arg ltn-policy))
 	   (flush-full-call-tail-transfer call))))
@@ -414,8 +412,7 @@
 ;;; Make sure that a tail local call is linked directly to the bind
 ;;; node. Usually it will be, but calls from XEPs and calls that might have
 ;;; needed a cleanup after them won't have been swung over yet, since we
-;;; weren't sure they would really be TR until now. Also called by byte
-;;; compiler.
+;;; weren't sure they would really be TR until now.
 (defun set-tail-local-call-successor (call)
   (let ((caller (node-home-lambda call))
 	(callee (combination-lambda call)))
@@ -424,7 +421,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.
@@ -476,26 +473,6 @@
   ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (setf (basic-combination-info node) :funny)
   (setf (node-tail-p node) nil))
-
-;;; Both of these functions need special LTN-annotate methods, since
-;;; we only want to clear the TYPE-CHECK in unsafe policies. If we
-;;; allowed the call to be annotated as a full call, then no type
-;;; checking would be done.
-;;;
-;;; We also need a special LTN annotate method for %SLOT-SETTER so
-;;; that the function is ignored. This is because the reference to a
-;;; SETF function can't be delayed, so IR2 conversion would have
-;;; already emitted a call to FDEFINITION by the time the IR2 convert
-;;; method got control.
-(defoptimizer (%slot-accessor ltn-annotate) ((struct) node ltn-policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation struct ltn-policy))
-(defoptimizer (%slot-setter ltn-annotate) ((struct value) node ltn-policy)
-  (setf (basic-combination-info node) :funny)
-  (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation struct ltn-policy)
-  (annotate-ordinary-continuation value ltn-policy))
 
 ;;;; known call annotation
 
@@ -679,7 +656,7 @@
   (declare (type combination call)
 	   (type ltn-policy ltn-policy))
   (let ((safe-p (ltn-policy-safe-p ltn-policy))
-	(current (function-info-templates (basic-combination-kind call)))
+	(current (fun-info-templates (basic-combination-kind call)))
 	(fallback nil)
 	(rejected nil))
     (loop
@@ -730,18 +707,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"))
@@ -783,7 +760,7 @@
 			(or template
 			    (template-or-lose 'call-named)))
 		       *efficiency-note-cost-threshold*)))
-      (dolist (try (function-info-templates (basic-combination-kind call)))
+      (dolist (try (fun-info-templates (basic-combination-kind call)))
 	(when (> (template-cost try) max-cost) (return)) ; FIXME: UNLESS'd be cleaner.
 	(let ((guard (template-guard try)))
 	  (when (and (or (not guard) (funcall guard))
@@ -791,46 +768,47 @@
 			 (ltn-policy-safe-p (template-ltn-policy try)))
 		     (or verbose-p
 			 (and (template-note try)
-			      (valid-function-use
+			      (valid-fun-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))
+		   (valid (valid-fun-use call type))
+		   (strict-valid (valid-fun-use call type
+						:strict-result t)))
+	      (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)
-		(aver (not (valid-function-use call type
-					       :error-function #'frob
-					       :warning-function #'frob))))
+		(aver (not (valid-fun-use call type
+					  :lossage-fun #'lose1
+					  :unwinnage-fun #'lose1))))
 	       (t
 		(aver (ltn-policy-safe-p ltn-policy))
-		(frob "can't trust output type assertion under safe 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))
@@ -844,7 +822,7 @@
 ;;; unsafe, then we never do any checks. If our policy is safe, and
 ;;; we are using a safe template, then we can also flush arg and
 ;;; result type checks. Result type checks are only flushed when the
-;;; continuation as a single use. Result type checks are not flush if
+;;; continuation has a single use. Result type checks are not flush if
 ;;; the policy is safe because the selection of template for results
 ;;; readers assumes the type check is done (uses the derived type
 ;;; which is the intersection of the proven and asserted types).
@@ -870,7 +848,7 @@
 (defun ltn-analyze-known-call (call ltn-policy)
   (declare (type combination call)
 	   (type ltn-policy ltn-policy))
-  (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
+  (let ((method (fun-info-ltn-annotate (basic-combination-kind call)))
 	(args (basic-combination-args call)))
     (when method
       (funcall method call ltn-policy)
@@ -894,22 +872,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 (fun-info-ir2-convert info)
+				(ir1-attributep (fun-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 +941,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 +953,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)