X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=3929851c8df1118065c98a61910a040dbf0fcd0a;hb=65f551e30f6f52855fdb7ff28e0cfff2f17c3e48;hp=a728e2e0623604ca1b1ee7998e8cc75b0623e9e6;hpb=1bfc464c657a8f4ad24ef612f76a38d8f6f1bbad;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index a728e2e..3929851 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -58,15 +58,6 @@
     ((:safe :fast-safe) t)
     ((:small :fast) nil)))
 
-;;; Called when an unsafe policy indicates that no type check should
-;;; be done on CONT. We delete the type check unless it is :ERROR
-;;; (indicating a compile-time type error.)
-(defun flush-type-check (cont)
-  (declare (type continuation cont))
-  (when (member (continuation-type-check cont) '(t :no-check))
-    (setf (continuation-%type-check cont) :deleted))
-  (values))
-
 ;;; an annotated continuation's primitive-type
 #!-sb-fluid (declaim (inline continuation-ptype))
 (defun continuation-ptype (cont)
@@ -99,9 +90,7 @@
 ;;; Annotate a normal single-value continuation. If its only use is a
 ;;; ref that we are allowed to delay the evaluation of, then we mark
 ;;; the continuation for delayed evaluation, otherwise we assign a TN
-;;; to hold the continuation's value. If the continuation has a type
-;;; check, we make the TN according to the proven type to ensure that
-;;; the possibly erroneous value can be represented.
+;;; to hold the continuation's value.
 (defun annotate-1-value-continuation (cont)
   (declare (type continuation cont))
   (let ((info (continuation-info cont)))
@@ -109,54 +98,35 @@
     (cond
      ((continuation-delayed-leaf cont)
       (setf (ir2-continuation-kind info) :delayed))
-     ((member (continuation-type-check cont) '(:deleted nil))
-      (setf (ir2-continuation-locs info)
-	    (list (make-normal-tn (ir2-continuation-primitive-type info)))))
-     (t
-      (setf (ir2-continuation-locs info)
-	    (list (make-normal-tn
-		   (primitive-type
-		    (single-value-type (continuation-proven-type cont)))))))))
+     (t (setf (ir2-continuation-locs info)
+              (list (make-normal-tn (ir2-continuation-primitive-type info)))))))
+  (ltn-annotate-casts cont)
   (values))
 
 ;;; Make an IR2-CONTINUATION corresponding to the continuation type
-;;; and then do ANNOTATE-1-VALUE-CONTINUATION. If POLICY-KEYWORD isn't
-;;; a safe policy keyword, then we clear the TYPE-CHECK flag.
-(defun annotate-ordinary-continuation (cont ltn-policy)
-  (declare (type continuation cont)
-	   (type ltn-policy ltn-policy))
+;;; and then do ANNOTATE-1-VALUE-CONTINUATION.
+(defun annotate-ordinary-continuation (cont)
+  (declare (type continuation cont))
   (let ((info (make-ir2-continuation
 	       (primitive-type (continuation-type cont)))))
     (setf (continuation-info cont) info)
-    (unless (ltn-policy-safe-p ltn-policy)
-      (flush-type-check cont))
     (annotate-1-value-continuation cont))
   (values))
 
 ;;; Annotate the function continuation for a full call. If the only
 ;;; reference is to a global function and DELAY is true, then we delay
 ;;; the reference, otherwise we annotate for a single value.
-;;;
-;;; 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))
-  (declare (type continuation cont) (type ltn-policy ltn-policy))
-  (unless (ltn-policy-safe-p ltn-policy)
-    (flush-type-check cont))
-  (let* ((ptype (primitive-type (continuation-type cont)))
-	 (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
-		       ptype
-		       (primitive-type
-			(single-value-type
-			 (continuation-proven-type cont)))))
-	 (info (make-ir2-continuation ptype)))
+(defun annotate-fun-continuation (cont &optional (delay t))
+  (declare (type continuation cont))
+  (let* ((tn-ptype (primitive-type (continuation-type cont)))
+	 (info (make-ir2-continuation tn-ptype)))
     (setf (continuation-info cont) info)
     (let ((name (continuation-fun-name cont t)))
       (if (and delay name)
 	  (setf (ir2-continuation-kind info) :delayed)
 	  (setf (ir2-continuation-locs info)
 		(list (make-normal-tn tn-ptype))))))
+  (ltn-annotate-casts cont)
   (values))
 
 ;;; If TAIL-P is true, then we check to see whether the call can really
