X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=e758d67ba6aeede9e606662276dfaa38f00780a6;hb=2c06e3056fe6aa820817a927fa0e840eb7b8edb7;hp=0a463c3a1fb122345bc800f95d47ff777bddb4d8;hpb=d0ee01da90c7fee75475bd6cce9d1737f2604772;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 0a463c3..e758d67 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -43,17 +43,11 @@ (setf (car args) nil))) (values)) -(defun handle-nested-dynamic-extent-lvars (lvar) +(defun handle-nested-dynamic-extent-lvars (dx lvar) (let ((uses (lvar-uses lvar))) - ;; 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. - ;; - ;; FIXME: Is this true? I cannot trigger any bad behaviour if I nuke this - ;; form, and the only assumption regarding block ends I see in in stack - ;; analysis is the one made by MAP-BLOCK-NLXES, which assumes that nodes - ;; with cleanups in their lexenv end their blocks. If this one is - ;; necessary, we should explain why in more detail. --NS 2008-07-19 + ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. + ;; Uses of mupltiple-use LVARs already end their blocks, so we just need + ;; to process uses of single-use LVARs. (when (node-p uses) (node-ends-block uses)) ;; If this LVAR's USE is good for DX, it is either a CAST, or it @@ -61,46 +55,37 @@ (flet ((recurse (use) (etypecase use (cast - (handle-nested-dynamic-extent-lvars (cast-value use))) + (handle-nested-dynamic-extent-lvars dx (cast-value use))) (combination (loop for arg in (combination-args use) - when (lvar-good-for-dx-p arg) - append (handle-nested-dynamic-extent-lvars arg)))))) + when (lvar-good-for-dx-p arg dx) + append (handle-nested-dynamic-extent-lvars dx arg)))))) (cons lvar (if (listp uses) (loop for use in uses - when (use-good-for-dx-p use) + when (use-good-for-dx-p use dx) nconc (recurse use)) - (when (use-good-for-dx-p uses) + (when (use-good-for-dx-p uses dx) (recurse uses))))))) (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))) - append (handle-nested-dynamic-extent-lvars arg) into dx-lvars + for var in (lambda-vars fun) + for dx = (lambda-var-dynamic-extent var) + when (and dx arg (not (lvar-dynamic-extent arg))) + append (handle-nested-dynamic-extent-lvars dx arg) into dx-lvars finally (when dx-lvars ;; Stack analysis requires that the CALL ends the block, so ;; that MAP-BLOCK-NLXES sees the cleanup we insert here. (node-ends-block call) - (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) + (let* ((entry (with-ir1-environment-from-node call + (make-entry))) + (cleanup (make-cleanup :kind :dynamic-extent + :mess-up entry + :info dx-lvars))) (setf (entry-cleanup entry) cleanup) + (insert-node-before call entry) (setf (node-lexenv call) (make-lexenv :default (node-lexenv call) :cleanup cleanup)) @@ -870,6 +855,8 @@ (setf (lambda-physenv clambda) home-physenv) (when physenv + (unless home-physenv + (setf home-physenv (get-lambda-physenv home))) (setf (physenv-nlx-info home-physenv) (nconc (physenv-nlx-info physenv) (physenv-nlx-info home-physenv))))