X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=4052fdce917e4242e21daabda901bb5c26046183;hb=5423b2e0f7e7643001ed3ef2f66681c0114a72a6;hp=1eed4ee2665fcc9edb97500e6573d584e17918df;hpb=8626856f9fd3df4988cca7121cb30cbf85e7cf3b;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 1eed4ee..4052fdc 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -300,15 +300,19 @@ ;;; duplicate COMPILED-DEBUG-FUN structures. (defvar *compiled-debug-funs* (make-hash-table :test 'eq)) -;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN -;;; and its component. This maps the latter to the former in -;;; *COMPILED-DEBUG-FUNS*. If there already is a -;;; COMPILED-DEBUG-FUN, then this returns it from -;;; *COMPILED-DEBUG-FUNS*. +;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its +;;; component. This maps the latter to the former in +;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN, +;;; then this returns it from *COMPILED-DEBUG-FUNS*. +;;; +;;; FIXME: It seems this table can potentially grow without bounds, +;;; and retains roots to functions that might otherwise be collected. (defun make-compiled-debug-fun (compiler-debug-fun component) - (or (gethash compiler-debug-fun *compiled-debug-funs*) - (setf (gethash compiler-debug-fun *compiled-debug-funs*) - (%make-compiled-debug-fun compiler-debug-fun component)))) + (let ((table *compiled-debug-funs*)) + (with-locked-hash-table (table) + (or (gethash compiler-debug-fun table) + (setf (gethash compiler-debug-fun table) + (%make-compiled-debug-fun compiler-debug-fun component)))))) (defstruct (bogus-debug-fun (:include debug-fun) @@ -2019,19 +2023,19 @@ register." ;; pointer #!+(or x86 x86-64) (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) - (and (logbitp 0 val) - (or (< sb!vm:read-only-space-start val - (* sb!vm:*read-only-space-free-pointer* - sb!vm:n-word-bytes)) - (< sb!vm:static-space-start val - (* sb!vm:*static-space-free-pointer* - sb!vm:n-word-bytes)) - (< (current-dynamic-space-start) val - (sap-int (dynamic-space-free-pointer)))))) + ;; 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) + (and (logbitp 0 val) + (or (< sb!vm:read-only-space-start val + (* sb!vm:*read-only-space-free-pointer* + sb!vm:n-word-bytes)) + (< sb!vm:static-space-start val + (* sb!vm:*static-space-free-pointer* + sb!vm:n-word-bytes)) + (< (current-dynamic-space-start) val + (sap-int (dynamic-space-free-pointer)))))) (values (%make-lisp-obj val) t) (if errorp (error "~S is not a valid argument to ~S" @@ -2639,13 +2643,6 @@ register." ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0 ;;; gets the first binding, and 1 gets the AREF form. -;;; temporary buffer used to build form-number => source-path translation in -;;; FORM-NUMBER-TRANSLATIONS -(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t)) - -;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS -(defvar *form-number-circularity-table* (make-hash-table :test 'eq)) - ;;; This returns a table mapping form numbers to source-paths. A ;;; source-path indicates a descent into the TOPLEVEL-FORM form, ;;; going directly to the subform corressponding to the form number. @@ -2654,32 +2651,32 @@ register." ;;; NODE-SOURCE-PATH; that is, the first element is the form number and ;;; the last is the TOPLEVEL-FORM number. (defun form-number-translations (form tlf-number) - (clrhash *form-number-circularity-table*) - (setf (fill-pointer *form-number-temp*) 0) - (sub-translate-form-numbers form (list tlf-number)) - (coerce *form-number-temp* 'simple-vector)) -(defun sub-translate-form-numbers (form path) - (unless (gethash form *form-number-circularity-table*) - (setf (gethash form *form-number-circularity-table*) t) - (vector-push-extend (cons (fill-pointer *form-number-temp*) path) - *form-number-temp*) - (let ((pos 0) - (subform form) - (trail form)) - (declare (fixnum pos)) - (macrolet ((frob () - '(progn - (when (atom subform) (return)) - (let ((fm (car subform))) - (when (consp fm) - (sub-translate-form-numbers fm (cons pos path))) - (incf pos)) - (setq subform (cdr subform)) - (when (eq subform trail) (return))))) - (loop - (frob) - (frob) - (setq trail (cdr trail))))))) + (let ((seen nil) + (translations (make-array 12 :fill-pointer 0 :adjustable t))) + (labels ((translate1 (form path) + (unless (member form seen) + (push form seen) + (vector-push-extend (cons (fill-pointer translations) path) + translations) + (let ((pos 0) + (subform form) + (trail form)) + (declare (fixnum pos)) + (macrolet ((frob () + '(progn + (when (atom subform) (return)) + (let ((fm (car subform))) + (when (consp fm) + (translate1 fm (cons pos path))) + (incf pos)) + (setq subform (cdr subform)) + (when (eq subform trail) (return))))) + (loop + (frob) + (frob) + (setq trail (cdr trail)))))))) + (translate1 form (list tlf-number))) + (coerce translations 'simple-vector))) ;;; FORM is a top level form, and path is a source-path into it. This ;;; returns the form indicated by the source-path. Context is the @@ -2868,7 +2865,7 @@ register." ;;; This maps bogus-lra-components to cookies, so that ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. -(defvar *fun-end-cookies* (make-hash-table :test 'eq)) +(defvar *fun-end-cookies* (make-hash-table :test 'eq :synchronized t)) ;;; This returns a hook function for the start helper breakpoint ;;; associated with a :FUN-END breakpoint. The returned function @@ -3120,7 +3117,7 @@ register." ;;;; breakpoint handlers (layer between C and exported interface) ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs. -(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq)) +(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq :synchronized t)) ;;; This returns the BREAKPOINT-DATA object associated with component cross ;;; offset. If none exists, this makes one, installs it, and returns it. @@ -3142,6 +3139,8 @@ register." ;;; We use this when there are no longer any active breakpoints ;;; corresponding to DATA. (defun delete-breakpoint-data (data) + ;; Again, this looks brittle. Is there no danger of being interrupted + ;; here? (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) (gethash component *component-breakpoint-offsets*) @@ -3245,6 +3244,8 @@ register." ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) + ;; FIXME: This looks brittle: what if we are interrupted somewhere + ;; here? ...or do we have interrupts disabled here? (delete-breakpoint-data data) (let* ((scp (locally