(deftype location-kind ()
'(member :unknown-return :known-return :internal-error :non-local-exit
- :block-start :call-site :single-value-return :non-local-entry))
+ :block-start :call-site :single-value-return :non-local-entry
+ :step-before-vop))
;;; 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))
- (:copier nil))
+ (: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.
;;; 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))
+ (type location-kind kind))
(let ((location (make-location-info kind label vop)))
(setf (ir2-block-locations (vop-block vop))
- (nconc (ir2-block-locations (vop-block vop))
- (list location)))
+ (nconc (ir2-block-locations (vop-block vop))
+ (list location)))
location))
#!-sb-fluid (declaim (inline ir2-block-physenv))
;;; 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)
- (type (or vop null) vop))
+ (type hash-table var-locs) (type node node)
+ (type (or vop null) vop))
(let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
- :element-type 'bit
- :initial-element 0))
- (spilled (gethash vop
- (ir2-component-spilled-vops
- (component-info *component-being-compiled*)))))
+ :element-type 'bit
+ :initial-element 0))
+ (spilled (gethash vop
+ (ir2-component-spilled-vops
+ (component-info *component-being-compiled*)))))
(do-live-tns (tn live block)
(let ((leaf (tn-leaf tn)))
- (when (and (lambda-var-p leaf)
- (or (not (member (tn-kind tn)
- '(:environment :debug-environment)))
- (rassoc leaf (lexenv-variables (node-lexenv node))))
- (or (null spilled)
- (not (member tn spilled))))
- (let ((num (gethash leaf var-locs)))
- (when num
- (setf (sbit res num) 1))))))
+ (when (and (lambda-var-p leaf)
+ (or (not (member (tn-kind tn)
+ '(:environment :debug-environment)))
+ (rassoc leaf (lexenv-vars (node-lexenv node))))
+ (or (null spilled)
+ (not (member tn spilled))))
+ (let ((num (gethash leaf var-locs)))
+ (when num
+ (setf (sbit res num) 1))))))
res))
;;; The PC for the location most recently dumped.
;;; 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 (or label index) label)
- (type location-kind kind) (type (or index null) tlf-num)
- (type hash-table var-locs) (type (or vop null) vop))
+ (type (or null local-tn-bit-vector) live)
+ (type (or label index) label)
+ (type location-kind kind) (type (or index null) tlf-num)
+ (type hash-table var-locs) (type (or vop null) vop))
(vector-push-extend
(dpb (position-or-lose kind *compiled-code-location-kinds*)
- compiled-code-location-kind-byte
- 0)
+ compiled-code-location-kind-byte
+ 0)
*byte-buffer*)
(let ((loc (if (fixnump label) label (label-position label))))
(write-var-integer (source-path-tlf-number path) *byte-buffer*))
(write-var-integer (source-path-form-number path) *byte-buffer*))
- (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
- *byte-buffer*)
-
+ (if live
+ (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
+ *byte-buffer*)
+ (write-packed-bit-vector
+ (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
+ :initial-element 0
+ :element-type 'bit)
+ *byte-buffer*))
+
+ (write-var-string (or (and (typep node 'combination)
+ (combination-step-info node))
+ "")
+ *byte-buffer*)
(values))
;;; 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))
+ (type hash-table var-locs))
(let ((vop (location-info-vop loc)))
(dump-1-location (vop-node vop)
- (vop-block vop)
- (location-info-kind loc)
- tlf-num
- (location-info-label loc)
- (vop-save-set vop)
- var-locs
- vop))
+ (vop-block vop)
+ (location-info-kind loc)
+ tlf-num
+ (location-info-label loc)
+ (vop-save-set vop)
+ var-locs
+ vop))
(values))
;;; Scan all the blocks, determining if all locations are in the same
(declare (type (or index null) res))
(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))))
- res)
- (setq res nil)))
-
- (dolist (loc (ir2-block-locations 2block))
- (unless (eql (source-path-tlf-number
- (node-source-path
- (vop-node (location-info-vop loc))))
- res)
- (setq res nil)))))
+ (when (eq (block-info block) 2block)
+ (unless (eql (source-path-tlf-number
+ (node-source-path
+ (block-start-node block)))
+ res)
+ (setq res nil)))
+
+ (dolist (loc (ir2-block-locations 2block))
+ (unless (eql (source-path-tlf-number
+ (node-source-path
+ (vop-node (location-info-vop loc))))
+ res)
+ (setq res nil)))))
res))
;;; Dump out the number of locations and the locations for Block.
(defun dump-block-locations (block locations tlf-num var-locs)
(declare (type cblock block) (list locations))
(if (and locations
- (eq (location-info-kind (first locations))
- :non-local-entry))
+ (eq (location-info-kind (first locations))
+ :non-local-entry))
(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))
- 2block :block-start tlf-num
- (ir2-block-%label 2block)
- (ir2-block-live-out 2block)
- var-locs
- nil)))
+ (write-var-integer (+ (length locations) 1) *byte-buffer*)
+ (dump-1-location (block-start-node block)
+ 2block :block-start tlf-num
+ (ir2-block-%label 2block)
+ (ir2-block-live-out 2block)
+ var-locs
+ nil)))
(dolist (loc locations)
(dump-location-from-info loc tlf-num var-locs))
(values))
(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)) physenv))))
- ()
- succ)))
+ (succ (block-succ block))
+ (valid-succ
+ (if (and succ
+ (or (eq (car succ) tail)
+ (not (eq (block-physenv (car succ)) physenv))))
+ ()
+ succ)))
(vector-push-extend
(dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
*byte-buffer*)
(let ((base (block-number
- (node-block
- (lambda-bind (physenv-lambda physenv))))))
+ (node-block
+ (lambda-bind (physenv-lambda physenv))))))
(dolist (b valid-succ)
- (write-var-integer
- (the index (- (block-number b) base))
- *byte-buffer*))))
+ (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
;;; 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
+;;; -- 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))
- (physenv (lambda-physenv fun))
- (prev-locs nil)
- (prev-block nil))
+ (tlf-num (find-tlf-number fun))
+ (physenv (lambda-physenv fun))
+ (prev-locs nil)
+ (prev-block nil))
(collect ((elsewhere))
(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 physenv)))
-
- (collect ((here prev-locs))
- (dolist (loc (ir2-block-locations 2block))
- (if (label-elsewhere-p (location-info-label loc))
- (elsewhere loc)
- (here loc)))
- (setq prev-locs (here))))
+ (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 physenv)))
+
+ (collect ((here prev-locs))
+ (dolist (loc (ir2-block-locations 2block))
+ (if (label-elsewhere-p (location-info-label loc))
+ (elsewhere loc)
+ (here loc)))
+ (setq prev-locs (here))))
(dump-block-locations prev-block prev-locs tlf-num var-locs)
(when (elsewhere)
- (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
- (write-var-integer (length (elsewhere)) *byte-buffer*)
- (dolist (loc (elsewhere))
- (dump-location-from-info loc tlf-num var-locs))))
+ (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
+ (write-var-integer (length (elsewhere)) *byte-buffer*)
+ (dolist (loc (elsewhere))
+ (dump-location-from-info loc tlf-num var-locs))))
(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.
-(defun debug-source-for-info (info)
+;;; Return DEBUG-SOURCE structure containing information derived from
+;;; INFO.
+(defun debug-source-for-info (info &key function)
(declare (type source-info 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)))
-
+ (let ((file-info (get-toplevelish-file-info info)))
+ (make-debug-source
+ :compiled (source-info-start-time info)
+
+ :namestring (or *source-namestring*
+ (make-file-info-namestring
+ (if (pathnamep (file-info-name file-info))
+ (file-info-name file-info))
+ file-info))
+ :created (file-info-write-date file-info)
+ :source-root (file-info-source-root file-info)
+ :start-positions (coerce-to-smallest-eltype
+ (file-info-positions file-info))
+
+ :form (let ((direct-file-info (source-info-file-info info)))
+ (when (eq :lisp (file-info-name direct-file-info))
+ (elt (file-info-forms direct-file-info) 0)))
+ :function function)))
;;; Given an arbitrary sequence, coerce it to an unsigned vector if
;;; possible. Ordinarily we coerce it to the smallest specialized
;;; 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)
- (setf maxoid x))
- (return-from coerce-to-smallest-eltype
- (coerce seq 'simple-vector)))))
+ (if (typep x 'unsigned-byte)
+ (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
(defun tn-sc-offset (tn)
(declare (type tn tn))
(make-sc-offset (sc-number (tn-sc tn))
- (tn-offset tn)))
+ (tn-offset tn)))
+
+(defun lambda-ancestor-p (maybe-ancestor maybe-descendant)
+ (declare (type clambda maybe-ancestor)
+ (type (or clambda null) maybe-descendant))
+ (loop
+ (when (eq maybe-ancestor maybe-descendant)
+ (return t))
+ (setf maybe-descendant (lambda-parent maybe-descendant))
+ (when (null maybe-descendant)
+ (return nil))))
;;; 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
;;; 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)
+(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))
+ (type clambda fun))
(let* ((name (leaf-debug-name var))
- (save-tn (and tn (tn-save-tn tn)))
- (kind (and tn (tn-kind tn)))
- (flags 0))
+ (save-tn (and tn (tn-save-tn tn)))
+ (kind (and tn (tn-kind tn)))
+ (flags 0)
+ (info (lambda-var-arg-info var)))
(declare (type index flags))
(when minimal
(setq flags (logior flags compiled-debug-var-minimal-p))
- (unless tn
- (setq flags (logior flags compiled-debug-var-deleted-p))))
+ (unless (and tn (tn-offset tn))
+ (setq flags (logior flags compiled-debug-var-deleted-p))))
(when (and (or (eq kind :environment)
- (and (eq kind :debug-environment)
- (null (basic-var-sets var))))
- (not (gethash tn (ir2-component-spilled-tns
- (component-info *component-being-compiled*))))
- (eq (lambda-var-home var) fun))
+ (and (eq kind :debug-environment)
+ (null (basic-var-sets var))))
+ (not (gethash tn (ir2-component-spilled-tns
+ (component-info *component-being-compiled*))))
+ (lambda-ancestor-p (lambda-var-home var) fun))
(setq flags (logior flags compiled-debug-var-environment-live)))
(when save-tn
(setq flags (logior flags compiled-debug-var-save-loc-p)))
(unless (or (zerop id) minimal)
(setq flags (logior flags compiled-debug-var-id-p)))
+ (when info
+ (case (arg-info-kind info)
+ (:more-context
+ (setq flags (logior flags compiled-debug-var-more-context-p)))
+ (:more-count
+ (setq flags (logior flags compiled-debug-var-more-count-p)))))
(vector-push-extend flags buffer)
(unless minimal
(vector-push-extend name buffer)
(unless (zerop id)
- (vector-push-extend id buffer)))
- (if tn
- (vector-push-extend (tn-sc-offset tn) buffer)
- (aver minimal))
+ (vector-push-extend id buffer)))
+ (if (and tn (tn-offset tn))
+ (vector-push-extend (tn-sc-offset tn) buffer)
+ (aver minimal))
(when save-tn
(vector-push-extend (tn-sc-offset save-tn) buffer)))
(values))
-;;; Return a vector suitable for use as the DEBUG-FUN-VARIABLES
+;;; 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-variables (fun level var-locs)
+(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-debug-name leaf)))
- (when (and name (leaf-refs leaf) (tn-offset tn)
- (or gensym-p (symbol-package name)))
- (vars (cons leaf tn)))))
- (frob-lambda (x gensym-p)
- (dolist (leaf (lambda-vars x))
- (frob-leaf leaf (leaf-info leaf) gensym-p))))
+ (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-lambda (x gensym-p)
+ (dolist (leaf (lambda-vars x))
+ (frob-leaf leaf (leaf-info leaf) gensym-p))))
(frob-lambda fun t)
(when (>= level 2)
- (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)))))
-
- (dolist (let (lambda-lets fun))
- (frob-lambda let (= level 3)))))
+ (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)))))
+
+ (dolist (let (lambda-lets fun))
+ (frob-lambda let (= level 3)))))
(let ((sorted (sort (vars) #'string<
- :key #'(lambda (x)
- (symbol-name (leaf-debug-name (car x))))))
- (prev-name nil)
- (id 0)
- (i 0)
- (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+ :key (lambda (x)
+ (symbol-name (leaf-debug-name (car x))))))
+ (prev-name nil)
+ (id 0)
+ (i 0)
+ (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
(declare (type (or simple-string null) prev-name)
- (type index id i))
+ (type index id i))
(dolist (x sorted)
- (let* ((var (car x))
- (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)
- (setf (gethash var var-locs) i))
- (incf i))
+ (let* ((var (car x))
+ (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-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-FUN-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
(declare (type lambda-var var) (type hash-table var-locs))
(let ((res (gethash var var-locs)))
(cond (res)
- (t
- (aver (or (null (leaf-refs var))
- (not (tn-offset (leaf-info var)))))
- 'deleted))))
+ (t
+ (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-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)))
(if (and od (eq (optional-dispatch-main-entry od) fun))
- (let ((actual-vars (lambda-vars fun))
- (saw-optional nil))
- (dolist (arg (optional-dispatch-arglist od))
- (let ((info (lambda-var-arg-info arg))
- (actual (pop actual-vars)))
- (cond (info
- (case (arg-info-kind info)
- (:keyword
- (res (arg-info-key info)))
- (:rest
- (res 'rest-arg))
- (:more-context
- (res 'more-arg))
- (:optional
- (unless saw-optional
- (res 'optional-args)
- (setq saw-optional t))))
- (res (debug-location-for actual var-locs))
- (when (arg-info-supplied-p info)
- (res 'supplied-p)
- (res (debug-location-for (pop actual-vars) var-locs))))
- (t
- (res (debug-location-for actual var-locs)))))))
- (dolist (var (lambda-vars fun))
- (res (debug-location-for var var-locs)))))
+ (let ((actual-vars (lambda-vars fun))
+ (saw-optional nil))
+ (labels ((one-arg (arg)
+ (let ((info (lambda-var-arg-info arg))
+ (actual (pop actual-vars)))
+ (cond (info
+ (case (arg-info-kind info)
+ (:keyword
+ (res (arg-info-key info)))
+ (:rest
+ (let ((more (arg-info-default info)))
+ (cond ((and (consp more) (third more))
+ (one-arg (first (arg-info-default info)))
+ (one-arg (second (arg-info-default info)))
+ (return-from one-arg))
+ (more
+ (setf (arg-info-default info) t)))
+ (res 'rest-arg)))
+ (:more-context
+ (res 'more-arg))
+ (:optional
+ (unless saw-optional
+ (res 'optional-args)
+ (setq saw-optional t))))
+ (res (debug-location-for actual var-locs))
+ (when (arg-info-supplied-p info)
+ (res 'supplied-p)
+ (res (debug-location-for (pop actual-vars) var-locs))))
+ (t
+ (res (debug-location-for actual var-locs)))))))
+ (dolist (arg (optional-dispatch-arglist od))
+ (one-arg arg))))
+ (dolist (var (lambda-vars fun))
+ (res (debug-location-for var var-locs)))))
(coerce-to-smallest-eltype (res))))
;;; (Must be known values return...)
(defun compute-debug-returns (fun)
(coerce-to-smallest-eltype
- (mapcar #'(lambda (loc)
- (tn-sc-offset loc))
- (return-info-locations (tail-set-info (lambda-tail-set fun))))))
+ (mapcar (lambda (loc)
+ (tn-sc-offset loc))
+ (return-info-locations (tail-set-info (lambda-tail-set fun))))))
\f
;;;; debug functions
(defun dfun-from-fun (fun)
(declare (type clambda fun))
(let* ((2env (physenv-info (lambda-physenv fun)))
- (dispatch (lambda-optional-dispatch fun))
- (main-p (and dispatch
- (eq fun (optional-dispatch-main-entry dispatch)))))
+ (dispatch (lambda-optional-dispatch fun))
+ (main-p (and dispatch
+ (eq fun (optional-dispatch-main-entry dispatch)))))
(make-compiled-debug-fun
:name (leaf-debug-name fun)
:kind (if main-p nil (functional-kind fun))
(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 (policy (lambda-bind fun) debug))
- (level (if #!+sb-dyncount *collect-dynamic-statistics*
- #!-sb-dyncount nil
- (max actual-level 2)
- actual-level)))
+ (actual-level (policy (lambda-bind fun) compute-debug-fun))
+ (level (if #!+sb-dyncount *collect-dynamic-statistics*
+ #!-sb-dyncount nil
+ (max actual-level 2)
+ actual-level)))
(cond ((zerop level))
- ((and (<= level 1)
- (let ((od (lambda-optional-dispatch fun)))
- (or (not od)
- (not (eq (optional-dispatch-main-entry od) fun)))))
- (setf (compiled-debug-fun-variables dfun)
- (compute-minimal-variables fun))
- (setf (compiled-debug-fun-arguments dfun) :minimal))
- (t
- (setf (compiled-debug-fun-variables dfun)
- (compute-variables 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)))
-
- (if (external-entry-point-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-fun-returns dfun)
- :standard))
- ((/= level 0)
- (setf (compiled-debug-fun-returns dfun)
- (compute-debug-returns fun)))))))
+ ((and (<= level 1)
+ (let ((od (lambda-optional-dispatch fun)))
+ (or (not od)
+ (not (eq (optional-dispatch-main-entry od) fun)))))
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-minimal-vars fun))
+ (setf (compiled-debug-fun-arguments dfun) :minimal))
+ (t
+ (setf (compiled-debug-fun-vars dfun)
+ (compute-vars fun level var-locs))
+ (setf (compiled-debug-fun-arguments dfun)
+ (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)
+ (let ((info (tail-set-info (lambda-tail-set fun))))
+ (when info
+ (cond ((eq (return-info-kind info) :unknown)
+ (setf (compiled-debug-fun-returns dfun)
+ :standard))
+ ((/= level 0)
+ (setf (compiled-debug-fun-returns dfun)
+ (compute-debug-returns fun)))))))
dfun))
\f
;;;; full component dumping
(defun compute-debug-fun-map (sorted)
(declare (list sorted))
(let* ((len (1- (* (length sorted) 2)))
- (funs-vec (make-array len)))
+ (funs-vec (make-array len)))
(do ((i -1 (+ i 2))
- (sorted sorted (cdr sorted)))
- ((= i len))
+ (sorted sorted (cdr sorted)))
+ ((= i len))
(declare (fixnum i))
(let ((dfun (car sorted)))
- (unless (minusp i)
- (setf (svref funs-vec i) (car dfun)))
- (setf (svref funs-vec (1+ i)) (cdr dfun))))
+ (unless (minusp i)
+ (setf (svref funs-vec i) (car dfun)))
+ (setf (svref funs-vec (1+ i)) (cdr dfun))))
funs-vec))
;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
;;; 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 (lambda-block 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))))
\f
;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of
;;; BITS must be evenly divisible by eight.
(multiple-value-bind (initial step done)
(ecase *backend-byte-order*
- (:little-endian (values 0 1 8))
- (:big-endian (values 7 -1 -1)))
+ (:little-endian (values 0 1 8))
+ (:big-endian (values 7 -1 -1)))
(let ((shift initial)
- (byte 0))
+ (byte 0))
(dotimes (i (length bits))
- (let ((int (aref bits i)))
- (setf byte (logior byte (ash int shift)))
- (incf shift step))
- (when (= shift done)
- (vector-push-extend byte byte-buffer)
- (setf shift initial
- byte 0)))
+ (let ((int (aref bits i)))
+ (setf byte (logior byte (ash int shift)))
+ (incf shift step))
+ (when (= shift done)
+ (vector-push-extend byte byte-buffer)
+ (setf shift initial
+ byte 0)))
(unless (= shift initial)
- (vector-push-extend byte byte-buffer))))
+ (vector-push-extend byte byte-buffer))))
(values))
projects / sbcl.git / blobdiff