@@ -178,58 +148,47 @@
 	     (setf (node-tail-p call) nil)))))
   (values))
 
-;;; We set the kind to :FULL or :FUNNY, depending on whether there is an
-;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion
-;;; and type check normally, since the IR2 convert method is going to want to
-;;; 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.
+;;; We set the kind to :FULL or :FUNNY, depending on whether there is
+;;; an IR2-CONVERT method. If a funny function, then we inhibit tail
+;;; recursion normally, since the IR2 convert method is going to want
+;;; to deliver values normally. We still annotate the function
+;;; continuation, since IR2tran might decide to call after all.
 ;;;
-;;; 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))
+;;; Note that args may already be annotated because template selection
+;;; can bail out to here.
+(defun ltn-default-call (call)
+  (declare (type combination call))
   (let ((kind (basic-combination-kind call)))
-    (annotate-function-continuation (basic-combination-fun call) ltn-policy)
+    (annotate-fun-continuation (basic-combination-fun call))
 
     (cond
-     ((and (function-info-p kind)
-	   (function-info-ir2-convert kind))
-      (setf (basic-combination-info call) :funny)
-      (setf (node-tail-p call) nil)
-      (dolist (arg (basic-combination-args call))
-	(unless (continuation-info arg)
-	  (setf (continuation-info arg)
-		(make-ir2-continuation
-		 (primitive-type
-		  (continuation-type arg)))))
-	(annotate-1-value-continuation arg)))
-     (t
-      (let ((safe-p (ltn-policy-safe-p ltn-policy)))
-	(dolist (arg (basic-combination-args call))
-	  (unless safe-p (flush-type-check arg))
-	  (unless (continuation-info arg)
-	    (setf (continuation-info arg)
-		  (make-ir2-continuation
-		   (primitive-type
-		    (continuation-type arg)))))
-	  (annotate-1-value-continuation arg)
-	  (when safe-p (flush-type-check arg))))
-      (when (eq kind :error)
-	(setf (basic-combination-kind call) :full))
-      (setf (basic-combination-info call) :full)
-      (flush-full-call-tail-transfer call))))
+      ((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))
+         (unless (continuation-info arg)
+           (setf (continuation-info arg)
+                 (make-ir2-continuation
+                  (primitive-type
+                   (continuation-type arg)))))
+         (annotate-1-value-continuation arg)))
+      (t
+       (dolist (arg (basic-combination-args call))
+         (unless (continuation-info arg)
+           (setf (continuation-info arg)
+                 (make-ir2-continuation
+                  (primitive-type
+                   (continuation-type arg)))))
+         (annotate-1-value-continuation arg))
+       (when (eq kind :error)
+         (setf (basic-combination-kind call) :full))
+       (setf (basic-combination-info call) :full)
+       (flush-full-call-tail-transfer call))))
 
   (values))
 
 ;;; Annotate a continuation for unknown multiple values:
-;;; -- Delete any type check, regardless of LTN-POLICY, since IR2
-;;;    conversion isn't prepared to check unknown-values continuations.
-;;;    If we delete a type check when the policy is safe, then we emit
-;;;    a warning.
 ;;; -- Add the continuation to the IR2-BLOCK-POPPED if it is used
 ;;;    across a block boundary.
 ;;; -- Assign an :UNKNOWN IR2-CONTINUATION.
@@ -238,18 +197,19 @@
 ;;; of CONT's DEST, and called in the order that the continuations are
 ;;; received. Otherwise the IR2-BLOCK-POPPED and
 ;;; IR2-COMPONENT-VALUES-FOO would get all messed up.
