Skip to content
Snippets Groups Projects
Commit 2e3a6270 authored by ram's avatar ram
Browse files

Added code to recognize :DEBUG-ENVIRONMENT TNs as always-live, but only

when they are never set.
parent 9564b548
No related branches found
No related tags found
No related merge requests found
...@@ -80,7 +80,8 @@ ...@@ -80,7 +80,8 @@
(do-live-tns (tn live block) (do-live-tns (tn live block)
(let ((leaf (tn-leaf tn))) (let ((leaf (tn-leaf tn)))
(when (and (lambda-var-p leaf) (when (and (lambda-var-p leaf)
(or (not (eq (tn-kind tn) :environment)) (or (not (member (tn-kind tn)
'(:environment :debug-environment)))
(rassoc leaf (lexenv-variables (node-lexenv node))))) (rassoc leaf (lexenv-variables (node-lexenv node)))))
(let ((num (gethash leaf var-locs))) (let ((num (gethash leaf var-locs)))
(when num (when num
...@@ -332,6 +333,11 @@ ...@@ -332,6 +333,11 @@
;;; makes Var's name unique in the function. Buffer is the vector we stick the ;;; makes Var's name unique in the function. Buffer is the vector we stick the
;;; result in. ;;; result in.
;;; ;;;
;;; The debug-variable is only marked as always-live if the TN is
;;; environment live and is an argument. If a :debug-environment TN, then we
;;; also exclude set variables, since the variable is not guranteed to be live
;;; everywhere in that case.
;;;
(defun dump-1-variable (fun var tn id buffer) (defun dump-1-variable (fun var tn id buffer)
(declare (type lambda-var var) (type tn tn) (type unsigned-byte id) (declare (type lambda-var var) (type tn tn) (type unsigned-byte id)
(type clambda fun)) (type clambda fun))
...@@ -339,12 +345,15 @@ ...@@ -339,12 +345,15 @@
(package (symbol-package name)) (package (symbol-package name))
(package-p (and package (not (eq package *package*)))) (package-p (and package (not (eq package *package*))))
(save-tn (tn-save-tn tn)) (save-tn (tn-save-tn tn))
(kind (tn-kind tn))
(flags 0)) (flags 0))
(unless package (unless package
(setq flags (logior flags compiled-debug-variable-uninterned))) (setq flags (logior flags compiled-debug-variable-uninterned)))
(when package-p (when package-p
(setq flags (logior flags compiled-debug-variable-packaged))) (setq flags (logior flags compiled-debug-variable-packaged)))
(when (and (eq (tn-kind tn) :environment) (when (and (or (eq kind :environment)
(and (eq kind :debug-environment)
(null (basic-var-sets var))))
(eq (lambda-var-home var) fun)) (eq (lambda-var-home var) fun))
(setq flags (logior flags compiled-debug-variable-environment-live))) (setq flags (logior flags compiled-debug-variable-environment-live)))
(when save-tn (when save-tn
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment