X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=d32325b6923caed5e75b8358a01de555cb37266c;hb=91392754bf1d241cd6913c728268caf18eae1485;hp=d722ba5471973dffe834beba4d617c2b012237fd;hpb=1a7d93adc5e5fa3c1bfe09ebbe32f54db6c8abcc;p=sbcl.git

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index d722ba5..d32325b 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -266,7 +266,7 @@
 ;;;; utilities for receiving fixed values
 
 ;;; Return a TN that can be referenced to get the value of CONT. CONT
-;;; must be LTN-Annotated either as a delayed leaf ref or as a fixed,
+;;; must be LTN-ANNOTATED either as a delayed leaf ref or as a fixed,
 ;;; single-value continuation. If a type check is called for, do it.
 ;;;
 ;;; The primitive-type of the result will always be the same as the
@@ -470,7 +470,7 @@
 
 ;;;; template conversion
 
-;;; Build a TN-Refs list that represents access to the values of the
+;;; Build a TN-REFS list that represents access to the values of the
 ;;; specified list of continuations ARGS for TEMPLATE. Any :CONSTANT
 ;;; arguments are returned in the second value as a list rather than
 ;;; being accessed as a normal argument. NODE and BLOCK provide the
@@ -588,7 +588,7 @@
 	 cont
 	 (find-template-result-types call cont template rtypes)))))
 
-;;; Get the operands into TNs, make TN-Refs for them, and then call
+;;; Get the operands into TNs, make TN-REFs for them, and then call
 ;;; the template emit function.
 (defun ir2-convert-template (call block)
   (declare (type combination call) (type ir2-block block))
@@ -966,7 +966,7 @@
 		  arg-locs nargs)))))
   (values))
 
-;;; stuff to check in CHECK-FULL-CALL
+;;; stuff to check in PONDER-FULL-CALL
 ;;;
 ;;; There are some things which are intended always to be optimized
 ;;; away by DEFTRANSFORMs and such, and so never compiled into full
@@ -979,7 +979,7 @@
 ;;; list.
 (defvar *always-optimized-away*
   '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug
-    ;; reported to cmucl-imp@cons.org 2000-06-20.
+    ;; reported to cmucl-imp 2000-06-20.
     %instance-ref
     ;; These should always turn into VOPs, but wasn't in a bug which
     ;; appeared when LTN-POLICY stuff was being tweaked in
@@ -987,7 +987,7 @@
     data-vector-set
     data-vector-ref))
 
-;;; more stuff to check in CHECK-FULL-CALL
+;;; more stuff to check in PONDER-FULL-CALL
 ;;;
 ;;; These came in handy when troubleshooting cold boot after making
 ;;; major changes in the package structure: various transforms and
@@ -999,12 +999,15 @@
 #!+sb-show (defvar *show-full-called-fnames-p* nil)
 #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal))
 
-;;; Do some checks on a full call:
+;;; Do some checks (and store some notes relevant for future checks)
+;;; on a full call:
 ;;;   * Is this a full call to something we have reason to know should
-;;;     never be full called?
+;;;     never be full called? (Except as of sbcl-0.7.18 or so, we no
+;;;     longer try to ensure this behavior when *FAILURE-P* has already
+;;;     been detected.)
 ;;;   * Is this a full call to (SETF FOO) which might conflict with
 ;;;     a DEFSETF or some such thing elsewhere in the program?
-(defun check-full-call (node)
+(defun ponder-full-call (node)
   (let* ((cont (basic-combination-fun node))
 	 (fname (continuation-fun-name cont t)))
     (declare (type (or symbol cons) fname))
@@ -1024,10 +1027,16 @@
 					  (basic-combination-args node))))
 		   (/show arg-types)))
 
-    (when (memq fname *always-optimized-away*)
-      (/show (policy node speed) (policy node safety))
-      (/show (policy node compilation-speed))
-      (bug "full call to ~S" fname))
+    ;; When illegal code is compiled, all sorts of perverse paths
+    ;; through the compiler can be taken, and it's much harder -- and
+    ;; probably pointless -- to guarantee that always-optimized-away
+    ;; functions are actually optimized away. Thus, we skip the check
+    ;; in that case.
+    (unless *failure-p*
+      (when (memq fname *always-optimized-away*)
+	(/show (policy node speed) (policy node safety))
+	(/show (policy node compilation-speed))
+	(bug "full call to ~S" fname)))
 
     (when (consp fname)
       (destructuring-bind (setf stem) fname
@@ -1040,7 +1049,7 @@
 ;;; multiple-values call.
 (defun ir2-convert-full-call (node block)
   (declare (type combination node) (type ir2-block block))
-  (check-full-call node)
+  (ponder-full-call node)
   (let ((2cont (continuation-info (node-cont node))))
     (cond ((node-tail-p node)
 	   (ir2-convert-tail-full-call node block))
@@ -1281,14 +1290,15 @@
 (defoptimizer (values-list ir2-convert) ((list) node block)
   (let* ((cont (node-cont node))
 	 (2cont (continuation-info cont)))
-    (when 2cont
-      (ecase (ir2-continuation-kind 2cont)
-	(:fixed (ir2-convert-full-call node block))
-	(:unknown
-	 (let ((locs (ir2-continuation-locs 2cont)))
-	   (vop* values-list node block
-		 ((continuation-tn node block list) nil)
-		 ((reference-tn-list locs t)))))))))
+    (cond ((and 2cont
+                (eq (ir2-continuation-kind 2cont) :unknown))
+           (let ((locs (ir2-continuation-locs 2cont)))
+             (vop* values-list node block
+                   ((continuation-tn node block list) nil)
+                   ((reference-tn-list locs t)))))
+          (t (aver (or (not 2cont) ; i.e. we want to check the argument
+                       (eq (ir2-continuation-kind 2cont) :fixed)))
+             (ir2-convert-full-call node block)))))
 
 (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block)
   (let* ((cont (node-cont node))