projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.pre7.86.flaky7.1:
[sbcl.git]
/
src
/
compiler
/
debug.lisp
diff --git
a/src/compiler/debug.lisp
b/src/compiler/debug.lisp
index
2458152
..
fa8bbf3
100644
(file)
--- a/
src/compiler/debug.lisp
+++ b/
src/compiler/debug.lisp
@@
-39,8
+39,8
@@
One of :WARN, :ERROR or :NONE.")
(declaim (type (member :warn :error :none) *burp-action*))
One of :WARN, :ERROR or :NONE.")
(declaim (type (member :warn :error :none) *burp-action*))
-;;; Called when something funny but possibly correct is noticed. Otherwise
-;;; similar to Barf.
+;;; Called when something funny but possibly correct is noticed.
+;;; Otherwise similar to BARF.
(declaim (ftype (function (string &rest t) (values)) burp))
(defun burp (string &rest *args*)
(ecase *burp-action*
(declaim (ftype (function (string &rest t) (values)) burp))
(defun burp (string &rest *args*)
(ecase *burp-action*
@@
-49,15
+49,16
@@
(:none))
(values))
(:none))
(values))
-;;; *Seen-Blocks* is a hashtable with true values for all blocks which appear
-;;; in the DFO for one of the specified components.
+;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which
+;;; appear in the DFO for one of the specified components.
+;;;
+;;; *SEEN-FUNCTIONS* is similar, but records all the lambdas we
+;;; reached by recursing on top level functions.
(defvar *seen-blocks* (make-hash-table :test 'eq))
(defvar *seen-blocks* (make-hash-table :test 'eq))
-
-;;; *Seen-Functions* is similar, but records all the lambdas we reached by
-;;; recursing on top-level functions.
(defvar *seen-functions* (make-hash-table :test 'eq))
(defvar *seen-functions* (make-hash-table :test 'eq))
-;;; Barf if Node is in a block which wasn't reached during the graph walk.
+;;; Barf if NODE is in a block which wasn't reached during the graph
+;;; walk.
(declaim (ftype (function (node) (values)) check-node-reached))
(defun check-node-reached (node)
(unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
(declaim (ftype (function (node) (values)) check-node-reached))
(defun check-node-reached (node)
(unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
@@
-118,7
+119,7
@@
(unless (or (constant-p v)
(and (global-var-p v)
(member (global-var-kind v)
(unless (or (constant-p v)
(and (global-var-p v)
(member (global-var-kind v)
- '(:global :special :constant))))
+ '(:global :special))))
(barf "strange *FREE-VARIABLES* entry: ~S" v))
(dolist (n (leaf-refs v))
(check-node-reached n))
(barf "strange *FREE-VARIABLES* entry: ~S" v))
(dolist (n (leaf-refs v))
(check-node-reached n))
@@
-196,7
+197,7
@@
(eq functional (optional-dispatch-main-entry ef)))
(barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
functional ef))))
(eq functional (optional-dispatch-main-entry ef)))
(barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
functional ef))))
- (:top-level
+ (:toplevel
(unless (eq (functional-entry-function functional) functional)
(barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional)))
((nil :escape :cleanup)
(unless (eq (functional-entry-function functional) functional)
(barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional)))
((nil :escape :cleanup)
@@
-211,7
+212,7
@@
(return-from check-function-stuff)))
(case (functional-kind functional)
(return-from check-function-stuff)))
(case (functional-kind functional)
- ((nil :optional :external :top-level :escape :cleanup)
+ ((nil :optional :external :toplevel :escape :cleanup)
(when (lambda-p functional)
(dolist (fun (lambda-lets functional))
(unless (eq (lambda-home fun) functional)
(when (lambda-p functional)
(dolist (fun (lambda-lets functional))
(unless (eq (lambda-home fun) functional)
@@
-244,8
+245,8
@@
(defun check-function-consistency (components)
(dolist (c components)
(defun check-function-consistency (components)
(dolist (c components)
- (dolist (fun (component-new-functions c))
- (observe-functional fun))
+ (dolist (new-fun (component-new-funs c))
+ (observe-functional new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :external)
(let ((ef (functional-entry-function fun)))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :external)
(let ((ef (functional-entry-function fun)))
@@
-256,8
+257,8
@@
(observe-functional let))))
(dolist (c components)
(observe-functional let))))
(dolist (c components)
- (dolist (fun (component-new-functions c))
- (check-function-stuff fun))
+ (dolist (new-fun (component-new-funs c))
+ (check-function-stuff new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
(barf "deleted lambda ~S in Lambdas for ~S" fun c))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
(barf "deleted lambda ~S in Lambdas for ~S" fun c))
@@
-484,10
+485,10
@@
(ref
(let ((leaf (ref-leaf node)))
(when (functional-p leaf)
(ref
(let ((leaf (ref-leaf node)))
(when (functional-p leaf)
- (if (eq (functional-kind leaf) :top-level-xep)
+ (if (eq (functional-kind leaf) :toplevel-xep)
(unless (eq (component-kind (block-component (node-block node)))
(unless (eq (component-kind (block-component (node-block node)))
- :top-level)
- (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S"
+ :toplevel)
+ (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S"
node))
(check-function-reached leaf node)))))
(basic-combination
node))
(check-function-reached leaf node)))))
(basic-combination
@@
-825,16
+826,16
@@
;;; full call passing locations.
(defun check-environment-lifetimes (component)
(dolist (fun (component-lambdas component))
;;; full call passing locations.
(defun check-environment-lifetimes (component)
(dolist (fun (component-lambdas component))
- (let* ((env (lambda-environment fun))
- (2env (environment-info env))
+ (let* ((env (lambda-physenv fun))
+ (2env (physenv-info env))
(vars (lambda-vars fun))
(vars (lambda-vars fun))
- (closure (ir2-environment-environment 2env))
- (pc (ir2-environment-return-pc-pass 2env))
- (fp (ir2-environment-old-fp 2env))
+ (closure (ir2-physenv-environment 2env))
+ (pc (ir2-physenv-return-pc-pass 2env))
+ (fp (ir2-physenv-old-fp 2env))
(2block (block-info
(node-block
(lambda-bind
(2block (block-info
(node-block
(lambda-bind
- (environment-function env))))))
+ (physenv-function env))))))
(do ((conf (ir2-block-global-tns 2block)
(global-conflicts-next conf)))
((null conf))
(do ((conf (ir2-block-global-tns 2block)
(global-conflicts-next conf)))
((null conf))
@@
-903,26
+904,16
@@
(def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
(def-frob *label-id* *id-labels* *label-ids* label-id id-label))
(def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
(def-frob *label-id* *id-labels* *label-ids* label-id id-label))
-;;; Print out a terse one-line description of a leaf.
+;;; Print a terse one-line description of LEAF.
(defun print-leaf (leaf &optional (stream *standard-output*))
(declare (type leaf leaf) (type stream stream))
(etypecase leaf
(defun print-leaf (leaf &optional (stream *standard-output*))
(declare (type leaf leaf) (type stream stream))
(etypecase leaf
- (lambda-var (prin1 (leaf-name leaf) stream))
+ (lambda-var (prin1 (leaf-debug-name leaf) stream))
(constant (format stream "'~S" (constant-value leaf)))
(global-var
(constant (format stream "'~S" (constant-value leaf)))
(global-var
- (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf)))
- (clambda
- (format stream "lambda ~S ~S" (leaf-name leaf)
- (mapcar #'leaf-name (lambda-vars leaf))))
- (optional-dispatch
- (format stream "optional-dispatch ~S" (leaf-name leaf)))
+ (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf)))
(functional
(functional
- (aver (eq (functional-kind leaf) :top-level-xep))
- (format stream "TL-XEP ~S"
- (let ((info (leaf-info leaf)))
- (etypecase info
- (entry-info (entry-info-name info))
- (byte-lambda-info :byte-compiled-entry)))))))
+ (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf)))))
;;; Attempt to find a block given some thing that has to do with it.
(declaim (ftype (function (t) cblock) block-or-lose))
;;; Attempt to find a block given some thing that has to do with it.
(declaim (ftype (function (t) cblock) block-or-lose))
@@
-947,8
+938,8
@@
(format t " c~D" (cont-num cont))
(values))
(format t " c~D" (cont-num cont))
(values))
-;;; Print out the nodes in Block in a format oriented toward representing
-;;; what the code does.
+;;; Print out the nodes in BLOCK in a format oriented toward
+;;; representing what the code does.
(defun print-nodes (block)
(setq block (block-or-lose block))
(format t "~%block start c~D" (cont-num (block-start block)))
(defun print-nodes (block)
(setq block (block-or-lose block))
(format t "~%block start c~D" (cont-num (block-start block)))
@@
-1074,7
+1065,8
@@
(format t "~D: " number)
(print-vop vop)))
(format t "~D: " number)
(print-vop vop)))
-;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block.
+;;; This is like PRINT-NODES, but dumps the IR2 representation of the
+;;; code in BLOCK.
(defun print-vops (block)
(setq block (block-or-lose block))
(let ((2block (block-info block)))
(defun print-vops (block)
(setq block (block-or-lose block))
(let ((2block (block-info block)))
@@
-1090,8
+1082,8
@@
(print-ir2-block block))
(values))
(print-ir2-block block))
(values))
-;;; Do a Print-Nodes on Block and all blocks reachable from it by successor
-;;; links.
+;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by
+;;; successor links.
(defun print-blocks (block)
(setq block (block-or-lose block))
(do-blocks (block (block-component block) :both)
(defun print-blocks (block)
(setq block (block-or-lose block))
(do-blocks (block (block-component block) :both)
@@
-1106,7
+1098,7
@@
(walk block))
(values))
(walk block))
(values))
-;;; Print all blocks in Block's component in DFO.
+;;; Print all blocks in BLOCK's component in DFO.
(defun print-all-blocks (thing)
(do-blocks (block (block-component (block-or-lose thing)))
(handler-case (print-nodes block)
(defun print-all-blocks (thing)
(do-blocks (block (block-component (block-or-lose thing)))
(handler-case (print-nodes block)
@@
-1116,7
+1108,7
@@
(defvar *list-conflicts-table* (make-hash-table :test 'eq))
(defvar *list-conflicts-table* (make-hash-table :test 'eq))
-;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when
+;;; Add all ALWAYS-LIVE TNs in Block to the conflicts. TN is ignored when
;;; it appears in the global conflicts.
(defun add-always-live-tns (block tn)
(declare (type ir2-block block) (type tn tn))
;;; it appears in the global conflicts.
(defun add-always-live-tns (block tn)
(declare (type ir2-block block) (type tn tn))