X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=f0e34f8a7e026bae84a68093300b72477d3b81eb;hb=c2404a2f430ecf57897a795202625dff4764c18d;hp=63b899b61a1c68a5613572b0a8a68992817a560a;hpb=2dbee6e782b54f8780933790d61a24cdb67b8d04;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 63b899b..f0e34f8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -205,12 +205,13 @@ (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 @@ -309,7 +310,7 @@ ;;; 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)))))) @@ -536,7 +537,7 @@ (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)) @@ -1409,10 +1410,13 @@ register." 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 @@ -1633,6 +1637,8 @@ register." (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)) @@ -1647,7 +1653,9 @@ register." id live sc-offset - save-sc-offset) + save-sc-offset + (cond (more-context-p :more-context) + (more-count-p :more-count))) buffer))))))) ;;;; CODE-LOCATIONs @@ -1970,12 +1978,12 @@ register." ;; 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* @@ -2371,12 +2379,10 @@ register." ;;; :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. @@ -2511,7 +2517,9 @@ register." (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) @@ -2519,17 +2527,33 @@ register." (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 @@ -3018,7 +3042,11 @@ register." (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) @@ -3115,11 +3143,20 @@ register." #!-(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)))))) ;;;; miscellaneous