X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=fdfdd67b97ab39f2e94577de02aaa2faae5c6f5a;hb=c1aeac123df223746249567a9c0d2f656d1222cb;hp=a63d1796d783a4bfc7b43e4d9dad5fa930447cc0;hpb=1a6def3955b715472eb2c75b15660912b9f90173;p=sbcl.git

diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index a63d179..fdfdd67 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -175,14 +175,14 @@
 
 ;;; Dump the successors of Block, being careful not to fly into space
 ;;; on weird successors.
-(defun dump-block-successors (block env)
-  (declare (type cblock block) (type physenv env))
+(defun dump-block-successors (block physenv)
+  (declare (type cblock block) (type physenv physenv))
   (let* ((tail (component-tail (block-component block)))
 	 (succ (block-succ block))
 	 (valid-succ
 	  (if (and succ
 		   (or (eq (car succ) tail)
-		       (not (eq (block-physenv (car succ)) env))))
+		       (not (eq (block-physenv (car succ)) physenv))))
 	      ()
 	      succ)))
     (vector-push-extend
@@ -190,7 +190,7 @@
      *byte-buffer*)
     (let ((base (block-number
 		 (node-block
-		  (lambda-bind (physenv-function env))))))
+		  (lambda-bind (physenv-lambda physenv))))))
       (dolist (b valid-succ)
 	(write-var-integer
 	 (the index (- (block-number b) base))
@@ -209,17 +209,17 @@
   (setf (fill-pointer *byte-buffer*) 0)
   (let ((*previous-location* 0)
 	(tlf-num (find-tlf-number fun))
-	(env (lambda-physenv fun))
+	(physenv (lambda-physenv fun))
 	(prev-locs nil)
 	(prev-block nil))
     (collect ((elsewhere))
-      (do-physenv-ir2-blocks (2block env)
+      (do-physenv-ir2-blocks (2block physenv)
 	(let ((block (ir2-block-block 2block)))
 	  (when (eq (block-info block) 2block)
 	    (when prev-block
 	      (dump-block-locations prev-block prev-locs tlf-num var-locs))
 	    (setq prev-block block  prev-locs ())
-	    (dump-block-successors block env)))
+	    (dump-block-successors block physenv)))
 	
 	(collect ((here prev-locs))
 	  (dolist (loc (ir2-block-locations 2block))
@@ -304,13 +304,13 @@
   (make-sc-offset (sc-number (tn-sc tn))
 		  (tn-offset tn)))
 
-;;; 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 is true, we suppress name
-;;; dumping, and set the minimal flag.
+;;; 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
+;;; set the minimal flag.
 ;;;
-;;; The debug-var is only marked as always-live if the TN is
-;;; environment live and is an argument. If a :debug-environment TN,
+;;; The DEBUG-VAR is only marked as always-live if the TN is
+;;; environment live and is an argument. If a :DEBUG-ENVIRONMENT TN,
 ;;; then we also exclude set variables, since the variable is not
 ;;; guaranteed to be live everywhere in that case.
 (defun dump-1-variable (fun var tn id minimal buffer)
@@ -366,8 +366,7 @@
 		 (frob-leaf leaf (leaf-info leaf) gensym-p))))
       (frob-lambda fun t)
       (when (>= level 2)
-	(dolist (x (ir2-physenv-environment
-		    (physenv-info (lambda-physenv fun))))
+	(dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun))))
 	  (let ((thing (car x)))
 	    (when (lambda-var-p thing)
 	      (frob-leaf thing (cdr x) (= level 3)))))
@@ -546,26 +545,30 @@
 ;;; called after assembly so that source map information is available.
 (defun debug-info-for-component (component)
   (declare (type component component))
-  (collect ((dfuns))
-    (let ((var-locs (make-hash-table :test 'eq))
-	  (*byte-buffer* (make-array 10
-				     :element-type '(unsigned-byte 8)
-				     :fill-pointer 0
-				     :adjustable t)))
-      (dolist (fun (component-lambdas component))
-	(clrhash var-locs)
-	(dfuns (cons (label-position
-		      (block-label (node-block (lambda-bind fun))))
-		     (compute-1-debug-fun fun var-locs))))
-      (let* ((sorted (sort (dfuns) #'< :key #'car))
-	     (fun-map (compute-debug-fun-map sorted)))
-	(make-compiled-debug-info :name (component-name component)
-				  :fun-map fun-map)))))
+  (let ((dfuns nil)
+	(var-locs (make-hash-table :test 'eq))
+	(*byte-buffer* (make-array 10
+				   :element-type '(unsigned-byte 8)
+				   :fill-pointer 0
+				   :adjustable t)))
+    (dolist (lambda (component-lambdas component))
+      (clrhash var-locs)
+      (push (cons (label-position (block-label (lambda-block lambda)))
+		  (compute-1-debug-fun lambda var-locs))
+	    dfuns))
+    (let* ((sorted (sort dfuns #'< :key #'car))
+	   (fun-map (compute-debug-fun-map sorted)))
+      (make-compiled-debug-info :name (component-name component)
+				:fun-map fun-map))))
 
 ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
 ;;; BITS must be evenly divisible by eight.
 (defun write-packed-bit-vector (bits byte-buffer)
   (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
+
+  ;; Enforce constraint from CMU-CL-era comment.
+  (aver (zerop (mod (length bits) 8)))
+
   (multiple-value-bind (initial step done)
       (ecase *backend-byte-order*
 	(:little-endian (values 0  1  8))