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

Mucho debugging of debug-location dumping. Check for the successors being the

component tail.  Dump the number of locations in each block.  Only dump
elsewhere block if there are some elsewhere locations.  Fixed uses of renamed
compiled-debug-variable constants.  Put back in support for DELETED arguments.
parent 59284178
Branches
Tags
No related merge requests found
...@@ -48,7 +48,7 @@ ...@@ -48,7 +48,7 @@
;;; location: some place where we are likely to end up in the debugger, and ;;; location: some place where we are likely to end up in the debugger, and
;;; thus want debug info. ;;; thus want debug info.
;;; ;;;
(defun note-vop-debug-location (vop label kind) (defun note-debug-location (vop label kind)
(declare (type vop vop) (type label label) (type location-kind kind)) (declare (type vop vop) (type label label) (type location-kind kind))
(setf (ir2-block-locations (vop-block vop)) (setf (ir2-block-locations (vop-block vop))
(nconc (ir2-block-locations (vop-block vop)) (nconc (ir2-block-locations (vop-block vop))
...@@ -73,7 +73,7 @@ ...@@ -73,7 +73,7 @@
(defun compute-live-vars (live block var-locs) (defun compute-live-vars (live block var-locs)
(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 hash-table var-locs))
(let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) #xFF) (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
:element-type 'bit :element-type 'bit
:initial-element 0))) :initial-element 0)))
(do-live-tns (tn live block) (do-live-tns (tn live block)
...@@ -101,7 +101,9 @@ ...@@ -101,7 +101,9 @@
(type hash-table var-locs)) (type hash-table var-locs))
(vector-push-extend (vector-push-extend
(dpb (position kind compiled-location-kinds) compiled-location-kind-byte 0) (dpb (position kind compiled-code-location-kinds)
compiled-code-location-kind-byte
0)
*byte-buffer*) *byte-buffer*)
(let ((loc (label-location label))) (let ((loc (label-location label)))
...@@ -146,7 +148,8 @@ ...@@ -146,7 +148,8 @@
;;; determining if all locations are in the same TLF. ;;; determining if all locations are in the same TLF.
;;; -- Scan all blocks, dumping the header and successors followed by all the ;;; -- Scan all blocks, dumping the header and successors followed by all the
;;; non-elsewhere locations. ;;; non-elsewhere locations.
;;; -- Dump the elsewhere block header and all the elsewhere locations. ;;; -- Dump the elsewhere block header and all the elsewhere locations (if
;;; any.)
;;; ;;;
(defun compute-debug-blocks (fun var-locs) (defun compute-debug-blocks (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs)) (declare (type clambda fun) (type hash-table var-locs))
...@@ -170,29 +173,42 @@ ...@@ -170,29 +173,42 @@
(setq tlf-num nil)))))) (setq tlf-num nil))))))
(collect ((elsewhere)) (collect ((elsewhere))
(do-environment-ir2-blocks (2block (lambda-environment fun)) (let ((tail (component-tail
(let ((block (ir2-block-block 2block))) (block-component (node-block (lambda-bind fun))))))
(when (eq (block-info block) 2block) (do-environment-ir2-blocks (2block (lambda-environment fun))
(let ((succ (block-succ block))) (let ((block (ir2-block-block 2block)))
(vector-push-extend (when (eq (block-info block) 2block)
(dpb (length succ) compiled-debug-block-nsucc-byte 0) (let ((succ (let ((s (block-succ block)))
*byte-buffer*) (if (eq (car s) tail)
(dolist (b succ) ()
(write-var-integer (block-flag b) *byte-buffer*))) s))))
(dump-1-location (continuation-next (block-start block)) (vector-push-extend
2block :block-start tlf-num (dpb (length succ) compiled-debug-block-nsucc-byte 0)
(ir2-block-%label 2block) *byte-buffer*)
(ir2-block-live-out 2block) (dolist (b succ)
var-locs)) (write-var-integer (block-flag b) *byte-buffer*)))
(dolist (loc (ir2-block-locations 2block)) (collect ((here))
(if (label-elsewhere-p (location-info-label loc)) (dolist (loc (ir2-block-locations 2block))
(elsewhere loc) (if (label-elsewhere-p (location-info-label loc))
(dump-location-from-info loc tlf-num var-locs))))) (elsewhere loc)
(here loc)))
(vector-push-extend compiler-debug-block-elsewhere-p *byte-buffer*) (write-var-integer (1+ (length (here))) *byte-buffer*)
(dolist (loc (elsewhere))
(dump-location-from-info loc tlf-num))) (dump-1-location (continuation-next (block-start block))
2block :block-start tlf-num
(ir2-block-%label 2block)
(ir2-block-live-out 2block)
var-locs)
(dolist (loc (here))
(dump-location-from-info loc tlf-num var-locs)))))))
(when (elsewhere)
(vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
(write-var-integer (length (elsewhere)) *byte-buffer*)
(dolist (loc (elsewhere))
(dump-location-from-info loc tlf-num var-locs))))
(values (copy-seq *byte-buffer*) tlf-num))) (values (copy-seq *byte-buffer*) tlf-num)))
...@@ -277,15 +293,15 @@ ...@@ -277,15 +293,15 @@
(save-tn (tn-save-tn tn)) (save-tn (tn-save-tn tn))
(flags 0)) (flags 0))
(unless package (unless package
(setq flags (logior flags compiled-location-uninterned))) (setq flags (logior flags compiled-debug-variable-uninterned)))
(when package-p (when package-p
(setq flags (logior flags compiled-location-packaged))) (setq flags (logior flags compiled-debug-variable-packaged)))
(when (eq (tn-kind tn) :environment) (when (eq (tn-kind tn) :environment)
(setq flags (logior flags compiled-location-environment-live))) (setq flags (logior flags compiled-debug-variable-environment-live)))
(when save-tn (when save-tn
(setq flags (logior flags compiled-location-save-loc-p))) (setq flags (logior flags compiled-debug-variable-save-loc-p)))
(unless (zerop id) (unless (zerop id)
(setq flags (logior flags compiled-location-id-p))) (setq flags (logior flags compiled-debug-variable-id-p)))
(vector-push-extend flags buffer) (vector-push-extend flags buffer)
(write-var-string (symbol-name name) buffer) (write-var-string (symbol-name name) buffer)
(when package-p (when package-p
...@@ -352,13 +368,15 @@ ...@@ -352,13 +368,15 @@
;;; DEBUG-LOCATION-FOR -- Internal ;;; DEBUG-LOCATION-FOR -- Internal
;;; ;;;
;;; Return Var's relative position in the function's variables (determined ;;; Return Var's relative position in the function's variables (determined
;;; from the Var-Locs hashtable.) ;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
;;; ;;;
(defun debug-location-for (var var-locs) (defun debug-location-for (var var-locs)
(declare (type lambda-var var) (type hash-table var-locs)) (declare (type lambda-var var) (type hash-table var-locs))
(let ((res (gethash var var-locs))) (let ((res (gethash var var-locs)))
(assert res () "No location for ~S?" var) (cond (res)
res)) (t
(assert (null (leaf-refs var)))
'deleted))))
;;;; Arguments/returns: ;;;; Arguments/returns:
...@@ -401,8 +419,8 @@ ...@@ -401,8 +419,8 @@
;;; COMPUTE-DEBUG-RETURNS -- Internal ;;; COMPUTE-DEBUG-RETURNS -- Internal
;;; ;;;
;;; Return a list of COMPILED-LOCATION structures for the fixed-values ;;; Return a vector of SC offsets describing Fun's return locations. (Must
;;; return from Fun. ;;; be known values return...)
;;; ;;;
(defun compute-debug-returns (fun) (defun compute-debug-returns (fun)
(coerce-to-smallest-eltype (coerce-to-smallest-eltype
...@@ -453,8 +471,8 @@ ...@@ -453,8 +471,8 @@
(when (>= level 2) (when (>= level 2)
(multiple-value-bind (blocks tlf-num) (multiple-value-bind (blocks tlf-num)
(compute-debug-blocks fun var-locs) (compute-debug-blocks fun var-locs)
(setf (debug-function-tlf-number dfun) tlf-num) (setf (compiled-debug-function-tlf-number dfun) tlf-num)
(setf (debug-function-blocks dfun) blocks))) (setf (compiled-debug-function-blocks dfun) blocks)))
(let ((tails (lambda-tail-set fun))) (let ((tails (lambda-tail-set fun)))
(when tails (when tails
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment