X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=0dc56c39903007b878bf0453a666e7e2c0ede8eb;hb=16a6592367eec7c5e9da668ec42fd260e7705b0c;hp=bf9bfbb125a32631d2f2ba67e176833d045631b5;hpb=4bc9a2b01540f3a7cbf4499b4689b292fe406139;p=sbcl.git

diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index bf9bfbb..0dc56c3 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -141,11 +141,10 @@
 	(when (eq (block-info block) 2block)
 	  (unless (eql (source-path-tlf-number
 			(node-source-path
-			 (continuation-next
-			  (block-start block))))
+			 (block-start-node block)))
 		       res)
 	    (setq res nil)))
-	
+
 	(dolist (loc (ir2-block-locations 2block))
 	  (unless (eql (source-path-tlf-number
 			(node-source-path
@@ -163,7 +162,7 @@
       (write-var-integer (length locations) *byte-buffer*)
       (let ((2block (block-info block)))
 	(write-var-integer (+ (length locations) 1) *byte-buffer*)
-	(dump-1-location (continuation-next (block-start block))
+	(dump-1-location (block-start-node block)
 			 2block :block-start tlf-num
 			 (ir2-block-%label 2block)
 			 (ir2-block-live-out 2block)
@@ -238,10 +237,8 @@
 
     (values (copy-seq *byte-buffer*) tlf-num)))
 
-;;; Return a list of DEBUG-SOURCE structures containing information
-;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
-;;; dump the START-POSITIONS, since it is too hard figure out whether
-;;; we need them or not.
+;;; Return DEBUG-SOURCE structure containing information derived from
+;;; INFO. 
 (defun debug-source-for-info (info)
   (declare (type source-info info))
   (let* ((file-info (source-info-file-info info))
@@ -255,19 +252,25 @@
 	 (name (file-info-name file-info)))
     (etypecase name
       ((member :lisp)
-       (setf (debug-source-from res) name)
-       (setf (debug-source-name res)
-	     (coerce (file-info-forms file-info) 'simple-vector)))
+       (setf (debug-source-from res) name
+	     (debug-source-name res) (file-info-forms file-info)))
       (pathname
        (let* ((untruename (file-info-untruename file-info))
 	      (dir (pathname-directory untruename)))
 	 (setf (debug-source-name res)
+	       #+sb-xc-host
+	       (let ((src (position "src" dir :test #'string= :from-end t)))
+		 (if src
+		     (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+			     (subseq dir src) (pathname-name untruename))
+		     ;; FIXME: just output/stuff-groveled-from-headers.lisp
+		     (namestring untruename)))
+	       #-sb-xc-host
 	       (namestring
 		(if (and dir (eq (first dir) :absolute))
 		    untruename
 		    name))))))
-    (list res)))
-
+    res))
 
 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
 ;;; possible. Ordinarily we coerce it to the smallest specialized
@@ -277,13 +280,7 @@
 ;;; a vector whose element size is an integer multiple of output byte
 ;;; size.
 (defun coerce-to-smallest-eltype (seq)
-  (let ((maxoid ;; It's probably better to avoid (UNSIGNED-BYTE 0).
-	        #-sb-xc-host 1 
-		;; An initial value of 255 prevents us from
-		;; specializing the array to anything smaller than
-		;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's
-		;; portable specialized array output functions happy.
-		#+sb-xc-host 255))
+  (let ((maxoid 0))
     (flet ((frob (x)
 	     (if (typep x 'unsigned-byte)
 		 (when (>= x maxoid)
@@ -295,18 +292,29 @@
 	    (frob i))
 	  (dovector (i seq)
 	    (frob i)))
-      (let ((specializer `(unsigned-byte ,(integer-length maxoid))))
+      (let ((specializer `(unsigned-byte
+			   ,(etypecase maxoid
+			      ((unsigned-byte 8) 8)
+			      ((unsigned-byte 16) 16)
+			      ((unsigned-byte 32) 32)))))
 	;; cross-compilers beware! It would be possible for the
-	;; upgraded-array-element-type of (UNSIGNED-BYTE 15) to be
-	;; (SIGNED-BYTE 16), and this is completely valid by
-	;; ANSI. However, the cross-compiler doesn't know how to dump
-	;; SIGNED-BYTE arrays, so better make it break now if it ever
-	;; will:
+	;; upgraded-array-element-type of (UNSIGNED-BYTE 16) to be
+	;; (SIGNED-BYTE 17) or (UNSIGNED-BYTE 23), and this is
+	;; completely valid by ANSI.  However, the cross-compiler
+	;; doesn't know how to dump (in practice) anything but the
+	;; above three specialized array types, so make it break here
+	;; if this is violated.
 	#+sb-xc-host
-	;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
-	;; worried about whether the host's implementation of arrays.
-	(aver (subtypep (upgraded-array-element-type specializer) 
-			'unsigned-byte))
+	(aver
+	 ;; not SB!XC:UPGRADED-ARRAY-ELEMENT-TYPE, because we are
+	 ;; worried about whether the host's implementation of arrays.
+	 (let ((uaet (upgraded-array-element-type specializer)))
+	   (dolist (et '((unsigned-byte 8)
+			 (unsigned-byte 16)
+			 (unsigned-byte 32))
+		    nil)
+	     (when (and (subtypep et uaet) (subtypep uaet et))
+	       (return t)))))
 	(coerce seq `(simple-array ,specializer (*)))))))
 
 ;;;; variables
@@ -520,10 +528,12 @@
 	   (setf (compiled-debug-fun-arguments dfun)
 		 (compute-args fun var-locs))))
 
-    (when (>= level 2)
-      (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
-	(setf (compiled-debug-fun-tlf-number dfun) tlf-num)
-	(setf (compiled-debug-fun-blocks dfun) blocks)))
+    (if (>= level 2)
+	(multiple-value-bind (blocks tlf-num)
+	    (compute-debug-blocks fun var-locs)
+	  (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
+	  (setf (compiled-debug-fun-blocks dfun) blocks))
+	(setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
 
     (if (xep-p fun)
 	(setf (compiled-debug-fun-returns dfun) :standard)