-(defun annotate-unknown-values-continuation (cont ltn-policy)
-  (declare (type continuation cont) (type ltn-policy ltn-policy))
-  (when (eq (continuation-type-check cont) t)
-    (let* ((dest (continuation-dest cont))
-	   (*compiler-error-context* dest))
-      (when (and (ltn-policy-safe-p ltn-policy)
-		 (policy dest (>= safety inhibit-warnings)))
-	(compiler-note "compiler limitation: ~
-                        unable to check type assertion in ~
-			unknown-values context:~%  ~S"
-		       (continuation-asserted-type cont))))
-    (setf (continuation-%type-check cont) :deleted))
+(defun annotate-unknown-values-continuation (cont)
+  (declare (type continuation cont))
+
+  (let ((2cont (make-ir2-continuation nil)))
+    (setf (ir2-continuation-kind 2cont) :unknown)
+    (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
+    (setf (continuation-info cont) 2cont))
+
+  ;; The CAST chain with corresponding continuations constitute the
+  ;; same "principal continuation", so we must preserve only inner
+  ;; annotation order and the order of the whole p.c. with other
+  ;; continiations. -- APD, 2002-02-27
+  (ltn-annotate-casts cont)
 
   (let* ((block (node-block (continuation-dest cont)))
 	 (use (continuation-use cont))
@@ -258,41 +218,16 @@
       (setf (ir2-block-popped 2block)
 	    (nconc (ir2-block-popped 2block) (list cont)))))
 
-  (let ((2cont (make-ir2-continuation nil)))
-    (setf (ir2-continuation-kind 2cont) :unknown)
-    (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
-    (setf (continuation-info cont) 2cont))
-
   (values))
 
 ;;; Annotate CONT for a fixed, but arbitrary number of values, of the
-;;; specified primitive TYPES. If the continuation has a type check,
-;;; 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))
-  (unless (ltn-policy-safe-p ltn-policy)
-    (flush-type-check cont))
+;;; specified primitive TYPES.
+(defun annotate-fixed-values-continuation (cont types)
+  (declare (type continuation cont) (list types))
   (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)))
-			       (values-types
-				(continuation-proven-type cont))))
-	       (num-proven (length proven))
-	       (num-types (length types)))
-	  (setf (ir2-continuation-locs res)
-		(cond
-		 ((< num-proven num-types)
-		  (append proven
-			  (make-n-tns (- num-types num-proven)
-				      *backend-t-primitive-type*)))
-		 ((> num-proven num-types)
-		  (subseq proven 0 num-types))
-		 (t
-		  proven)))))
+    (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
     (setf (continuation-info cont) res))
+  (ltn-annotate-casts cont)
   (values))
 
 ;;;; node-specific analysis functions
@@ -317,8 +252,8 @@
 ;;;    perverse code, we may annotate for unknown values when we
 ;;;    didn't have to.
 ;;; * 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))
