* Generate one NLX-INFO per pair cleanup/continuation.
((: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))
;;; 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))))
\f
;;;; functional hackery
;;; 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)))
;;; 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.
;;; 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))
(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,
;; 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
;; some kind of info used by the back end
info)
(defprinter (nlx-info :identity t)
- exit
+ block
target
info)
\f
(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)
(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))
(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
;;; 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"
projects / sbcl.git / commitdiff