res))))
;;; If FUN has no physical environment, assign one, otherwise clean up
-;;; the old physical environment, removing/flagging variables that
-;;; have no sets or refs. If a var has no references, we remove it
-;;; from the closure. We always clear the INDIRECT flag. This is
-;;; necessary because pre-analysis is done before optimization.
+;;; the old physical environment and the INDIRECT flag on LAMBDA-VARs.
+;;; This is necessary because pre-analysis is done before
+;;; optimization.
(defun reinit-lambda-physenv (fun)
(let ((old (lambda-physenv (lambda-home fun))))
(cond (old
- (setf (physenv-closure old)
- (delete-if (lambda (x)
- (and (lambda-var-p x)
- (null (leaf-refs x))))
- (physenv-closure old)))
+ (setf (physenv-closure old) nil)
(flet ((clear (fun)
(dolist (var (lambda-vars fun))
(setf (lambda-var-indirect var) nil))))
(loop for what in (cleanup-info cleanup)
do (etypecase what
(lvar
- (let* ((lvar what)
- (use (lvar-uses lvar)))
- (if (and (combination-p use)
- (eq (basic-combination-kind use) :known)
- (awhen (fun-info-stack-allocate-result
- (basic-combination-fun-info use))
- (funcall it use)))
- (real-dx-lvars lvar)
- (setf (lvar-dynamic-extent lvar) nil))))
+ (if (lvar-good-for-dx-p what t component)
+ (let ((real (principal-lvar what)))
+ (setf (lvar-dynamic-extent real) cleanup)
+ (real-dx-lvars real))
+ (setf (lvar-dynamic-extent what) nil)))
(node ; DX closure
(let* ((call what)
(arg (first (basic-combination-args call)))
(dx nil))
(dolist (fun funs)
(binding* ((() (leaf-dynamic-extent fun)
- :exit-if-null)
+ :exit-if-null)
(xep (functional-entry-fun fun)
- :exit-if-null)
+ :exit-if-null)
(closure (physenv-closure
(get-lambda-physenv xep))))
(cond (closure
(when dx
(setf (lvar-dynamic-extent arg) cleanup)
(real-dx-lvars arg))))))
- (setf (cleanup-info cleanup) (real-dx-lvars))
- (setf (component-dx-lvars component)
- (append (real-dx-lvars) (component-dx-lvars component)))))))
+ (let ((real-dx-lvars (delete-duplicates (real-dx-lvars))))
+ (setf (cleanup-info cleanup) real-dx-lvars)
+ (setf (component-dx-lvars component)
+ (append real-dx-lvars (component-dx-lvars component))))))))
(values))
\f
;;;; cleanup emission