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

Merged non-descriptor changes: debug.lisp

 revision 1.1.1.4
 date: 90/04/12 23:48:28;  author: ram;  state: Exp;  lines added/del: 20/21
 Fixed pre-pack-tn-stats not to have to vars called COMPONENT.
 In TN consistency checking, check that the TN has a SC assigned.
 Changed stuff to be consistent with TN-ENVIRONMENT now that it returns an
 IR1 environment rather than an IR2 environment.
 Flushed old argument pointer stuff.
 Moved TN location printing into the VM dependent function
 LOCATION-PRINT-NAME.
 Changed TN-ref printing to print the now-implicit load-TNs.
 ----------------------------
 revision 1.1.1.3
 date: 90/04/08 17:55:26;  author: ram;  state: Exp;  lines added/del: 2/2
 old-cont -> old-fp
 ----------------------------
 revision 1.1.1.2
 date: 90/04/02 15:09:25;  author: ram;  state: Exp;  lines added/del: 13/6
 Added :COMPONENT TN support.
 ----------------------------
 revision 1.1.1.1
 date: 90/03/27 12:12:30;  author: ram;  state: Exp;  lines added/del: 1/3
 Use DO-ENVIRONMENT-IR2-BLOCKS now that the IR2-ENVIRONMENT-BLOCKS
 slot is gone.
