(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
(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
(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)))
(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