diff --git a/compiler/debug.lisp b/compiler/debug.lisp index 3ce3036ee87de25d1b10a2a876d8328719507719..4f1e166cab6c897a5c8dcdbee4b40c068d87bc2a 100644 --- a/compiler/debug.lisp +++ b/compiler/debug.lisp @@ -733,10 +733,10 @@ (incf unused)) (cond ((eq (tn-kind tn) :component) (incf comp)) - ((eq (tn-kind tn) :environment) - (incf environment)) ((tn-global-conflicts tn) - (incf global) + (case (tn-kind tn) + ((:environment :debug-environment) (incf environment)) + (t (incf global))) (do ((conf (tn-global-conflicts tn) (global-conflicts-tn-next conf))) ((null conf)) @@ -795,23 +795,6 @@ (unless (member tn (ir2-component-component-tns (component-info component))) (barf "~S not in Component-TNs for ~S." tn component))) - ((eq kind :environment) - (let ((env (tn-environment tn))) - (macrolet ((frob (refs) - `(do ((ref ,refs (tn-ref-next ref))) - ((null ref)) - (unless (eq (block-environment - (ir2-block-block - (vop-block (tn-ref-vop ref)))) - env) - (barf "~S not in TN-Environment for ~S." ref - tn))))) - (frob (tn-reads tn)) - (frob (tn-writes tn))) - (unless (member tn (ir2-environment-live-tns (environment-info env))) - (barf "~S not in Live-TNs for ~S." tn env)) - (when (or (tn-local tn) (tn-global-conflicts tn)) - (barf ":Environment TN ~S has Local or Global-Conflicts." tn)))) (conf (do ((conf conf (global-conflicts-tn-next conf)) (prev nil conf)) @@ -832,7 +815,7 @@ (unless (> (ir2-block-number (global-conflicts-block conf)) (ir2-block-number (global-conflicts-block prev))) (barf "~S and ~S out of order." prev conf))))) - ((eq (tn-kind tn) :constant)) + ((member (tn-kind tn) '(:constant :specified-save))) (t (let ((local (tn-local tn))) (unless local @@ -894,9 +877,10 @@ (dolist (fun (component-lambdas component)) (let* ((env (lambda-environment fun)) (2env (environment-info env)) - (locs (ir2-environment-arg-locs 2env)) + (vars (lambda-vars fun)) + (closure (ir2-environment-environment 2env)) (pc (ir2-environment-return-pc-pass 2env)) - (fp (ir2-environment-old-fp-pass 2env)) + (fp (ir2-environment-old-fp 2env)) (2block (block-info (node-block (lambda-bind @@ -906,10 +890,13 @@ ((null conf)) (let ((tn (global-conflicts-tn conf))) (unless (or (eq (global-conflicts-kind conf) :write) - (eq (tn-kind tn) :cached-constant) - (member tn locs) (eq tn pc) - (eq tn fp)) + (eq tn fp) + (and (external-entry-point-p fun) + (tn-offset tn)) + (member (tn-kind tn) '(:environment :debug-environment)) + (member tn vars :key #'leaf-info) + (member tn closure :key #'cdr)) (barf "Strange TN live at head of ~S: ~S." env tn)))))) (undefined-value)) @@ -1080,12 +1067,14 @@ (declare (type tn tn)) (let ((leaf (tn-leaf tn))) (cond (leaf - (print-leaf leaf stream) - (format stream "!~D" (tn-id tn))) + (xp::princ (with-output-to-string (stream) + (print-leaf leaf stream)) + stream) + (xp::format stream "!~D" (tn-id tn))) (t - (format stream "t~D" (tn-id tn)))) + (xp::format stream "t~D" (tn-id tn)))) (when (and (tn-sc tn) (tn-offset tn)) - (format stream "[~A]" (location-print-name tn))))) + (xp::format stream "[~A]" (location-print-name tn))))) ;;; Print-Operands -- Internal @@ -1095,18 +1084,42 @@ ;;; (defun print-operands (refs) (declare (type (or tn-ref null) refs)) - (do ((ref refs (tn-ref-across ref))) - ((null ref)) - (format t " ") - (let ((tn (tn-ref-tn ref)) - (ltn (tn-ref-load-tn ref))) - (cond ((not ltn) - (print-tn tn)) - (t - (print-tn tn) - (write-char (if (tn-ref-write-p ref) #\< #\>)) - (print-tn ltn)))))) - + (xp:within-logical-block (nil nil) + (do ((ref refs (tn-ref-across ref))) + ((null ref)) + (let ((tn (tn-ref-tn ref)) + (ltn (tn-ref-load-tn ref))) + (cond ((not ltn) + (print-tn tn)) + (t + (print-tn tn) + (xp::princ (if (tn-ref-write-p ref) #\< #\>)) + (print-tn ltn))) + (xp::princ #\space) + (xp:conditional-newline :fill))))) + + +;;; Print-Vop -- internal +;;; +;;; Print the vop on a single line. +;;; +(defun print-vop (vop) + (xp:within-logical-block (nil nil) + (xp::princ (vop-info-name (vop-info vop))) + (xp::princ #\space) + (xp:logical-block-indent :current 0) + (print-operands (vop-args vop)) + (xp:conditional-newline :linear) + (when (vop-codegen-info vop) + (xp::princ (with-output-to-string (stream) + (let ((*print-level* 1) + (*print-length* 3)) + (format stream "{~{~S~^ ~}} " (vop-codegen-info vop))))) + (xp:conditional-newline :linear)) + (when (vop-results vop) + (xp::princ "=> ") + (print-operands (vop-results vop)))) + (xp::terpri)) ;;; Print-IR2-Block -- Internal ;;; @@ -1128,16 +1141,8 @@ (vop-next vop)) (number 0 (1+ number))) ((null vop)) - (format t "~D: ~A" number (vop-info-name (vop-info vop))) - (print-operands (vop-args vop)) - (when (vop-codegen-info vop) - (let ((*print-level* 1) - (*print-length* 3)) - (format t " {~{~S~^ ~}}" (vop-codegen-info vop)))) - (when (vop-results vop) - (format t " =>") - (print-operands (vop-results vop))) - (terpri))) + (format t "~D: " number) + (print-vop vop))) ;;; Print-VOPs -- Interface @@ -1244,17 +1249,10 @@ ;;; (defun list-conflicts (tn) "Return a list of a the TNs that conflict with TN. Sort of, kind of. For - debugging use only. Probably doesn't work on :COMPONENT and :ENVIRONMENT - TNs." - (assert (member (tn-kind tn) '(:normal :cached-constant :environment))) + debugging use only. Probably doesn't work on :COMPONENT TNs." + (assert (member (tn-kind tn) '(:normal :environment :debug-environment))) (let ((confs (tn-global-conflicts tn))) - (cond ((eq (tn-kind tn) :environment) - (clrhash *list-conflicts-table*) - (do-environment-ir2-blocks (env-block (tn-environment tn)) - (add-always-live-tns env-block tn) - (add-all-local-tns env-block)) - (listify-conflicts-table)) - (confs + (cond (confs (clrhash *list-conflicts-table*) (do ((conf confs (global-conflicts-tn-next conf))) ((null conf))