X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=c8759f9f682b832baa747d0c3f3a01dc809cd3e0;hb=20748f2dd7965dcd1446a1cb27e5a5af18a0e5bb;hp=fe81a456458b227d96c6f6623b3015bccebbd32a;hpb=7fd2eb4b1bc68e8aaec233c4a39bdfc40225bda2;p=sbcl.git

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index fe81a45..c8759f9 100644
--- 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*))
 
-;;; 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*
@@ -49,15 +49,16 @@
     (: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))
-
-;;; *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))
 
-;;; 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*)
@@ -118,7 +119,7 @@
 	       (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))
@@ -169,15 +170,15 @@
 (defun check-function-stuff (functional)
   (ecase (functional-kind functional)
     (:external
-     (let ((fun (functional-entry-function functional)))
+     (let ((fun (functional-entry-fun functional)))
        (check-function-reached fun functional)
        (when (functional-kind fun)
 	 (barf "The function for XEP ~S has kind." functional))
-       (unless (eq (functional-entry-function fun) functional)
+       (unless (eq (functional-entry-fun fun) functional)
 	 (barf "bad back-pointer in function for XEP ~S" functional))))
     ((:let :mv-let :assignment)
      (check-function-reached (lambda-home functional) functional)
-     (when (functional-entry-function functional)
+     (when (functional-entry-fun functional)
        (barf "The LET ~S has entry function." functional))
      (unless (member functional (lambda-lets (lambda-home functional)))
        (barf "The LET ~S is not in LETs for HOME." functional))
@@ -187,8 +188,8 @@
      (when (lambda-lets functional)
        (barf "LETs in a LET: ~S" functional)))
     (:optional
-     (when (functional-entry-function functional)
-       (barf ":OPTIONAL ~S has an ENTRY-FUNCTION." functional))
+     (when (functional-entry-fun functional)
+       (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
      (let ((ef (lambda-optional-dispatch functional)))
        (check-function-reached ef functional)
        (unless (or (member functional (optional-dispatch-entry-points ef))
@@ -196,22 +197,20 @@
 		   (eq functional (optional-dispatch-main-entry ef)))
 	 (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
 	       functional ef))))
-    (:top-level
-     (unless (eq (functional-entry-function functional) functional)
-       (barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional)))
+    (:toplevel
+     (unless (eq (functional-entry-fun functional) functional)
+       (barf "The ENTRY-FUN in ~S isn't a self-pointer." functional)))
     ((nil :escape :cleanup)
-     (let ((ef (functional-entry-function functional)))
+     (let ((ef (functional-entry-fun functional)))
        (when ef
 	 (check-function-reached ef functional)
 	 (unless (eq (functional-kind ef) :external)
-	   (barf "The ENTRY-FUNCTION in ~S isn't an XEP: ~S."
-		 functional
-		 ef)))))
+	   (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef)))))
     (:deleted
      (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)
@@ -244,11 +243,11 @@
 
 (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)))
+	(let ((ef (functional-entry-fun fun)))
 	  (when (optional-dispatch-p ef)
 	    (observe-functional ef))))
       (observe-functional fun)
@@ -256,8 +255,8 @@
 	(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))
@@ -484,10 +483,10 @@
     (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)))
-			 :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
@@ -907,19 +906,12 @@
 (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
-     (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
-     (aver (eq (functional-kind leaf) :top-level-xep))
-     (format stream "TL-XEP ~S"
-	     (entry-info-name (leaf-info leaf))))))
+     (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))
@@ -934,7 +926,7 @@
     (component (component-head thing))
 #|    (cloop (loop-head thing))|#
     (integer (continuation-block (num-cont thing)))
-    (functional (node-block (lambda-bind (main-entry thing))))
+    (functional (lambda-block (main-entry thing)))
     (null (error "Bad thing: ~S." thing))
     (symbol (block-or-lose (gethash thing *free-functions*)))))
 
@@ -944,8 +936,8 @@
   (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)))