Skip to content
Snippets Groups Projects
Commit 49abe894 authored by ram's avatar ram
Browse files

Misc changes for new lexenv structure. Only dump TNs as always-live

if they are args, otherwise use the lexenv to tell whether they are
in scope at any given point.
parent 9a5030ec
No related branches found
No related tags found
No related merge requests found
......@@ -61,24 +61,27 @@
(proclaim '(inline ir2-block-environment))
(defun ir2-block-environment (2block)
(declare (type ir2-block 2block))
(lambda-environment (block-lambda (ir2-block-block 2block))))
(block-environment (ir2-block-block 2block)))
;;; COMPUTE-LIVE-VARS -- Internal
;;;
;;; Given a local conflicts vector and an IR2 block to represent the set of
;;; live TNs, and the Var-Locs hashtable representing the variables dumped,
;;; compute a bit-vector representing the set of live variables.
;;; compute a bit-vector representing the set of live variables. If the TN is
;;; environment-live, we only mark it as live when it is in scope at Node.
;;;
(defun compute-live-vars (live block var-locs)
(defun compute-live-vars (live node block var-locs)
(declare (type ir2-block block) (type local-tn-bit-vector live)
(type hash-table var-locs))
(type hash-table var-locs) (type node node))
(let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
:element-type 'bit
:initial-element 0)))
(do-live-tns (tn live block)
(let ((leaf (tn-leaf tn)))
(when (lambda-var-p leaf)
(when (and (lambda-var-p leaf)
(or (not (eq (tn-kind tn) :environment))
(rassoc leaf (lexenv-variables (node-lexenv node)))))
(let ((num (gethash leaf var-locs)))
(when num
(setf (sbit res num) 1))))))
......@@ -109,12 +112,13 @@
(let ((loc (label-location label)))
(write-var-integer (- loc *previous-location*) *byte-buffer*)
(setq *previous-location* loc))
(let ((path (node-source-path node)))
(unless tlf-num
(write-var-integer (source-path-tlf-number path) *byte-buffer*))
(write-var-integer (source-path-form-number path) *byte-buffer*))
(unless tlf-num
(write-var-integer (node-tlf-number node) *byte-buffer*))
(write-var-integer (first (node-source-path node)) *byte-buffer*)
(write-packed-bit-vector (compute-live-vars live block var-locs)
(write-packed-bit-vector (compute-live-vars live node block var-locs)
*byte-buffer*)
(undefined-value))
......@@ -146,19 +150,24 @@
;;;
(defun find-tlf-and-block-numbers (fun)
(declare (type clambda fun))
(let ((res (node-tlf-number (lambda-bind fun)))
(let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
(num 0))
(do-environment-ir2-blocks (2block (lambda-environment fun))
(let ((block (ir2-block-block 2block)))
(when (eq (block-info block) 2block)
(setf (block-flag block) num)
(incf num)
(unless (eql (node-tlf-number (continuation-next (block-start block)))
(unless (eql (source-path-tlf-number
(node-source-path
(continuation-next
(block-start block))))
res)
(setq res nil)))
(dolist (loc (ir2-block-locations 2block))
(unless (eql (node-tlf-number (vop-node (location-info-vop loc)))
(unless (eql (source-path-tlf-number
(node-source-path
(vop-node (location-info-vop loc))))
res)
(setq res nil)))))
res))
......@@ -194,8 +203,7 @@
(valid-succ
(if (and succ
(or (eq (car succ) tail)
(not (eq (lambda-environment (block-lambda (car succ)))
env))))
(not (eq (block-environment (car succ)) env))))
()
succ)))
(vector-push-extend
......@@ -277,7 +285,7 @@
(setf (debug-source-from res) name)
(when (eq name :lisp)
(setf (debug-source-name res)
(cadr (aref (file-info-forms x) 0))))))
(aref (file-info-forms x) 0)))))
res))
(source-info-files info)))
......@@ -306,7 +314,7 @@
(coerce seq 'simple-vector))))
;;;; Locations:
;;;; Variables:
;;; TN-SC-OFFSET -- Internal
;;;
......@@ -324,8 +332,9 @@
;;; makes Var's name unique in the function. Buffer is the vector we stick the
;;; result in.
;;;
(defun dump-1-variable (var tn id buffer)
(declare (type lambda-var var) (type tn tn) (type unsigned-byte id))
(defun dump-1-variable (fun var tn id buffer)
(declare (type lambda-var var) (type tn tn) (type unsigned-byte id)
(type clambda fun))
(let* ((name (leaf-name var))
(package (symbol-package name))
(package-p (and package (not (eq package *package*))))
......@@ -335,7 +344,8 @@
(setq flags (logior flags compiled-debug-variable-uninterned)))
(when package-p
(setq flags (logior flags compiled-debug-variable-packaged)))
(when (eq (tn-kind tn) :environment)
(when (and (eq (tn-kind tn) :environment)
(eq (lambda-var-home var) fun))
(setq flags (logior flags compiled-debug-variable-environment-live)))
(when save-tn
(setq flags (logior flags compiled-debug-variable-save-loc-p)))
......@@ -397,7 +407,7 @@
(incf id))
(t
(setq id 0 prev-name name)))
(dump-1-variable var (cdr x) id *byte-buffer*)
(dump-1-variable fun var (cdr x) id *byte-buffer*)
(setf (gethash var var-locs) i))
(incf i)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment