X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=93dc01643a316f856914ad043632cff5db269e0e;hb=7c406887c08477181e869b1b98142d99b52990ac;hp=ff31524d85a1239db8f38334355604aad97b8b74;hpb=7a7a5268d45a213d425228e87c9ecc9f79bd7858;p=sbcl.git diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index ff31524..93dc016 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -20,7 +20,8 @@ (deftype location-kind () '(member :unknown-return :known-return :internal-error :non-local-exit - :block-start :call-site :single-value-return :non-local-entry)) + :block-start :call-site :single-value-return :non-local-entry + :step-before-vop)) ;;; The LOCATION-INFO structure holds the information what we need ;;; about locations which code generation decided were "interesting". @@ -89,7 +90,7 @@ ;;; are spilled. (defun dump-1-location (node block kind tlf-num label live var-locs vop) (declare (type node node) (type ir2-block block) - (type local-tn-bit-vector live) + (type (or null local-tn-bit-vector) live) (type (or label index) label) (type location-kind kind) (type (or index null) tlf-num) (type hash-table var-locs) (type (or vop null) vop)) @@ -109,9 +110,19 @@ (write-var-integer (source-path-tlf-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 vop) - *byte-buffer*) - + (if live + (write-packed-bit-vector (compute-live-vars live node block var-locs vop) + *byte-buffer*) + (write-packed-bit-vector + (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7) + :initial-element 0 + :element-type 'bit) + *byte-buffer*)) + + (write-var-string (or (and (typep node 'combination) + (combination-step-info node)) + "") + *byte-buffer*) (values)) ;;; Extract context info from a Location-Info structure and use it to @@ -239,25 +250,25 @@ ;;; Return DEBUG-SOURCE structure containing information derived from ;;; INFO. -(defun debug-source-for-info (info) +(defun debug-source-for-info (info &key function) (declare (type source-info info)) - (let* ((file-info (source-info-file-info info)) - (res (make-debug-source - :from :file - :created (file-info-write-date file-info) - :compiled (source-info-start-time info) - :source-root (file-info-source-root file-info) - :start-positions (coerce-to-smallest-eltype - (file-info-positions file-info)))) - (name (file-info-name file-info))) - (etypecase name - ((member :lisp) - (setf (debug-source-from res) name - (debug-source-name res) (file-info-forms file-info))) - (pathname - (setf (debug-source-name res) - (make-file-info-namestring name file-info)))) - res)) + (let ((file-info (get-toplevelish-file-info info))) + (make-debug-source + :compiled (source-info-start-time info) + + :namestring (make-file-info-namestring + (if (pathnamep (file-info-name file-info)) + (file-info-name file-info)) + file-info) + :created (file-info-write-date file-info) + :source-root (file-info-source-root file-info) + :start-positions (coerce-to-smallest-eltype + (file-info-positions file-info)) + + :form (let ((direct-file-info (source-info-file-info info))) + (if (eq :lisp (file-info-name direct-file-info)) + (elt (file-info-forms direct-file-info) 0))) + :function function))) ;;; Given an arbitrary sequence, coerce it to an unsigned vector if ;;; possible. Ordinarily we coerce it to the smallest specialized @@ -312,6 +323,16 @@ (make-sc-offset (sc-number (tn-sc tn)) (tn-offset tn))) +(defun lambda-ancestor-p (maybe-ancestor maybe-descendant) + (declare (type clambda maybe-ancestor) + (type (or clambda null) maybe-descendant)) + (loop + (when (eq maybe-ancestor maybe-descendant) + (return t)) + (setf maybe-descendant (lambda-parent maybe-descendant)) + (when (null maybe-descendant) + (return nil)))) + ;;; Dump info to represent VAR's location being TN. ID is an integer ;;; that makes VAR's name unique in the function. BUFFER is the vector ;;; we stick the result in. If MINIMAL, we suppress name dumping, and @@ -331,14 +352,14 @@ (declare (type index flags)) (when minimal (setq flags (logior flags compiled-debug-var-minimal-p)) - (unless tn + (unless (and tn (tn-offset tn)) (setq flags (logior flags compiled-debug-var-deleted-p)))) (when (and (or (eq kind :environment) (and (eq kind :debug-environment) (null (basic-var-sets var)))) (not (gethash tn (ir2-component-spilled-tns (component-info *component-being-compiled*)))) - (eq (lambda-var-home var) fun)) + (lambda-ancestor-p (lambda-var-home var) fun)) (setq flags (logior flags compiled-debug-var-environment-live))) (when save-tn (setq flags (logior flags compiled-debug-var-save-loc-p))) @@ -349,7 +370,7 @@ (vector-push-extend name buffer) (unless (zerop id) (vector-push-extend id buffer))) - (if tn + (if (and tn (tn-offset tn)) (vector-push-extend (tn-sc-offset tn) buffer) (aver minimal)) (when save-tn @@ -399,8 +420,8 @@ (t (setq id 0 prev-name name))) (dump-1-var fun var (cdr x) id nil buffer) - (setf (gethash var var-locs) i)) - (incf i)) + (setf (gethash var var-locs) i) + (incf i))) (coerce buffer 'simple-vector)))) ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of