+(defun ltn-analyze-return (node)
+  (declare (type creturn node))
   (let* ((cont (return-result node))
 	 (fun (return-lambda node))
 	 (returns (tail-set-info (lambda-tail-set fun)))
@@ -331,16 +266,16 @@
 			 (member (basic-combination-info use) '(:local :full)))
 	      (res (node-derived-type use))))
 
-	  (let ((int (values-type-intersection
-		      (res)
-		      (continuation-asserted-type cont))))
+	  (let ((int (res)))
 	    (multiple-value-bind (types kind)
-		(values-types (if (eq int *empty-type*) (res) int))
+                (if (eq int *empty-type*)
+                    (values nil :unknown)
+                    (values-types int))
 	      (if (eq kind :unknown)
-		  (annotate-unknown-values-continuation cont ltn-policy)
+		  (annotate-unknown-values-continuation cont)
 		  (annotate-fixed-values-continuation
-		   cont ltn-policy (mapcar #'primitive-type types))))))
-	(annotate-fixed-values-continuation cont ltn-policy types)))
+		   cont (mapcar #'primitive-type types))))))
+	(annotate-fixed-values-continuation cont types)))
 
   (values))
 
@@ -348,14 +283,12 @@
 ;;; continuation. We look at the called lambda to determine number and
 ;;; type of return values desired. It is assumed that only a function
 ;;; that LOOKS-LIKE-AN-MV-BIND will be converted to a local call.
-(defun ltn-analyze-mv-bind (call ltn-policy)
-  (declare (type mv-combination call)
-	   (type ltn-policy ltn-policy))
+(defun ltn-analyze-mv-bind (call)
+  (declare (type mv-combination call))
   (setf (basic-combination-kind call) :local)
   (setf (node-tail-p call) nil)
   (annotate-fixed-values-continuation
    (first (basic-combination-args call))
-   ltn-policy
    (mapcar (lambda (var)
 	     (primitive-type (basic-var-type var)))
 	   (lambda-vars
@@ -378,35 +311,33 @@
 ;;; in IR1 as an MV call to the %THROW funny function. We annotate the
 ;;; tag continuation for a single value and the values continuation
 ;;; for unknown values.
-(defun ltn-analyze-mv-call (call ltn-policy)
-  (declare (type mv-combination call) (type ltn-policy ltn-policy))
+(defun ltn-analyze-mv-call (call)
+  (declare (type mv-combination call))
   (let ((fun (basic-combination-fun call))
 	(args (basic-combination-args call)))
     (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)
+	   (annotate-ordinary-continuation (first args))
+	   (annotate-unknown-values-continuation (second args))
 	   (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)
+				      nil)
 	   (dolist (arg (reverse args))
-	     (annotate-unknown-values-continuation arg ltn-policy))
+	     (annotate-unknown-values-continuation arg))
 	   (flush-full-call-tail-transfer call))))
 
   (values))
 
 ;;; Annotate the arguments as ordinary single-value continuations. And
 ;;; check the successor.
-(defun ltn-analyze-local-call (call ltn-policy)
-  (declare (type combination call)
-	   (type ltn-policy ltn-policy))
+(defun ltn-analyze-local-call (call)
+  (declare (type combination call))
   (setf (basic-combination-info call) :local)
   (dolist (arg (basic-combination-args call))
     (when arg
-      (annotate-ordinary-continuation arg ltn-policy)))
+      (annotate-ordinary-continuation arg)))
   (when (node-tail-p call)
     (set-tail-local-call-successor call))
   (values))
@@ -414,8 +345,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)))
@@ -428,10 +358,10 @@
   (values))
 
 ;;; Annotate the value continuation.
-(defun ltn-analyze-set (node ltn-policy)
-  (declare (type cset node) (type ltn-policy ltn-policy))
+(defun ltn-analyze-set (node)
+  (declare (type cset node))
   (setf (node-tail-p node) nil)
-  (annotate-ordinary-continuation (set-value node) ltn-policy)
+  (annotate-ordinary-continuation (set-value node))
   (values))
 
 ;;; If the only use of the TEST continuation is a combination
@@ -441,8 +371,8 @@
 ;;; a conditional template if the call immediately precedes the IF
 ;;; node in the same block, we know that any predicate will already be
 ;;; annotated.
-(defun ltn-analyze-if (node ltn-policy)
-  (declare (type cif node) (type ltn-policy ltn-policy))
+(defun ltn-analyze-if (node)
+  (declare (type cif node))
   (setf (node-tail-p node) nil)
   (let* ((test (if-test node))
 	 (use (continuation-use test)))
@@ -450,17 +380,17 @@
 		 (let ((info (basic-combination-info use)))
 		   (and (template-p info)
 			(eq (template-result-types info) :conditional))))
-      (annotate-ordinary-continuation test ltn-policy)))
+      (annotate-ordinary-continuation test)))
   (values))
 
 ;;; If there is a value continuation, then annotate it for unknown
 ;;; values. In this case, the exit is non-local, since all other exits
 ;;; are deleted or degenerate by this point.
