(defstruct (compiled-debug-var
(:include debug-var)
(:constructor make-compiled-debug-var
- (symbol id alive-p sc-offset save-sc-offset))
+ (symbol id alive-p sc-offset save-sc-offset info))
(:copier nil))
;; storage class and offset (unexported)
(sc-offset nil :type sb!c:sc-offset)
;; storage class and offset when saved somewhere
- (save-sc-offset nil :type (or sb!c:sc-offset null)))
+ (save-sc-offset nil :type (or sb!c:sc-offset null))
+ (info nil))
;;;; frames
;;; and retains roots to functions that might otherwise be collected.
(defun make-compiled-debug-fun (compiler-debug-fun component)
(let ((table *compiled-debug-funs*))
- (with-locked-hash-table (table)
+ (with-locked-system-table (table)
(or (gethash compiler-debug-fun table)
(setf (gethash compiler-debug-fun table)
(%make-compiled-debug-fun compiler-debug-fun component))))))
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
-#!+(or x86 x86-64)
+#!+gencgc
(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
(pointer system-area-pointer))
args (incf i) vars))
res))
(sb!c::more-arg
- ;; Just ignore the fact that the next two args are
- ;; the &MORE arg context and count, and act like they
- ;; are regular arguments.
- nil)
+ ;; The next two args are the &MORE arg context and count.
+ (push (list :more
+ (compiled-debug-fun-lambda-list-var
+ args (incf i) vars)
+ (compiled-debug-fun-lambda-list-var
+ args (incf i) vars))
+ res))
(t
;; &KEY arg
(push (list :keyword
(let* ((flags (geti))
(minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
(deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
+ (more-context-p (logtest sb!c::compiled-debug-var-more-context-p flags))
+ (more-count-p (logtest sb!c::compiled-debug-var-more-count-p flags))
(live (logtest sb!c::compiled-debug-var-environment-live
flags))
(save (logtest sb!c::compiled-debug-var-save-loc-p flags))
id
live
sc-offset
- save-sc-offset)
+ save-sc-offset
+ (cond (more-context-p :more-context)
+ (more-count-p :more-count)))
buffer)))))))
\f
;;;; CODE-LOCATIONs
;; unbound marker
(= val sb!vm:unbound-marker-widetag)
;; pointer
- #!+(or x86 x86-64)
+ #!+gencgc
(not (zerop (valid-lisp-pointer-p (int-sap val))))
;; FIXME: There is no fundamental reason not to use the above
;; function on other platforms as well, but I didn't have
;; others available while doing this. --NS 2007-06-21
- #!-(or x86 x86-64)
+ #!-gencgc
(and (logbitp 0 val)
(or (< sb!vm:read-only-space-start val
(* sb!vm:*read-only-space-free-pointer*
;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
;;; live-set information has been cached in the code-location.
(defun debug-var-validity (debug-var basic-code-location)
- (etypecase debug-var
- (compiled-debug-var
- (compiled-debug-var-validity debug-var basic-code-location))
- ;; (There used to be more cases back before sbcl-0.7.0, when
- ;; we did special tricks to debug the IR1 interpreter.)
- ))
+ (compiled-debug-var-validity debug-var basic-code-location))
+
+(defun debug-var-info (debug-var)
+ (compiled-debug-var-info debug-var))
;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
;;; For safety, make sure basic-code-location is what we think.
(defun preprocess-for-eval (form loc)
(declare (type code-location loc))
(let ((n-frame (gensym))
- (fun (code-location-debug-fun loc)))
+ (fun (code-location-debug-fun loc))
+ (more-context nil)
+ (more-count nil))
(unless (debug-var-info-available fun)
(debug-signal 'no-debug-vars :debug-fun fun))
(sb!int:collect ((binds)
(do-debug-fun-vars (var fun)
(let ((validity (debug-var-validity var loc)))
(unless (eq validity :invalid)
+ (case (debug-var-info var)
+ (:more-context
+ (setf more-context var))
+ (:more-count
+ (setf more-count var)))
(let* ((sym (debug-var-symbol var))
(found (assoc sym (binds))))
(if found
(setf (second found) :ambiguous)
(binds (list sym validity var)))))))
+ (when (and more-context more-count)
+ (let ((more (assoc 'sb!debug::more (binds))))
+ (if more
+ (setf (second more) :ambiguous)
+ (binds (list 'sb!debug::more :more more-context more-count)))))
(dolist (bind (binds))
(let ((name (first bind))
(var (third bind)))
(ecase (second bind)
(:valid
(specs `(,name (debug-var-value ',var ,n-frame))))
+ (:more
+ (let ((count-var (fourth bind)))
+ (specs `(,name (multiple-value-list
+ (sb!c:%more-arg-values (debug-var-value ',var ,n-frame)
+ 0
+ (debug-var-value ',count-var ,n-frame)))))))
(:unknown
(specs `(,name (debug-signal 'invalid-value
:debug-var ',var
(sb!alien:sap-alien signal-context (* os-context-t))))
(cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset))))
(compute-calling-frame cfp
- (sb!vm:context-pc scp)
+ ;; KLUDGE: This argument is ignored on
+ ;; x86oids in this scenario, but is
+ ;; declared to be a SAP.
+ #!+(or x86 x86-64) (sb!vm:context-pc scp)
+ #!-(or x86 x86-64) nil
nil)))
(defun handle-fun-end-breakpoint (offset component context)
#!-(or x86 x86-64)
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
sb!vm:other-pointer-lowtag))))
- (set-header-data
- new-lra
- (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
- 1))
- (sb!vm:sanctify-for-execution code-object)
+ #!-(or gencgc ppc)
+ (progn
+ ;; Set the offset from the LRA to the enclosing component.
+ ;; This does not need to be done on GENCGC targets, as the
+ ;; pointer validation done in MAKE-LISP-OBJ requires that it
+ ;; already have been set before we get here. It does not
+ ;; need to be done on CHENEYGC PPC as it's easier to use the
+ ;; same fun_end_breakpoint_guts on both, including the LRA
+ ;; header.
+ (set-header-data
+ new-lra
+ (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
+ 1))
+ (sb!vm:sanctify-for-execution code-object))
(values new-lra code-object (sap- trap-loc src-start))))))
\f
;;;; miscellaneous
projects / sbcl.git / blobdiff