X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug-dump.lisp;h=35929ccb82bc5b11f71a3f747ddec80ac83171e1;hb=a8419eb994f3b59b70cfa12e1004711a830a43fa;hp=a286675cb8328ff7beef7b5805a54f3437cdf4b0;hpb=b66385e2031fc2cac17dd129df0af400beb48a22;p=sbcl.git diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index a286675..35929cc 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -250,25 +250,26 @@ ;;; Return DEBUG-SOURCE structure containing information derived from ;;; INFO. -(defun debug-source-for-info (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 - (debug-source-name res) (file-info-forms file-info))) - (pathname - (setf (debug-source-name res) - (make-file-info-namestring name file-info)))) - 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 @@ -323,6 +324,16 @@ (make-sc-offset (sc-number (tn-sc 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 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and @@ -338,7 +349,8 @@ (let* ((name (leaf-debug-name var)) (save-tn (and tn (tn-save-tn tn))) (kind (and tn (tn-kind tn))) - (flags 0)) + (flags 0) + (info (lambda-var-arg-info var))) (declare (type index flags)) (when minimal (setq flags (logior flags compiled-debug-var-minimal-p)) @@ -349,12 +361,18 @@ (null (basic-var-sets var)))) (not (gethash tn (ir2-component-spilled-tns (component-info *component-being-compiled*)))) - (eq (lambda-var-home var) fun)) + (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) @@ -410,8 +428,8 @@ (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)) + (setf (gethash var var-locs) i) + (incf i))) (coerce buffer 'simple-vector)))) ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of @@ -450,27 +468,36 @@ (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))))))) + (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))))) @@ -511,8 +538,9 @@ (level (if #!+sb-dyncount *collect-dynamic-statistics* #!-sb-dyncount nil (max actual-level 2) - actual-level))) - (cond ((zerop level)) + 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) @@ -526,7 +554,7 @@ (setf (compiled-debug-fun-arguments dfun) (compute-args fun var-locs)))) - (if (>= level 2) + (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)