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

Added stuff to check for spilled TNs so that the debugger knows they

aren't really there.
Also, added declarations and stuff to avoid generic arith.
And fixed up the debug-info policy handling a bit so that this quality
works reasonably as a local declaration.
parent 06645b79
No related branches found
No related tags found
No related merge requests found
...@@ -71,18 +71,24 @@ ...@@ -71,18 +71,24 @@
;;; compute a bit-vector representing the set of live variables. If the TN is ;;; 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. ;;; environment-live, we only mark it as live when it is in scope at Node.
;;; ;;;
(defun compute-live-vars (live node block var-locs) (defun compute-live-vars (live node block var-locs vop)
(declare (type ir2-block block) (type local-tn-bit-vector live) (declare (type ir2-block block) (type local-tn-bit-vector live)
(type hash-table var-locs) (type node node)) (type hash-table var-locs) (type node node)
(type (or vop null) vop))
(let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
:element-type 'bit :element-type 'bit
:initial-element 0))) :initial-element 0))
(spilled (gethash vop
(ir2-component-spilled-vops
(component-info *compile-component*)))))
(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 (member (tn-kind tn) (or (not (member (tn-kind tn)
'(:environment :debug-environment))) '(:environment :debug-environment)))
(rassoc leaf (lexenv-variables (node-lexenv node))))) (rassoc leaf (lexenv-variables (node-lexenv node))))
(or (null spilled)
(not (member tn spilled))))
(let ((num (gethash leaf var-locs))) (let ((num (gethash leaf var-locs)))
(when num (when num
(setf (sbit res num) 1)))))) (setf (sbit res num) 1))))))
...@@ -92,17 +98,19 @@ ...@@ -92,17 +98,19 @@
;;; The PC for the location most recently dumped. ;;; The PC for the location most recently dumped.
;;; ;;;
(defvar *previous-location*) (defvar *previous-location*)
(proclaim '(type index *previous-location*))
;;; DUMP-1-LOCATION -- Internal ;;; DUMP-1-LOCATION -- Internal
;;; ;;;
;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the ;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
;;; code/source map and live info. ;;; code/source map and live info. If true, VOP is the VOP associated with
;;; this location, for use in determining whether TNs are spilled.
;;; ;;;
(defun dump-1-location (node block kind tlf-num label live var-locs) (defun dump-1-location (node block kind tlf-num label live var-locs vop)
(declare (type node node) (type ir2-block block) (declare (type node node) (type ir2-block block)
(type local-tn-bit-vector live) (type label label) (type local-tn-bit-vector live) (type label label)
(type location-kind kind) (type (or index null) tlf-num) (type location-kind kind) (type (or index null) tlf-num)
(type hash-table var-locs)) (type hash-table var-locs) (type (or vop null) vop))
(vector-push-extend (vector-push-extend
(dpb (position kind compiled-code-location-kinds) (dpb (position kind compiled-code-location-kinds)
...@@ -119,7 +127,7 @@ ...@@ -119,7 +127,7 @@
(write-var-integer (source-path-tlf-number path) *byte-buffer*)) (write-var-integer (source-path-tlf-number path) *byte-buffer*))
(write-var-integer (source-path-form-number path) *byte-buffer*)) (write-var-integer (source-path-form-number path) *byte-buffer*))
(write-packed-bit-vector (compute-live-vars live node block var-locs) (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
*byte-buffer*) *byte-buffer*)
(undefined-value)) (undefined-value))
...@@ -140,7 +148,8 @@ ...@@ -140,7 +148,8 @@
tlf-num tlf-num
(location-info-label loc) (location-info-label loc)
(vop-save-set vop) (vop-save-set vop)
var-locs)) var-locs
vop))
(undefined-value)) (undefined-value))
...@@ -153,6 +162,7 @@ ...@@ -153,6 +162,7 @@
(declare (type clambda fun)) (declare (type clambda fun))
(let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))) (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun))))
(num 0)) (num 0))
(declare (type index num) (type (or index null) res))
(do-environment-ir2-blocks (2block (lambda-environment fun)) (do-environment-ir2-blocks (2block (lambda-environment fun))
(let ((block (ir2-block-block 2block))) (let ((block (ir2-block-block 2block)))
(when (eq (block-info block) 2block) (when (eq (block-info block) 2block)
...@@ -186,7 +196,8 @@ ...@@ -186,7 +196,8 @@
2block :block-start tlf-num 2block :block-start tlf-num
(ir2-block-%label 2block) (ir2-block-%label 2block)
(ir2-block-live-out 2block) (ir2-block-live-out 2block)
var-locs)) var-locs
nil))
(dolist (loc locations) (dolist (loc locations)
(dump-location-from-info loc tlf-num var-locs)) (dump-location-from-info loc tlf-num var-locs))
(undefined-value)) (undefined-value))
...@@ -263,7 +274,8 @@ ...@@ -263,7 +274,8 @@
;;; DEBUG-SOURCE-FOR-INFO -- Interface ;;; DEBUG-SOURCE-FOR-INFO -- Interface
;;; ;;;
;;; Return a list of DEBUG-SOURCE structures containing information derived ;;; Return a list of DEBUG-SOURCE structures containing information derived
;;; from Info. ;;; from Info. We always dump the Start-Positions, since it is too hard
;;; figure out whether we need them or not.
;;; ;;;
(defun debug-source-for-info (info) (defun debug-source-for-info (info)
(declare (type source-info info)) (declare (type source-info info))
...@@ -277,9 +289,8 @@ ...@@ -277,9 +289,8 @@
:compiled (source-info-start-time info) :compiled (source-info-start-time info)
:source-root (file-info-source-root x) :source-root (file-info-source-root x)
:start-positions :start-positions
(when (policy nil (>= debug 2)) (coerce-to-smallest-eltype
(coerce-to-smallest-eltype (file-info-positions x)))))
(file-info-positions x))))))
(cond ((pathnamep name) (cond ((pathnamep name)
(setf (debug-source-name res) name)) (setf (debug-source-name res) name))
(t (t
...@@ -297,9 +308,11 @@ ...@@ -297,9 +308,11 @@
;;; possible. ;;; possible.
;;; ;;;
(defun coerce-to-smallest-eltype (seq) (defun coerce-to-smallest-eltype (seq)
(declare (type sequence seq))
(let ((max 0)) (let ((max 0))
(declare (type (or index null) max))
(macrolet ((frob () (macrolet ((frob ()
'(if (and (integerp val) (>= val 0) max) '(if (and (typep val 'index) max)
(when (> val max) (when (> val max)
(setq max val)) (setq max val))
(setq max nil)))) (setq max nil))))
...@@ -339,7 +352,7 @@ ...@@ -339,7 +352,7 @@
;;; everywhere in that case. ;;; 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 index id)
(type clambda fun)) (type clambda fun))
(let* ((name (leaf-name var)) (let* ((name (leaf-name var))
(package (symbol-package name)) (package (symbol-package name))
...@@ -347,6 +360,7 @@ ...@@ -347,6 +360,7 @@
(save-tn (tn-save-tn tn)) (save-tn (tn-save-tn tn))
(kind (tn-kind tn)) (kind (tn-kind tn))
(flags 0)) (flags 0))
(declare (type index flags))
(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
...@@ -354,6 +368,8 @@ ...@@ -354,6 +368,8 @@
(when (and (or (eq kind :environment) (when (and (or (eq kind :environment)
(and (eq kind :debug-environment) (and (eq kind :debug-environment)
(null (basic-var-sets var)))) (null (basic-var-sets var))))
(not (gethash tn (ir2-component-spilled-tns
(component-info *compile-component*))))
(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
...@@ -408,7 +424,8 @@ ...@@ -408,7 +424,8 @@
(prev-name nil) (prev-name nil)
(id 0) (id 0)
(i 0)) (i 0))
(declare (type (or simple-string null) prev-name)) (declare (type (or simple-string null) prev-name)
(type index id i))
(dolist (x sorted) (dolist (x sorted)
(let* ((var (car x)) (let* ((var (car x))
(name (symbol-name (leaf-name var)))) (name (symbol-name (leaf-name var))))
...@@ -500,8 +517,7 @@ ...@@ -500,8 +517,7 @@
;;; ;;;
(defun debug-info-for-component (component) (defun debug-info-for-component (component)
(declare (type component component)) (declare (type component component))
(let ((level (cookie-debug *default-cookie*)) (let ((res (make-compiled-debug-info :name (component-name component)
(res (make-compiled-debug-info :name (component-name component)
:package (package-name *package*)))) :package (package-name *package*))))
(collect ((dfuns)) (collect ((dfuns))
(let ((var-locs (make-hash-table :test #'eq))) (let ((var-locs (make-hash-table :test #'eq)))
...@@ -529,7 +545,11 @@ ...@@ -529,7 +545,11 @@
:elsewhere-pc :elsewhere-pc
(label-position (label-position
(ir2-environment-elsewhere-start 2env))))) (ir2-environment-elsewhere-start 2env))))
(level (cookie-debug
(lexenv-cookie
(node-lexenv
(lambda-bind fun))))))
(when (>= level 1) (when (>= level 1)
(setf (compiled-debug-function-variables dfun) (setf (compiled-debug-function-variables dfun)
...@@ -567,6 +587,7 @@ ...@@ -567,6 +587,7 @@
(do ((i -1 (+ i 2)) (do ((i -1 (+ i 2))
(sorted sorted (cdr sorted))) (sorted sorted (cdr sorted)))
((= i len)) ((= i len))
(declare (fixnum i))
(let ((dfun (car sorted))) (let ((dfun (car sorted)))
(unless (minusp i) (unless (minusp i)
(setf (svref funs-vec i) (car dfun))) (setf (svref funs-vec i) (car dfun)))
......
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