(in-package "SB!C")
-(file-comment
- "$Header$")
-
(deftype byte-buffer () '(vector (unsigned-byte 8)))
(defvar *byte-buffer*)
(declaim (type byte-buffer *byte-buffer*))
'(member :unknown-return :known-return :internal-error :non-local-exit
:block-start :call-site :single-value-return :non-local-entry))
-;;; The Location-Info structure holds the information what we need about
-;;; locations which code generation decided were "interesting".
+;;; The LOCATION-INFO structure holds the information what we need
+;;; about locations which code generation decided were "interesting".
(defstruct (location-info
- (:constructor make-location-info (kind label vop)))
+ (:constructor make-location-info (kind label vop))
+ (:copier nil))
;; The kind of location noted.
(kind nil :type location-kind)
;; The label pointing to the interesting code location.
;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
(vop nil :type vop))
-;;; Called during code generation in places where there is an "interesting"
-;;; location: some place where we are likely to end up in the debugger, and
-;;; thus want debug info.
+;;; This is called during code generation in places where there is an
+;;; "interesting" location: someplace where we are likely to end up
+;;; in the debugger, and thus want debug info.
(defun note-debug-location (vop label kind)
(declare (type vop vop) (type (or label null) label)
(type location-kind kind))
(list location)))
location))
-#!-sb-fluid (declaim (inline ir2-block-environment))
-(defun ir2-block-environment (2block)
+#!-sb-fluid (declaim (inline ir2-block-physenv))
+(defun ir2-block-physenv (2block)
(declare (type ir2-block 2block))
- (block-environment (ir2-block-block 2block)))
+ (block-physenv (ir2-block-block 2block)))
-;;; Given a local conflicts vector and an IR2 block to represent the set of
-;;; live TNs, and the Var-Locs hash-table representing the variables dumped,
-;;; compute a bit-vector representing the set of live variables. If the TN is
-;;; environment-live, we only mark it as live when it is in scope at Node.
+;;; Given a local conflicts vector and an IR2 block to represent the
+;;; set of live TNs, and the VAR-LOCS hash-table representing the
+;;; variables dumped, compute a bit-vector representing the set of
+;;; live variables. If the TN is environment-live, we only mark it as
+;;; live when it is in scope at NODE.
(defun compute-live-vars (live node block var-locs vop)
(declare (type ir2-block block) (type local-tn-bit-vector live)
(type hash-table var-locs) (type node node)
(when (and (lambda-var-p leaf)
(or (not (member (tn-kind tn)
'(:environment :debug-environment)))
- (rassoc leaf (lexenv-variables (node-lexenv node))))
+ (rassoc leaf (lexenv-vars (node-lexenv node))))
(or (null spilled)
(not (member tn spilled))))
(let ((num (gethash leaf var-locs)))
(defvar *previous-location*)
(declaim (type index *previous-location*))
-;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
-;;; code/source map and live info. If true, VOP is the VOP associated with
-;;; this location, for use in determining whether TNs are spilled.
+;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes
+;;; the code/source map and live info. If true, VOP is the VOP
+;;; associated with this location, for use in determining whether TNs
+;;; are spilled.
(defun dump-1-location (node block kind tlf-num label live var-locs vop)
(declare (type node node) (type ir2-block block)
(type local-tn-bit-vector live)
(type hash-table var-locs) (type (or vop null) vop))
(vector-push-extend
- (dpb (position-or-lose kind compiled-code-location-kinds)
+ (dpb (position-or-lose kind *compiled-code-location-kinds*)
compiled-code-location-kind-byte
0)
*byte-buffer*)
- (let ((loc (if (target-fixnump label) label (label-position label))))
+ (let ((loc (if (fixnump label) label (label-position label))))
(write-var-integer (- loc *previous-location*) *byte-buffer*)
(setq *previous-location* loc))
(values))
-;;; Extract context info from a Location-Info structure and use it to dump a
-;;; compiled code-location.
+;;; Extract context info from a Location-Info structure and use it to
+;;; dump a compiled code-location.
(defun dump-location-from-info (loc tlf-num var-locs)
(declare (type location-info loc) (type (or index null) tlf-num)
(type hash-table var-locs))
vop))
(values))
-;;; Scan all the blocks, determining if all locations are in the same TLF,
-;;; and returning it or NIL.
+;;; Scan all the blocks, determining if all locations are in the same
+;;; TLF, and returning it or NIL.
(defun find-tlf-number (fun)
(declare (type clambda fun))
(let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
(declare (type (or index null) res))
- (do-environment-ir2-blocks (2block (lambda-environment fun))
+ (do-physenv-ir2-blocks (2block (lambda-physenv fun))
(let ((block (ir2-block-block 2block)))
(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)
(dump-location-from-info loc tlf-num var-locs))
(values))
-;;; 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 environment env))
+;;; Dump the successors of Block, being careful not to fly into space
+;;; on weird successors.
+(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-environment (car succ)) env))))
+ (not (eq (block-physenv (car succ)) physenv))))
()
succ)))
(vector-push-extend
*byte-buffer*)
(let ((base (block-number
(node-block
- (lambda-bind (environment-function env))))))
+ (lambda-bind (physenv-lambda physenv))))))
(dolist (b valid-succ)
(write-var-integer
(the index (- (block-number b) base))
*byte-buffer*))))
(values))
-;;; Return a vector and an integer (or null) suitable for use as the BLOCKS
-;;; and TLF-NUMBER in Fun's debug-function. This requires two passes to
-;;; compute:
-;;; -- Scan all blocks, dumping the header and successors followed by all the
-;;; non-elsewhere locations.
-;;; -- Dump the elsewhere block header and all the elsewhere locations (if
-;;; any.)
+;;; Return a vector and an integer (or null) suitable for use as the
+;;; BLOCKS and TLF-NUMBER in FUN's DEBUG-FUN. This requires two
+;;; passes to compute:
+;;; -- Scan all blocks, dumping the header and successors followed
+;;; by all the non-elsewhere locations.
+;;; -- Dump the elsewhere block header and all the elsewhere
+;;; locations (if any.)
(defun compute-debug-blocks (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(setf (fill-pointer *byte-buffer*) 0)
(let ((*previous-location* 0)
(tlf-num (find-tlf-number fun))
- (env (lambda-environment fun))
+ (physenv (lambda-physenv fun))
(prev-locs nil)
(prev-block nil))
(collect ((elsewhere))
- (do-environment-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))
(values (copy-seq *byte-buffer*) tlf-num)))
\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 we need them or
-;;; not.
+;;; 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.
(defun debug-source-for-info (info)
(declare (type source-info info))
- (assert (not (source-info-current-file info)))
- (mapcar #'(lambda (x)
- (let ((res (make-debug-source
- :from :file
- :comment (file-info-comment x)
- :created (file-info-write-date x)
- :compiled (source-info-start-time info)
- :source-root (file-info-source-root x)
- :start-positions
- (unless (eq *byte-compile* 't)
- (coerce-to-smallest-eltype
- (file-info-positions x)))))
- (name (file-info-name x)))
- (etypecase name
- ((member :lisp)
- (setf (debug-source-from res) name)
- (setf (debug-source-name res)
- (coerce (file-info-forms x) 'simple-vector)))
- (pathname
- (let* ((untruename (file-info-untruename x))
- (dir (pathname-directory untruename)))
- (setf (debug-source-name res)
- (namestring
- (if (and dir (eq (first dir) :absolute))
- untruename
- name))))))
- res))
- (source-info-files info)))
+ (let* ((file-info (source-info-file-info info))
+ (res (make-debug-source
+ :from :file
+ :created (file-info-write-date file-info)
+ :compiled (source-info-start-time info)
+ :source-root (file-info-source-root file-info)
+ :start-positions (coerce-to-smallest-eltype
+ (file-info-positions file-info))))
+ (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)))
+ (pathname
+ (let* ((untruename (file-info-untruename file-info))
+ (dir (pathname-directory untruename)))
+ (setf (debug-source-name res)
+ (namestring
+ (if (and dir (eq (first dir) :absolute))
+ untruename
+ name))))))
+ (list res)))
+
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
-;;; possible. Ordinarily we coerce it to the smallest specialized vector
-;;; we can. However, we also have a special hack for cross-compiling at
-;;; bootstrap time, when arbitrarily-specialized aren't fully supported:
-;;; in that case, we coerce it only to a vector whose element size is an
-;;; integer multiple of output byte size.
+;;; possible. Ordinarily we coerce it to the smallest specialized
+;;; vector we can. However, we also have a special hack for
+;;; cross-compiling at bootstrap time, when arbitrarily-specialized
+;;; vectors aren't fully supported: in that case, we coerce it only to
+;;; 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 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)
- (setf maxoid x))
- (return-from coerce-to-smallest-eltype
- (coerce seq 'simple-vector)))))
+ (when (>= x maxoid)
+ (setf maxoid x))
+ (return-from coerce-to-smallest-eltype
+ (coerce seq 'simple-vector)))))
(if (listp seq)
- (dolist (i seq)
- (frob i))
- (dovector (i seq)
- (frob i)))
- (coerce seq `(simple-array (integer 0 ,maxoid) (*))))))
+ (dolist (i seq)
+ (frob i))
+ (dovector (i seq)
+ (frob i)))
+ (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
(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, 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)
+;;; 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-var (fun var tn id minimal buffer)
(declare (type lambda-var var) (type (or tn null) tn) (type index id)
(type clambda fun))
- (let* ((name (leaf-name var))
+ (let* ((name (leaf-debug-name var))
(save-tn (and tn (tn-save-tn tn)))
(kind (and tn (tn-kind tn)))
(flags 0))
(vector-push-extend id buffer)))
(if tn
(vector-push-extend (tn-sc-offset tn) buffer)
- (assert minimal))
+ (aver minimal))
(when save-tn
(vector-push-extend (tn-sc-offset save-tn) buffer)))
(values))
-;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of FUN.
-;;; LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a hashtable in which
-;;; we enter the translation from LAMBDA-VARS to the relative position of that
-;;; variable's location in the resulting vector.
-(defun compute-variables (fun level var-locs)
+;;; Return a vector suitable for use as the DEBUG-FUN-VARS
+;;; of FUN. LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a
+;;; hash table in which we enter the translation from LAMBDA-VARS to
+;;; the relative position of that variable's location in the resulting
+;;; vector.
+(defun compute-vars (fun level var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(collect ((vars))
(labels ((frob-leaf (leaf tn gensym-p)
- (let ((name (leaf-name leaf)))
+ (let ((name (leaf-debug-name leaf)))
(when (and name (leaf-refs leaf) (tn-offset tn)
(or gensym-p (symbol-package name)))
(vars (cons leaf tn)))))
(frob-leaf leaf (leaf-info leaf) gensym-p))))
(frob-lambda fun t)
(when (>= level 2)
- (dolist (x (ir2-environment-environment
- (environment-info (lambda-environment 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)))))
(frob-lambda let (= level 3)))))
(let ((sorted (sort (vars) #'string<
- :key #'(lambda (x)
- (symbol-name (leaf-name (car x))))))
+ :key (lambda (x)
+ (symbol-name (leaf-debug-name (car x))))))
(prev-name nil)
(id 0)
(i 0)
(type index id i))
(dolist (x sorted)
(let* ((var (car x))
- (name (symbol-name (leaf-name var))))
+ (name (symbol-name (leaf-debug-name var))))
(cond ((and prev-name (string= prev-name name))
(incf id))
(t
(setq id 0 prev-name name)))
- (dump-1-variable fun var (cdr x) id nil buffer)
+ (dump-1-var fun var (cdr x) id nil buffer)
(setf (gethash var var-locs) i))
(incf i))
(coerce buffer 'simple-vector))))
-;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of
+;;; Return a vector suitable for use as the DEBUG-FUN-VARS of
;;; FUN, representing the arguments to FUN in minimal variable format.
-(defun compute-minimal-variables (fun)
+(defun compute-minimal-vars (fun)
(declare (type clambda fun))
(let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
(dolist (var (lambda-vars fun))
- (dump-1-variable fun var (leaf-info var) 0 t buffer))
+ (dump-1-var fun var (leaf-info var) 0 t buffer))
(coerce buffer 'simple-vector)))
-;;; Return Var's relative position in the function's variables (determined
-;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
+;;; Return VAR's relative position in the function's variables (determined
+;;; from the VAR-LOCS hashtable). If VAR is deleted, then return DELETED.
(defun debug-location-for (var var-locs)
(declare (type lambda-var var) (type hash-table var-locs))
(let ((res (gethash var var-locs)))
(cond (res)
(t
- (assert (or (null (leaf-refs var))
- (not (tn-offset (leaf-info var)))))
+ (aver (or (null (leaf-refs var))
+ (not (tn-offset (leaf-info var)))))
'deleted))))
\f
;;;; arguments/returns
-;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-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)
+;;; ### This assumption breaks down in EPs other than the main-entry,
+;;; since they may or may not have supplied-p vars, etc.
+(defun compute-args (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(collect ((res))
(let ((od (lambda-optional-dispatch fun)))
(cond (info
(case (arg-info-kind info)
(:keyword
- (res (arg-info-keyword info)))
+ (res (arg-info-key info)))
(:rest
(res 'rest-arg))
(:more-context
(coerce-to-smallest-eltype (res))))
-;;; Return a vector of SC offsets describing Fun's return locations. (Must
-;;; be known values return...)
+;;; Return a vector of SC offsets describing FUN's return locations.
+;;; (Must be known values return...)
(defun compute-debug-returns (fun)
(coerce-to-smallest-eltype
- (mapcar #'(lambda (loc)
- (tn-sc-offset loc))
+ (mapcar (lambda (loc)
+ (tn-sc-offset loc))
(return-info-locations (tail-set-info (lambda-tail-set fun))))))
\f
;;;; debug functions
;;; Return a C-D-F structure with all the mandatory slots filled in.
(defun dfun-from-fun (fun)
(declare (type clambda fun))
- (let* ((2env (environment-info (lambda-environment fun)))
+ (let* ((2env (physenv-info (lambda-physenv fun)))
(dispatch (lambda-optional-dispatch fun))
(main-p (and dispatch
(eq fun (optional-dispatch-main-entry dispatch)))))
- (make-compiled-debug-function
- :name (cond ((leaf-name fun))
- ((let ((ef (functional-entry-function
- fun)))
- (and ef (leaf-name ef))))
- ((and main-p (leaf-name dispatch)))
- (t
- (component-name
- (block-component (node-block (lambda-bind fun))))))
+ (make-compiled-debug-fun
+ :name (leaf-debug-name fun)
:kind (if main-p nil (functional-kind fun))
- :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
- :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
- :start-pc (label-position (ir2-environment-environment-start 2env))
- :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
-
-;;; Return a complete C-D-F structure for Fun. This involves determining
-;;; the DEBUG-INFO level and filling in optional slots as appropriate.
-(defun compute-1-debug-function (fun var-locs)
+ :return-pc (tn-sc-offset (ir2-physenv-return-pc 2env))
+ :old-fp (tn-sc-offset (ir2-physenv-old-fp 2env))
+ :start-pc (label-position (ir2-physenv-environment-start 2env))
+ :elsewhere-pc (label-position (ir2-physenv-elsewhere-start 2env)))))
+
+;;; Return a complete C-D-F structure for FUN. This involves
+;;; determining the DEBUG-INFO level and filling in optional slots as
+;;; appropriate.
+(defun compute-1-debug-fun (fun var-locs)
(declare (type clambda fun) (type hash-table var-locs))
(let* ((dfun (dfun-from-fun fun))
- (actual-level
- (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
+ (actual-level (policy (lambda-bind fun) debug))
(level (if #!+sb-dyncount *collect-dynamic-statistics*
#!-sb-dyncount nil
(max actual-level 2)
(let ((od (lambda-optional-dispatch fun)))
(or (not od)
(not (eq (optional-dispatch-main-entry od) fun)))))
- (setf (compiled-debug-function-variables dfun)
- (compute-minimal-variables fun))
- (setf (compiled-debug-function-arguments dfun) :minimal))
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-minimal-vars fun))
+ (setf (compiled-debug-fun-arguments dfun) :minimal))
(t
- (setf (compiled-debug-function-variables dfun)
- (compute-variables fun level var-locs))
- (setf (compiled-debug-function-arguments dfun)
- (compute-arguments fun var-locs))))
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-vars fun level var-locs))
+ (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-function-tlf-number dfun) tlf-num)
- (setf (compiled-debug-function-blocks dfun) blocks)))
+ (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
+ (setf (compiled-debug-fun-blocks dfun) blocks)))
- (if (external-entry-point-p fun)
- (setf (compiled-debug-function-returns dfun) :standard)
+ (if (xep-p fun)
+ (setf (compiled-debug-fun-returns dfun) :standard)
(let ((info (tail-set-info (lambda-tail-set fun))))
(when info
(cond ((eq (return-info-kind info) :unknown)
- (setf (compiled-debug-function-returns dfun)
+ (setf (compiled-debug-fun-returns dfun)
:standard))
((/= level 0)
- (setf (compiled-debug-function-returns dfun)
+ (setf (compiled-debug-fun-returns dfun)
(compute-debug-returns fun)))))))
dfun))
\f
-;;;; minimal debug functions
-
-;;; Return true if Dfun can be represented as a minimal debug function.
-;;; Dfun is a cons (<start offset> . C-D-F).
-(defun debug-function-minimal-p (dfun)
- (declare (type cons dfun))
- (let ((dfun (cdr dfun)))
- (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
- (null (compiled-debug-function-blocks dfun)))))
-
-;;; Dump a packed binary representation of a Dfun into *byte-buffer*.
-;;; Prev-Start and Start are the byte offsets in the code where the previous
-;;; function started and where this one starts. Prev-Elsewhere is the previous
-;;; function's elsewhere PC.
-(defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
- (declare (type compiled-debug-function dfun)
- (type index prev-start start prev-elsewhere))
- (let* ((name (compiled-debug-function-name dfun))
- (setf-p (and (consp name) (eq (car name) 'setf)
- (consp (cdr name)) (symbolp (cadr name))))
- (base-name (if setf-p (cadr name) name))
- (pkg (when (symbolp base-name)
- (symbol-package base-name)))
- (name-rep
- (cond ((stringp base-name)
- minimal-debug-function-name-component)
- ((not pkg)
- minimal-debug-function-name-uninterned)
- ((eq pkg *package*)
- minimal-debug-function-name-symbol)
- (t
- minimal-debug-function-name-packaged))))
- (assert (or (atom name) setf-p))
- (let ((options 0))
- (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
- (setf (ldb minimal-debug-function-kind-byte options)
- (position-or-lose (compiled-debug-function-kind dfun)
- minimal-debug-function-kinds))
- (setf (ldb minimal-debug-function-returns-byte options)
- (etypecase (compiled-debug-function-returns dfun)
- ((member :standard) minimal-debug-function-returns-standard)
- ((member :fixed) minimal-debug-function-returns-fixed)
- (vector minimal-debug-function-returns-specified)))
- (vector-push-extend options *byte-buffer*))
-
- (let ((flags 0))
- (when setf-p
- (setq flags (logior flags minimal-debug-function-setf-bit)))
- (when (compiled-debug-function-nfp dfun)
- (setq flags (logior flags minimal-debug-function-nfp-bit)))
- (when (compiled-debug-function-variables dfun)
- (setq flags (logior flags minimal-debug-function-variables-bit)))
- (vector-push-extend flags *byte-buffer*))
-
- (when (eql name-rep minimal-debug-function-name-packaged)
- (write-var-string (package-name pkg) *byte-buffer*))
- (unless (stringp base-name)
- (write-var-string (symbol-name base-name) *byte-buffer*))
-
- (let ((vars (compiled-debug-function-variables dfun)))
- (when vars
- (let ((len (length vars)))
- (write-var-integer len *byte-buffer*)
- (dotimes (i len)
- (vector-push-extend (aref vars i) *byte-buffer*)))))
-
- (let ((returns (compiled-debug-function-returns dfun)))
- (when (vectorp returns)
- (let ((len (length returns)))
- (write-var-integer len *byte-buffer*)
- (dotimes (i len)
- (write-var-integer (aref returns i) *byte-buffer*)))))
-
- (write-var-integer (compiled-debug-function-return-pc dfun)
- *byte-buffer*)
- (write-var-integer (compiled-debug-function-old-fp dfun)
- *byte-buffer*)
- (when (compiled-debug-function-nfp dfun)
- (write-var-integer (compiled-debug-function-nfp dfun)
- *byte-buffer*))
- (write-var-integer (- start prev-start) *byte-buffer*)
- (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
- *byte-buffer*)
- (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
- prev-elsewhere)
- *byte-buffer*)))
-
-;;; Return a byte-vector holding all the debug functions for a component in
-;;; the packed binary minimal-debug-function format.
-(defun compute-minimal-debug-functions (dfuns)
- (declare (list dfuns))
- (setf (fill-pointer *byte-buffer*) 0)
- (let ((prev-start 0)
- (prev-elsewhere 0))
- (dolist (dfun dfuns)
- (let ((start (car dfun))
- (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
- (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
- (setq prev-start start prev-elsewhere elsewhere))))
- (copy-seq *byte-buffer*))
-\f
;;;; full component dumping
;;; Compute the full form (simple-vector) function map.
-(defun compute-debug-function-map (sorted)
+(defun compute-debug-fun-map (sorted)
(declare (list sorted))
(let* ((len (1- (* (length sorted) 2)))
(funs-vec (make-array len)))
;;; 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))
- ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code now that
- ;; we no longer use minimal-debug-function representation?
- (*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-function fun var-locs))))
- (let* ((sorted (sort (dfuns) #'< :key #'car))
- ;; FIXME: CMU CL had
- ;; (IF (EVERY #'DEBUG-FUNCTION-MINIMAL-P SORTED)
- ;; (COMPUTE-MINIMAL-DEBUG-FUNCTIONS SORTED)
- ;; (COMPUTE-DEBUG-FUNCTION-MAP SORTED))
- ;; here. We've gotten rid of the minimal-debug-function case in
- ;; SBCL because the minimal representation couldn't be made to
- ;; transform properly under package renaming. Now that that
- ;; case is gone, a lot of code is dead, and once everything is
- ;; known to work, the dead code should be deleted.
- (function-map (compute-debug-function-map sorted)))
- (make-compiled-debug-info :name (component-name component)
- :function-map function-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))))
\f
-;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of BITS
-;;; must be evenly divisible by eight.
+;;; 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))