(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
(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)
\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))
;;; 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)
(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
\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)))
(setf (compiled-debug-fun-vars dfun)
(compute-vars fun level var-locs))
(setf (compiled-debug-fun-arguments dfun)
- (compute-arguments fun var-locs))))
+ (compute-args fun var-locs))))
- (when (>= level 2)
+ (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-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)