0.8.13.26:

[sbcl.git] / src / compiler / debug-dump.lisp

diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 8e264a9..9e3630a 100644 (file)
--- 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)
@@ -240,7 +239,7 @@
 \f
 ;;; 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
+;;; dump the START-POSITIONS, since it is too hard figure out whether
 ;;; we need them or not.
 (defun debug-source-for-info (info)
   (declare (type source-info info))
@@ -262,6 +261,14 @@
        (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
@@ -277,12 +284,7 @@
 ;;; a vector whose element size is an integer multiple of output byte
 ;;; size.
 (defun coerce-to-smallest-eltype (seq)
-  (let ((maxoid #-sb-xc-host 0
-               ;; 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)
@@ -294,7 +296,30 @@
            (frob i))
          (dovector (i seq)
            (frob i)))
-      (coerce seq `(simple-array (integer 0 ,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 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
+       (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 (*)))))))
 \f
 ;;;; variables
 
@@ -417,14 +442,14 @@
 \f
 ;;;; arguments/returns
 
-;;; Return a vector to be used as the
-;;; COMPILED-DEBUG-FUN-ARGUMENTS for Fun. If fun is the
-;;; MAIN-ENTRY for an optional dispatch, then look at the ARGLIST to
-;;; determine the syntax, otherwise pretend all arguments are fixed.
+;;; Return a vector to be used as the COMPILED-DEBUG-FUN-ARGS for FUN.
+;;; If FUN is the MAIN-ENTRY for an optional dispatch, then look at
+;;; the ARGLIST to determine the syntax, otherwise pretend all
+;;; arguments are fixed.
 ;;;
 ;;; ### This assumption breaks down in EPs other than the main-entry,
 ;;; since they may or may not have supplied-p vars, etc.
-(defun compute-arguments (fun var-locs)
+(defun compute-args (fun var-locs)
   (declare (type clambda fun) (type hash-table var-locs))
   (collect ((res))
     (let ((od (lambda-optional-dispatch fun)))
@@ -505,12 +530,14 @@
           (setf (compiled-debug-fun-vars dfun)
                 (compute-vars fun level var-locs))
           (setf (compiled-debug-fun-arguments dfun)
-                (compute-arguments 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)))
+                (compute-args fun var-locs))))
+
+    (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)