X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=35929ccb82bc5b11f71a3f747ddec80ac83171e1;hb=54da325f13fb41669869aea688ae195426c0e231;hp=ef8169934a9e8ca0a65c23907d3190f8207fae08;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index ef81699..35929cc 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -20,13 +20,14 @@ (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. @@ -39,11 +40,11 @@ ;;; 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)) @@ -58,25 +59,25 @@ ;;; 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-vars (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. @@ -89,15 +90,15 @@ ;;; 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)))) @@ -109,25 +110,35 @@ (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 @@ -138,36 +149,36 @@ (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 - (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))))) + (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 (block-start-node 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)) @@ -177,23 +188,23 @@ (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 @@ -201,72 +212,64 @@ ;;; 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))) -;;; 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 @@ -278,40 +281,40 @@ (defun coerce-to-smallest-eltype (seq) (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))) + (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 (*))))))) + ,(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 (*))))))) ;;;; variables @@ -319,7 +322,17 @@ (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 @@ -332,35 +345,42 @@ ;;; 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)) + (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)) @@ -374,42 +394,42 @@ (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-var 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-VARS of @@ -427,10 +447,10 @@ (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)))) ;;;; arguments/returns @@ -446,31 +466,40 @@ (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)))) @@ -479,8 +508,8 @@ (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)))))) + (tn-sc-offset loc)) + (return-info-locations (tail-set-info (lambda-tail-set fun)))))) ;;;; debug functions @@ -488,9 +517,9 @@ (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)) @@ -505,40 +534,43 @@ (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))) - (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-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)))) - - (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))) + (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)) + (toplevel-p (eq :toplevel (compiled-debug-fun-kind dfun)))) + (cond ((or (zerop level) toplevel-p)) + ((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 (and (>= level 2) (not toplevel-p)) + (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))))))) + (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)) ;;;; full component dumping @@ -547,15 +579,15 @@ (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 @@ -563,20 +595,20 @@ (defun debug-info-for-component (component) (declare (type component component)) (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))) + (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)) + (compute-1-debug-fun lambda var-locs)) + dfuns)) (let* ((sorted (sort dfuns #'< :key #'car)) - (fun-map (compute-debug-fun-map sorted))) + (fun-map (compute-debug-fun-map sorted))) (make-compiled-debug-info :name (component-name component) - :fun-map fun-map)))) + :fun-map fun-map)))) ;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of ;;; BITS must be evenly divisible by eight. @@ -588,18 +620,18 @@ (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))