parent d8b4d704
No related branches found
No related tags found
No related merge requests found
...@@ -724,7 +724,8 @@ ...@@ -724,7 +724,8 @@
(unused 0) (unused 0)
(const 0) (const 0)
(temps 0) (temps 0)
(environment 0)) (environment 0)
(comp 0))
(do-packed-tns (tn component) (do-packed-tns (tn component)
(let ((reads (tn-reads tn)) (let ((reads (tn-reads tn))
(writes (tn-writes tn))) (writes (tn-writes tn)))
...@@ -736,7 +737,9 @@ ...@@ -736,7 +737,9 @@
(incf wired)) (incf wired))
(unless (or (tn-reads tn) (tn-writes tn)) (unless (or (tn-reads tn) (tn-writes tn))
(incf unused)) (incf unused))
(cond ((eq (tn-kind tn) :environment) (cond ((eq (tn-kind tn) :component)
(incf comp))
((eq (tn-kind tn) :environment)
(incf environment)) (incf environment))
((tn-global-conflicts tn) ((tn-global-conflicts tn)
(incf global) (incf global)
...@@ -753,9 +756,9 @@ ...@@ -753,9 +756,9 @@
(incf const)) (incf const))
(format stream (format stream
"~%TNs: ~D local, ~D temps, ~D constant, ~D environment, ~D global.~@ "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@
Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%" Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%"
local temps const environment global wired unused local temps const environment comp global wired unused
(1+ (ir2-block-number (1+ (ir2-block-number
(block-info (block-next (component-head component))))) (block-info (block-next (component-head component)))))
confs)) confs))
...@@ -788,25 +791,29 @@ ...@@ -788,25 +791,29 @@
(unless (or (tn-reads tn) (tn-writes tn)) (unless (or (tn-reads tn) (tn-writes tn))
(barf "No references to ~S." tn)) (barf "No references to ~S." tn))
(unless (tn-sc tn) (barf "~S has no SC." tn))
(let ((conf (tn-global-conflicts tn)) (let ((conf (tn-global-conflicts tn))
(kind (tn-kind tn))) (kind (tn-kind tn)))
(cond (cond
((eq kind :component)
(unless (member tn (ir2-component-component-tns component))
(barf "~S not in Component-TNs for ~S." tn component)))
((eq kind :environment) ((eq kind :environment)
(let ((env (tn-environment tn))) (let ((env (tn-environment tn)))
(macrolet ((frob (refs) (macrolet ((frob (refs)
`(do ((ref ,refs (tn-ref-next ref))) `(do ((ref ,refs (tn-ref-next ref)))
((null ref)) ((null ref))
(unless (eq (environment-info (unless (eq (lambda-environment
(lambda-environment (block-lambda
(block-lambda (ir2-block-block
(ir2-block-block (vop-block (tn-ref-vop ref)))))
(vop-block (tn-ref-vop ref))))))
env) env)
(barf "~S not in TN-Environment for ~S." ref (barf "~S not in TN-Environment for ~S." ref
tn))))) tn)))))
(frob (tn-reads tn)) (frob (tn-reads tn))
(frob (tn-writes tn))) (frob (tn-writes tn)))
(unless (member tn (ir2-environment-live-tns env)) (unless (member tn (ir2-environment-live-tns (environment-info env)))
(barf "~S not in Live-TNs for ~S." tn env)) (barf "~S not in Live-TNs for ~S." tn env))
(when (or (tn-local tn) (tn-global-conflicts tn)) (when (or (tn-local tn) (tn-global-conflicts tn))
(barf ":Environment TN ~S has Local or Global-Conflicts." tn)))) (barf ":Environment TN ~S has Local or Global-Conflicts." tn))))
...@@ -894,8 +901,7 @@ ...@@ -894,8 +901,7 @@
(2env (environment-info env)) (2env (environment-info env))
(locs (ir2-environment-arg-locs 2env)) (locs (ir2-environment-arg-locs 2env))
(pc (ir2-environment-return-pc-pass 2env)) (pc (ir2-environment-return-pc-pass 2env))
(cont (ir2-environment-old-cont-pass 2env)) (fp (ir2-environment-old-fp-pass 2env))
(argp (ir2-environment-argument-pointer 2env))
(2block (block-info (2block (block-info
(node-block (node-block
(lambda-bind (lambda-bind
...@@ -908,8 +914,7 @@ ...@@ -908,8 +914,7 @@
(eq (tn-kind tn) :cached-constant) (eq (tn-kind tn) :cached-constant)
(member tn locs) (member tn locs)
(eq tn pc) (eq tn pc)
(eq tn cont) (eq tn fp))
(eq tn argp))
(barf "Strange TN live at head of ~S: ~S." env tn)))))) (barf "Strange TN live at head of ~S: ~S." env tn))))))
(undefined-value)) (undefined-value))
...@@ -1080,14 +1085,7 @@ ...@@ -1080,14 +1085,7 @@
(t (t
(format stream "t~D" (tn-id tn)))) (format stream "t~D" (tn-id tn))))
(when (and (tn-sc tn) (tn-offset tn)) (when (and (tn-sc tn) (tn-offset tn))
;; ### hack... (format stream "[~A]" (location-print-name tn)))))
(let ((sb (sb-name (sc-sb (tn-sc tn)))))
(if (eq sb 'registers)
(format stream "[~A]"
(svref '#(NL0 A0 NL1 A1 A3 A2 SP L0 L1 L2 L3 L4
BS CONT ENV PC)
(tn-offset tn)))
(format stream "[~A~D]" (char (string sb) 0) (tn-offset tn)))))))
;;; Print-Operands -- Internal ;;; Print-Operands -- Internal
...@@ -1100,7 +1098,14 @@ ...@@ -1100,7 +1098,14 @@
(do ((ref refs (tn-ref-across ref))) (do ((ref refs (tn-ref-across ref)))
((null ref)) ((null ref))
(format t " ") (format t " ")
(print-tn (tn-ref-tn ref)))) (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))))))
;;; Print-IR2-Block -- Internal ;;; Print-IR2-Block -- Internal
...@@ -1239,16 +1244,15 @@ ...@@ -1239,16 +1244,15 @@
;;; List-Conflicts -- Interface ;;; List-Conflicts -- Interface
;;; ;;;
;;; Return a list of a the TNs that conflict with TN.
;;;
(defun list-conflicts (tn) (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))) (assert (member (tn-kind tn) '(:normal :cached-constant :environment)))
(let ((confs (tn-global-conflicts tn))) (let ((confs (tn-global-conflicts tn)))
(cond ((eq (tn-kind tn) :environment) (cond ((eq (tn-kind tn) :environment)
(clrhash *list-conflicts-table*) (clrhash *list-conflicts-table*)
(do ((env-block (ir2-environment-blocks (tn-environment tn)) (do-environment-ir2-blocks (env-block (tn-environment tn))
(ir2-block-environment-next env-block)))
((null env-block))
(add-always-live-tns env-block tn) (add-always-live-tns env-block tn)
(add-all-local-tns env-block)) (add-all-local-tns env-block))
(listify-conflicts-table)) (listify-conflicts-table))
......
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