(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".
;;; 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 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))
(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
\f
;;; 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
- (let* ((untruename (file-info-untruename file-info))
- (dir (pathname-directory untruename)))
- (setf (debug-source-name res)
- #+sb-xc-host
- (let ((src (position "src" dir :test #'string= :from-end t)))
- (if src
- (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
- (subseq dir src) (pathname-name untruename))
- ;; FIXME: just output/stuff-groveled-from-headers.lisp
- (namestring untruename)))
- #-sb-xc-host
- (namestring
- (if (and dir (eq (first dir) :absolute))
- untruename
- name))))))
- 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
(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
(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))
- (unless tn
+ (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))
+ (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
+ (if (and tn (tn-offset tn))
(vector-push-extend (tn-sc-offset tn) buffer)
(aver minimal))
(when save-tn
(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
(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)))))
(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))
+ (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))
+ 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)
(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)