(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
(with-ir1-environment-from-node node
- (let* ((start (make-continuation))
- (block (continuation-starts-block start))
- (cont (make-continuation))
- (*lexenv* (if cleanup
- (make-lexenv :cleanup cleanup)
- *lexenv*)))
- (change-block-successor block1 block2 block)
- (link-blocks block block2)
- (ir1-convert start cont form)
- (setf (block-last block) (continuation-use cont))
- block)))
+ (with-component-last-block (*current-component*
+ (block-next (component-head *current-component*)))
+ (let* ((start (make-continuation))
+ (block (continuation-starts-block start))
+ (cont (make-continuation))
+ (*lexenv* (if cleanup
+ (make-lexenv :cleanup cleanup)
+ *lexenv*)))
+ (change-block-successor block1 block2 block)
+ (link-blocks block block2)
+ (ir1-convert start cont form)
+ (setf (block-last block) (continuation-use cont))
+ block))))
\f
;;;; continuation use hacking
(ecase (continuation-kind cont)
(:unused
(aver (not (continuation-block cont)))
- (let* ((head (component-head *current-component*))
- (next (block-next head))
- (new-block (make-block cont)))
+ (let* ((next (component-last-block *current-component*))
+ (prev (block-prev next))
+ (new-block (make-block cont)))
(setf (block-next new-block) next
- (block-prev new-block) head
- (block-prev next) new-block
- (block-next head) new-block
- (continuation-block cont) new-block
- (continuation-use cont) nil
- (continuation-kind cont) :block-start)
+ (block-prev new-block) prev
+ (block-prev next) new-block
+ (block-next prev) new-block
+ (continuation-block cont) new-block
+ (continuation-use cont) nil
+ (continuation-kind cont) :block-start)
new-block))
(:block-start
(continuation-block cont))))
(defun make-empty-component ()
(let* ((head (make-block-key :start nil :component nil))
(tail (make-block-key :start nil :component nil))
- (res (make-component :head head :tail tail)))
+ (res (make-component head tail)))
(setf (block-flag head) t)
(setf (block-flag tail) t)
(setf (block-component head) res)
(setf (continuation-next prev) nil))
(t
(setf (continuation-next prev) next)
- (setf (node-prev next) prev)))
+ (setf (node-prev next) prev)
+ (when (and (if-p next) ; AOP wanted
+ (eq prev (if-test next)))
+ (reoptimize-continuation prev))))
(setf (node-prev node) nil)
nil)
(t
(append before-args inside-args after-args))
(change-ref-leaf (continuation-use inside-fun)
(find-free-fun 'list "???"))
- (setf (combination-kind inside) :full)
+ (setf (combination-kind inside)
+ (info :function :info 'list))
(setf (node-derived-type inside) *wild-type*)
(flush-dest cont)
(setf (continuation-asserted-type cont) *wild-type*)
:type (ctype-of object)
:where-from :defined)))
\f
+;;; Return true if VAR would have to be closed over if environment
+;;; analysis ran now (i.e. if there are any uses that have a different
+;;; home lambda than VAR's home.)
+(defun closure-var-p (var)
+ (declare (type lambda-var var))
+ (let ((home (lambda-var-home var)))
+ (cond ((eq (functional-kind home) :deleted)
+ nil)
+ (t (let ((home (lambda-home home)))
+ (flet ((frob (l)
+ (find home l :key #'node-home-lambda
+ :test-not #'eq)))
+ (or (frob (leaf-refs var))
+ (frob (basic-var-sets var)))))))))
+
;;; If there is a non-local exit noted in ENTRY's environment that
;;; exits to CONT in that entry, then return it, otherwise return NIL.
(defun find-nlx-info (entry cont)