-(defun ltn-analyze-exit (node ltn-policy)
+(defun ltn-analyze-exit (node)
   (setf (node-tail-p node) nil)
   (let ((value (exit-value node)))
     (when value
-      (annotate-unknown-values-continuation value ltn-policy)))
+      (annotate-unknown-values-continuation value)))
   (values))
 
 ;;; We need a special method for %UNWIND-PROTECT that ignores the
@@ -476,26 +406,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
 
@@ -548,10 +458,6 @@
       (when (null args) (return nil))
       (let ((arg (car args))
 	    (type (car types)))
-	(when (and (eq (continuation-type-check arg) :no-check)
-		   safe-p
-		   (not (eq (template-ltn-policy template) :safe)))
-	  (return nil))
 	(unless (operand-restriction-ok type (continuation-ptype arg)
 					:cont arg)
 	  (return nil))))))
@@ -609,7 +515,6 @@
   (declare (type template template) (type combination call))
   (let* ((guard (template-guard template))
 	 (cont (node-cont call))
-	 (atype (continuation-asserted-type cont))
 	 (dtype (node-derived-type call)))
     (cond ((and guard (not (funcall guard)))
 	   (values nil :guard))
@@ -624,13 +529,7 @@
 		      (immediately-used-p (if-test dest) call))
 		 (values t nil)
 		 (values nil :conditional))))
-	  ((template-results-ok
-	    template
-	    (if (and (or (eq (template-ltn-policy template) :safe)
-			 (not safe-p))
-		     (continuation-type-check cont))
-		(values-type-intersection dtype atype)
-		dtype))
+	  ((template-results-ok template dtype)
 	   (values t nil))
 	  (t
 	   (values nil :result-types)))))
@@ -679,7 +578,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 +629,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 +682,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,7 +690,7 @@
 			 (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-equal-or-intersect
 			       :result-test
@@ -801,31 +700,30 @@
     (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 ~W) because:"
-		    (or (template-note loser) (template-name loser))
-		    (template-cost loser))
+		   (valid (valid-fun-use call type))
+		   (strict-valid (valid-fun-use call type)))
+	      (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))
@@ -841,37 +739,14 @@
 			       . ,(messages))))))))
   (values))
 
-;;; Flush type checks according to policy. If the policy is
-;;; 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
-;;; 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).
-(defun flush-type-checks-according-to-ltn-policy (call ltn-policy template)
-  (declare (type combination call) (type ltn-policy ltn-policy)
-	   (type template template))
-  (let ((safe-op (eq (template-ltn-policy template) :safe)))
-    (when (or (not (ltn-policy-safe-p ltn-policy)) safe-op)
-      (dolist (arg (basic-combination-args call))
-	(flush-type-check arg)))
-    (when safe-op
-      (let ((cont (node-cont call)))
-	(when (and (eq (continuation-use cont) call)
-		   (not (ltn-policy-safe-p ltn-policy)))
-	  (flush-type-check cont)))))
-
-  (values))
-
 ;;; If a function has a special-case annotation method use that,
 ;;; otherwise annotate the argument continuations and try to find a
 ;;; template corresponding to the type signature. If there is none,
 ;;; convert a full call.
-(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)))
+(defun ltn-analyze-known-call (call)
+  (declare (type combination call))
+  (let ((ltn-policy (node-ltn-policy call))
+        (method (fun-info-ltn-annotate (basic-combination-kind call)))
 	(args (basic-combination-args call)))
     (when method
       (funcall method call ltn-policy)
@@ -900,28 +775,67 @@
 		     (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)
+		       (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))))
-	(ltn-default-call call ltn-policy)
+	    (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)
 	(return-from ltn-analyze-known-call (values)))
       (setf (basic-combination-info call) template)
       (setf (node-tail-p call) nil)
 
-      (flush-type-checks-according-to-ltn-policy call ltn-policy template)
-
       (dolist (arg args)
 	(annotate-1-value-continuation arg))))
 
   (values))
