From 883b33b092472473b0dd559d64351b9436916af3 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Wed, 12 Jan 2005 17:57:14 +0000 Subject: [PATCH] 0.8.18.26: * Generate one NLX-INFO per pair cleanup/continuation. --- src/compiler/ir1util.lisp | 13 +++++++++--- src/compiler/ir2tran.lisp | 19 ++++++++++------- src/compiler/node.lisp | 31 +++++++++++++-------------- src/compiler/physenvanal.lisp | 46 ++++++++++++++++++++++------------------- version.lisp-expr | 2 +- 5 files changed, 63 insertions(+), 48 deletions(-) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 5d74523..b62fb36 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -740,7 +740,7 @@ ((:block :tagbody) (aver (entry-p mess-up)) (loop for exit in (entry-exits mess-up) - for nlx-info = (find-nlx-info exit) + for nlx-info = (exit-nlx-info exit) do (funcall fun nlx-info))) ((:catch :unwind-protect) (aver (combination-p mess-up)) @@ -1531,10 +1531,17 @@ ;;; 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))) + (let* ((entry (exit-entry exit)) + (cleanup (entry-cleanup entry)) + (block (first (block-succ (node-block exit))))) (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) - (when (eq (nlx-info-exit nlx) exit) + (when (and (eq (nlx-info-block nlx) block) + (eq (nlx-info-cleanup nlx) cleanup)) (return nlx))))) + +(defun nlx-info-lvar (nlx) + (declare (type nlx-info nlx)) + (node-lvar (block-last (nlx-info-target nlx)))) ;;;; functional hackery diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 22b4332..8157cd8 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1489,7 +1489,7 @@ ;;; IR2 converted. (defun ir2-convert-exit (node block) (declare (type exit node) (type ir2-block block)) - (let ((loc (find-in-physenv (find-nlx-info node) + (let ((loc (find-in-physenv (exit-nlx-info node) (node-physenv node))) (temp (make-stack-pointer-tn)) (value (exit-value node))) @@ -1570,12 +1570,15 @@ ;;; Scan each of ENTRY's exits, setting up the exit for each lexical exit. (defun ir2-convert-entry (node block) (declare (type entry node) (type ir2-block block)) - (dolist (exit (entry-exits node)) - (let ((info (find-nlx-info exit))) - (when (and info - (member (cleanup-kind (nlx-info-cleanup info)) - '(:block :tagbody))) - (emit-nlx-start node block info nil)))) + (let ((nlxes '())) + (dolist (exit (entry-exits node)) + (let ((info (exit-nlx-info exit))) + (when (and info + (not (memq info nlxes)) + (member (cleanup-kind (nlx-info-cleanup info)) + '(:block :tagbody))) + (push info nlxes) + (emit-nlx-start node block info nil))))) (values)) ;;; Set up the unwind block for these guys. @@ -1606,7 +1609,7 @@ ;;; pointer alone, since the thrown values are still out there. (defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block) (let* ((info (lvar-value info-lvar)) - (lvar (nlx-info-lvar info)) + (lvar (node-lvar node)) (2info (nlx-info-info info)) (top-loc (ir2-nlx-info-save-sp 2info)) (start-loc (make-nlx-entry-arg-start-location)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 5c9d617..535af80 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -543,7 +543,9 @@ (def!struct (nlx-info (:constructor make-nlx-info (cleanup exit - &aux (lvar (node-lvar exit)))) + &aux + (block (first (block-succ + (node-block exit)))))) (:make-load-form-fun ignore-it)) ;; the cleanup associated with this exit. In a catch or ;; unwind-protect, this is the :CATCH or :UNWIND-PROTECT cleanup, @@ -551,19 +553,17 @@ ;; this thus provides a good indication of what kind of exit is ;; being done. (cleanup (missing-arg) :type cleanup) - ;; the continuation exited to (the CONT of the EXIT nodes). If this - ;; exit is from an escape function (CATCH or UNWIND-PROTECT), then - ;; physical environment analysis deletes the escape function and - ;; instead has the %NLX-ENTRY use this continuation. + ;; the ``continuation'' exited to (the block, succeeding the EXIT + ;; nodes). If this exit is from an escape function (CATCH or + ;; UNWIND-PROTECT), then physical environment analysis deletes the + ;; escape function and instead has the %NLX-ENTRY use this + ;; continuation. ;; - ;; This slot is primarily an indication of where this exit delivers - ;; its values to (if any), but it is also used as a sort of name to - ;; allow us to find the NLX-INFO that corresponds to a given exit. - ;; For this purpose, the ENTRY must also be used to disambiguate, - ;; since exits to different places may deliver their result to the - ;; same continuation. - (exit (missing-arg) :type exit) - (lvar (missing-arg) :type (or lvar null)) + ;; This slot is used as a sort of name to allow us to find the + ;; NLX-INFO that corresponds to a given exit. For this purpose, the + ;; ENTRY must also be used to disambiguate, since exits to different + ;; places may deliver their result to the same continuation. + (block (missing-arg) :type cblock) ;; the entry stub inserted by physical environment analysis. This is ;; a block containing a call to the %NLX-ENTRY funny function that ;; has the original exit destination as its successor. Null only @@ -572,7 +572,7 @@ ;; some kind of info used by the back end info) (defprinter (nlx-info :identity t) - exit + block target info) @@ -1319,7 +1319,8 @@ (entry nil :type (or entry null)) ;; the lvar yielding the value we are to exit with. If NIL, then no ;; value is desired (as in GO). - (value nil :type (or lvar null))) + (value nil :type (or lvar null)) + (nlx-info nil :type (or nlx-info null))) (defprinter (exit :identity t) #!+sb-show id (entry :test entry) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index 3908aca..ff248e9 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -282,6 +282,7 @@ (link-blocks exit-block (component-tail component)) (link-blocks (component-head component) new-block) + (setf (exit-nlx-info exit) info) (setf (nlx-info-target info) new-block) (push info (physenv-nlx-info env)) (push info (cleanup-nlx-info cleanup)) @@ -311,27 +312,30 @@ (defun note-non-local-exit (env exit) (declare (type physenv env) (type exit exit)) (let ((lvar (node-lvar exit)) - (exit-fun (node-home-lambda exit))) - (if (find-nlx-info exit) - (let ((block (node-block exit))) - (aver (= (length (block-succ block)) 1)) - (unlink-blocks block (first (block-succ block))) - (link-blocks block (component-tail (block-component block)))) - (insert-nlx-entry-stub exit env)) - (let ((info (find-nlx-info exit))) - (aver info) - (close-over info (node-physenv exit) env) - (when (eq (functional-kind exit-fun) :escape) - (mapc (lambda (x) - (setf (node-derived-type x) *wild-type*)) - (leaf-refs exit-fun)) - (substitute-leaf (find-constant info) exit-fun)) - (when lvar - (let ((node (block-last (nlx-info-target info)))) - (unless (node-lvar node) - (aver (eq lvar (node-lvar exit))) - (setf (node-derived-type node) (lvar-derived-type lvar)) - (add-lvar-use node lvar)))))) + (exit-fun (node-home-lambda exit)) + (info (find-nlx-info exit))) + (cond (info + (let ((block (node-block exit))) + (aver (= (length (block-succ block)) 1)) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (component-tail (block-component block))) + (setf (exit-nlx-info exit) info))) + (t + (insert-nlx-entry-stub exit env) + (setq info (exit-nlx-info exit)) + (aver info))) + (close-over info (node-physenv exit) env) + (when (eq (functional-kind exit-fun) :escape) + (mapc (lambda (x) + (setf (node-derived-type x) *wild-type*)) + (leaf-refs exit-fun)) + (substitute-leaf (find-constant info) exit-fun)) + (when lvar + (let ((node (block-last (nlx-info-target info)))) + (unless (node-lvar node) + (aver (eq lvar (node-lvar exit))) + (setf (node-derived-type node) (lvar-derived-type lvar)) + (add-lvar-use node lvar))))) (values)) ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT diff --git a/version.lisp-expr b/version.lisp-expr index 9410235..425e4e3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.18.25" +"0.8.18.26" -- 1.7.10.4