X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=4e4b031ab9a3d4ddce0c62725962fb44cdae7353;hb=f705c517d8606a9a72edd11a96725f9c4e4be93d;hp=538e95a6d005a30bc9c917334a5026978340da13;hpb=5ef7f500a505f5711b1c76ff8c15f443d4815367;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 538e95a..4e4b031 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -164,16 +164,27 @@
   (values))
 
 ;;; Replace all uses of OLD with uses of NEW, where NEW has an
-;;; arbitary number of uses.
-(defun substitute-lvar-uses (new old)
+;;; arbitary number of uses. NEW is supposed to be "later" than OLD.
+(defun substitute-lvar-uses (new old propagate-dx)
   (declare (type lvar old)
-           (type (or lvar null) new))
-
-  (cond (new (do-uses (node old)
-               (%delete-lvar-use node)
-               (add-lvar-use node new))
-             (reoptimize-lvar new))
+           (type (or lvar null) new)
+           (type boolean propagate-dx))
+
+  (cond (new
+         (do-uses (node old)
+           (%delete-lvar-use node)
+           (add-lvar-use node new))
+         (reoptimize-lvar new)
+         (awhen (and propagate-dx (lvar-dynamic-extent old))
+           (setf (lvar-dynamic-extent old) nil)
+           (unless (lvar-dynamic-extent new)
+             (setf (lvar-dynamic-extent new) it)
+             (setf (cleanup-info it) (substitute new old (cleanup-info it)))))
+         (when (lvar-dynamic-extent new)
+           (do-uses (node new)
+             (node-ends-block node))))
         (t (flush-dest old)))
+
   (values))
 
 ;;;; block starting/creation
@@ -305,8 +316,9 @@
                     (when (and (basic-combination-p use)
                                (eq (basic-combination-kind use) :local))
                       (merges use))))
+                (substitute-lvar-uses lvar value
+                                      (and lvar (eq (lvar-uses lvar) node)))
                 (%delete-lvar-use node)
-                (substitute-lvar-uses lvar value)
                 (prog1
                     (unlink-node node)
                   (dolist (merge (merges))
@@ -342,6 +354,11 @@
 (defun node-dest (node)
   (awhen (node-lvar node) (lvar-dest it)))
 
+#!-sb-fluid (declaim (inline node-stack-allocate-p))
+(defun node-stack-allocate-p (node)
+  (awhen (node-lvar node)
+    (lvar-dynamic-extent it)))
+
 (declaim (inline block-to-be-deleted-p))
 (defun block-to-be-deleted-p (block)
   (or (block-delete-p block)
@@ -494,6 +511,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 +527,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 +555,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 +570,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 +600,8 @@
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil
+     (lexenv-handled-conditions lexenv)
+     (lexenv-disabled-package-locks lexenv)
      (lexenv-policy lexenv))))
 
 ;;;; flow/DFO/component hackery
@@ -684,7 +711,7 @@
 ;;; end. The tricky thing is a special cleanup block; all its nodes
 ;;; have the same cleanup info, corresponding to the start, so the
 ;;; same approach returns safe result.
-(defun map-block-nlxes (fun block)
+(defun map-block-nlxes (fun block &optional dx-cleanup-fun)
   (loop for cleanup = (block-end-cleanup block)
         then (node-enclosing-cleanup (cleanup-mess-up cleanup))
         while cleanup
@@ -699,7 +726,10 @@
                 (aver (combination-p mess-up))
                 (let* ((arg-lvar (first (basic-combination-args mess-up)))
                        (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
-                (funcall fun nlx-info)))))))
+                (funcall fun nlx-info)))
+               ((:dynamic-extent)
+                (when dx-cleanup-fun
+                  (funcall dx-cleanup-fun cleanup)))))))
 
 ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
 ;;; the head and tail which are set to T.
@@ -1149,8 +1179,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))
 
@@ -1466,8 +1502,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)))))