+
+;;; CASTs are merely continuation annotations than nodes. So we wait
+;;; until value consumer deside how values should be passed, and after
+;;; that we propagate this decision backwards through CAST chain. The
+;;; exception is a dangling CAST with a type check, which we process
+;;; immediately.
+(defun ltn-analyze-cast (cast)
+  (declare (type cast cast))
+  (setf (node-tail-p cast) nil)
+  (when (and (cast-type-check cast)
+             (not (continuation-dest (node-cont cast))))
+    ;; FIXME
+    (bug "IR2 type checking of unused values in not implemented.")
+    )
+  (values))
+
+(defun ltn-annotate-casts (cont)
+  (declare (type continuation cont))
+  (do-uses (node cont)
+    (when (cast-p node)
+      (ltn-annotate-cast node))))
+
+(defun ltn-annotate-cast (cast)
+  (declare (type cast))
+  (let ((2cont (continuation-info (node-cont cast)))
+        (value (cast-value cast)))
+    (aver 2cont)
+    ;; XXX
+    (ecase (ir2-continuation-kind 2cont)
+      (:unknown
+       (annotate-unknown-values-continuation value))
+      (:fixed
+       (let* ((count (length (ir2-continuation-locs 2cont)))
+              (ctype (continuation-derived-type value)))
+         (multiple-value-bind (types rest)
+             (values-type-types ctype (specifier-type 'null))
+           (annotate-fixed-values-continuation
+            value
+            (mapcar #'primitive-type
+                    (adjust-list types count rest))))))))
+  (values))
+
 
 ;;;; interfaces
 
@@ -934,31 +848,33 @@
 (defun ltn-analyze-block (block)
   (do* ((node (continuation-next (block-start block))
 	      (continuation-next cont))
-	(cont (node-cont node) (node-cont node))
-	(ltn-policy (node-ltn-policy node) (node-ltn-policy node)))
+	(cont (node-cont node) (node-cont node)))
       (nil)
+    (let ((dest (continuation-dest cont)))
+      (when (and (cast-p dest)
+                 (not (cast-type-check dest))
+                 (immediately-used-p cont node))
+        (derive-node-type node (cast-asserted-type dest))))
     (etypecase node
       (ref)
       (combination
        (case (basic-combination-kind node)
-	 (:local (ltn-analyze-local-call node ltn-policy))
-	 ((:full :error) (ltn-default-call node ltn-policy))
+	 (:local (ltn-analyze-local-call node))
+	 ((:full :error) (ltn-default-call node))
 	 (t
-	  (ltn-analyze-known-call node ltn-policy))))
-      (cif
-       (ltn-analyze-if node ltn-policy))
-      (creturn
-       (ltn-analyze-return node ltn-policy))
+	  (ltn-analyze-known-call node))))
+      (cif (ltn-analyze-if node))
+      (creturn (ltn-analyze-return node))
       ((or bind entry))
-      (exit
-       (ltn-analyze-exit node ltn-policy))
-      (cset (ltn-analyze-set node ltn-policy))
+      (exit (ltn-analyze-exit node))
+      (cset (ltn-analyze-set node))
+      (cast (ltn-analyze-cast node))
       (mv-combination
        (ecase (basic-combination-kind node)
 	 (:local
-	  (ltn-analyze-mv-bind node ltn-policy))
+	  (ltn-analyze-mv-bind node))
 	 ((:full :error)
-	  (ltn-analyze-mv-call node ltn-policy)))))
+	  (ltn-analyze-mv-call node)))))
     (when (eq node (block-last block))
       (return))))
 
@@ -977,14 +893,12 @@
   (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)
-	(ltn-analyze-block block)
+	(ltn-analyze-block block)))
+    (do-blocks (block component)
+      (let ((2block (block-info block)))
 	(let ((popped (ir2-block-popped 2block)))
 	  (when popped
 	    (push block (ir2-component-values-receivers 2comp)))))))