X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=b6da50be6589cd05eaa2df57e859704e9a5b17bb;hb=095564c28a259002c7e34fd1d861f5bbd0a959b6;hp=8ebe63ad416abddae670ea6e33ca8a0849b28b8c;hpb=bfa4310e41dcd011ca9d139f29be1c5757b41378;p=sbcl.git

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 8ebe63a..b6da50b 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -43,6 +43,46 @@
              (setf (car args) nil)))
   (values))
 
+(defun recognize-dynamic-extent-lvars (call fun)
+  (declare (type combination call) (type clambda fun))
+  (loop for arg in (basic-combination-args call)
+        and var in (lambda-vars fun)
+        when (and arg
+                  (lambda-var-dynamic-extent var)
+                  (not (lvar-dynamic-extent arg)))
+        collect arg into dx-lvars
+        and do (let ((use (lvar-uses arg)))
+                 ;; Stack analysis wants DX value generators to end
+                 ;; their blocks. Uses of mupltiple used LVARs already
+                 ;; end their blocks, so we just need to process
+                 ;; used-once LVARs.
+                 (when (node-p use)
+                   (node-ends-block use)))
+        finally (when dx-lvars
+                  (binding* ((before-ctran (node-prev call))
+                             (nil (ensure-block-start before-ctran))
+                             (block (ctran-block before-ctran))
+                             (new-call-ctran (make-ctran :kind :inside-block
+                                                         :next call
+                                                         :block block))
+                             (entry (with-ir1-environment-from-node call
+                                      (make-entry :prev before-ctran
+                                                  :next new-call-ctran)))
+                             (cleanup (make-cleanup :kind :dynamic-extent
+                                                    :mess-up entry
+                                                    :info dx-lvars)))
+                    (setf (node-prev call) new-call-ctran)
+                    (setf (ctran-next before-ctran) entry)
+                    (setf (ctran-use new-call-ctran) entry)
+                    (setf (entry-cleanup entry) cleanup)
+                    (setf (node-lexenv call)
+                          (make-lexenv :default (node-lexenv call)
+                                       :cleanup cleanup))
+                    (push entry (lambda-entries (node-home-lambda entry)))
+                    (dolist (lvar dx-lvars)
+                      (setf (lvar-dynamic-extent lvar) cleanup)))))
+  (values))
+
 ;;; This function handles merging the tail sets if CALL is potentially
 ;;; tail-recursive, and is a call to a function with a different
 ;;; TAIL-SET than CALL's FUN. This must be called whenever we alter
@@ -92,6 +132,7 @@
       (when arg
         (flush-lvar-externally-checkable-type arg))))
   (pushnew fun (lambda-calls-or-closes (node-home-lambda call)))
+  (recognize-dynamic-extent-lvars call fun)
   (merge-tail-sets call fun)
   (change-ref-leaf ref fun)
   (values))
@@ -351,8 +392,8 @@
           (cond (losing-local-functional
                  (let ((*compiler-error-context* call))
                    (compiler-notify "couldn't inline expand because expansion ~
-		                   calls this LET-converted local function:~
-		                   ~%  ~S"
+                                     calls this LET-converted local function:~
+                                     ~%  ~S"
                                     (leaf-debug-name losing-local-functional)))
                  (loop for block = (block-next pred) then (block-next block)
                        until (eq block end)
@@ -586,8 +627,7 @@
       (when (optional-dispatch-keyp fun)
 	(when (oddp (length more))
 	  (compiler-warn "function called with odd number of ~
-  		          arguments in keyword portion")
-
+                          arguments in keyword portion")
 	  (setf (basic-combination-kind call) :error)
 	  (return-from convert-more-call))
 
@@ -846,7 +886,8 @@
         ;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26
         (do-uses (use result)
           (derive-node-type use call-type)))
-      (substitute-lvar-uses lvar result)))
+      (substitute-lvar-uses lvar result
+                            (and lvar (eq (lvar-uses lvar) call)))))
   (values))
 
 ;;; We are converting FUN to be a LET when the call is in a non-tail