X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=7600eebfa19f18128490efac5b63ba4a6378d022;hb=80f222325e1f677e5cf8de01c6990906fa47f65d;hp=2dfcfef0fd11ed90b6b9a9150adb857e750b8c56;hpb=64ec717cf13c44fb4571c1fd7fbd508551ecfe01;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 2dfcfef..7600eeb 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -494,6 +494,10 @@
 (defun ctran-home-lambda (ctran)
   (ctran-home-lambda-or-null ctran))
 
+(declaim (inline cast-single-value-p))
+(defun cast-single-value-p (cast)
+  (not (values-type-p (cast-asserted-type cast))))
+
 #!-sb-fluid (declaim (inline lvar-single-value-p))
 (defun lvar-single-value-p (lvar)
   (or (not lvar)
@@ -506,7 +510,7 @@
           (cast
            (locally
                (declare (notinline lvar-single-value-p))
-             (and (not (values-type-p (cast-asserted-type dest)))
+             (and (cast-single-value-p dest)
                   (lvar-single-value-p (node-lvar dest)))))
           (t
            t)))))
@@ -534,6 +538,9 @@
                          type-restrictions
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
+		         (handled-conditions (lexenv-handled-conditions default))
+		         (disabled-package-locks 
+			  (lexenv-disabled-package-locks default))
 			 (policy (lexenv-policy default)))
   (macrolet ((frob (var slot)
 	       `(let ((old (,slot default)))
@@ -546,7 +553,8 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
-     lambda cleanup policy)))
+     lambda cleanup handled-conditions 
+     disabled-package-locks policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
 ;;; macroexpander
@@ -575,6 +583,8 @@
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil
+     (lexenv-handled-conditions lexenv)
+     (lexenv-disabled-package-locks lexenv)
      (lexenv-policy lexenv))))
 
 ;;;; flow/DFO/component hackery
@@ -1149,8 +1159,14 @@
 	(unless (policy *compiler-error-context* (= inhibit-warnings 3))
 	  ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
 	  ;; requires this to be no more than a STYLE-WARNING.
+	  #-sb-xc-host
 	  (compiler-style-warn "The variable ~S is defined but never used."
-			       (leaf-debug-name var)))
+			       (leaf-debug-name var))
+	  ;; There's no reason to accept this kind of equivocation
+	  ;; when compiling our own code, though.
+	  #+sb-xc-host
+	  (warn "The variable ~S is defined but never used."
+		(leaf-debug-name var)))
 	(setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
   (values))
 
@@ -1374,8 +1390,8 @@
 		(append before-args inside-args after-args))
 	  (change-ref-leaf (lvar-uses inside-fun)
 			   (find-free-fun 'list "???"))
-	  (setf (combination-kind inside)
-                (info :function :info 'list))
+	  (setf (combination-fun-info inside) (info :function :info 'list)
+		(combination-kind inside) :known)
 	  (setf (node-derived-type inside) *wild-type*)
 	  (flush-dest lvar)
 	  (values))))))
@@ -1458,7 +1474,7 @@
                (flet ((frob (l)
                         (find home l
                               :key #'node-home-lambda
-                              :test-not #'eq)))
+                              :test #'neq)))
                  (or (frob (leaf-refs var))
                      (frob (basic-var-sets var)))))))))
 
@@ -1466,8 +1482,7 @@
 ;;; exits to CONT in that entry, then return it, otherwise return NIL.
 (defun find-nlx-info (exit)
   (declare (type exit exit))
-  (let* ((entry (exit-entry exit))
-         (entry-cleanup (entry-cleanup entry)))
+  (let ((entry (exit-entry exit)))
     (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
       (when (eq (nlx-info-exit nlx) exit)
 	(return nlx)))))
@@ -1601,13 +1616,15 @@
   (declare (type combination call))
   (let ((kind (basic-combination-kind call)))
     (or (eq kind :full)
-        (and (fun-info-p kind)
-             (not (fun-info-ir2-convert kind))
-             (dolist (template (fun-info-templates kind) t)
-               (when (eq (template-ltn-policy template) :fast-safe)
-                 (multiple-value-bind (val win)
-                     (valid-fun-use call (template-type template))
-                   (when (or val (not win)) (return nil)))))))))
+        (and (eq kind :known)
+	     (let ((info (basic-combination-fun-info call)))
+	       (and
+		(not (fun-info-ir2-convert info))
+		(dolist (template (fun-info-templates info) t)
+		  (when (eq (template-ltn-policy template) :fast-safe)
+		    (multiple-value-bind (val win)
+		       (valid-fun-use call (template-type template))
+		      (when (or val (not win)) (return nil)))))))))))
 
 ;;;; careful call