X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=fc38784880a06513d0663a2da53af05c1c17e619;hb=a6a12ed609d5467ec43b411283e5b3568fee81df;hp=756911817b3dd6b4995913718b44bb910f9a1fc4;hpb=0f05d24232969fa063ccc5086677e9ae7f877aba;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 7569118..fc38784 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -527,18 +527,19 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) (sap> control-stack-end x) - (or (not aligned) (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))) + (or (not aligned) (zerop (logand (sap-int x) + (1- (ash 1 sb!vm:word-shift)))))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) -#!+gencgc (declaim (inline valid-lisp-pointer-p)) -#!+gencgc +(declaim (inline valid-lisp-pointer-p)) (sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int (pointer system-area-pointer)) @@ -865,7 +866,15 @@ (component-from-component-ptr component-ptr)))) (/noshow0 "got CODE") (when (null code) - (return (values code 0 context))) + ;; KLUDGE: Detect undefined functions by a range-check + ;; against the trampoline address and the following + ;; function in the runtime. + (if (< (foreign-symbol-address "undefined_tramp") + (sap-int (sb!vm:context-pc context)) + (foreign-symbol-address #!+x86 "closure_tramp" + #!+x86-64 "alloc_tramp")) + (return (values :undefined-function 0 context)) + (return (values code 0 context)))) (let* ((code-header-len (* (get-header-data code) sb!vm:n-word-bytes)) (pc-offset @@ -1972,6 +1981,18 @@ register." ;;; (Such values can arise in registers on machines with conservative ;;; GC, and might also arise in debug variable locations when ;;; those variables are invalid.) +;;; +;;; NOTE: this function is not GC-safe in the slightest when creating +;;; a pointer to an object in dynamic space. If a GC occurs between +;;; the start of the call to VALID-LISP-POINTER-P and the end of +;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer +;;; is constructed. This can happen on CHENEYGC if an asynchronous +;;; interrupt occurs within the window. This can happen on GENCGC +;;; under the same circumstances, but is more likely due to all GENCGC +;;; platforms supporting threaded operation. This is somewhat +;;; mitigated on x86oids due to the conservative stack and interrupt +;;; context "scavenging" on such platforms, but there still may be a +;;; vulnerable window. (defun make-lisp-obj (val &optional (errorp t)) (if (or ;; fixnum @@ -1984,22 +2005,17 @@ register." (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) + ;; undefined_tramp doesn't validate properly as a pointer, and + ;; the actual value can vary by backend (x86oids need not + ;; apply) + #!+(or alpha hppa mips ppc) + (= val (+ (- (foreign-symbol-address "undefined_tramp") + (* sb!vm:n-word-bytes sb!vm:simple-fun-code-offset)) + sb!vm:fun-pointer-lowtag)) + #!+sparc + (= val (foreign-symbol-address "undefined_tramp")) ;; pointer - #!+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 - #!-gencgc - (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)))))) + (not (zerop (valid-lisp-pointer-p (int-sap val))))) (values (%make-lisp-obj val) t) (if errorp (error "~S is not a valid argument to ~S" @@ -2509,6 +2525,70 @@ register." (nconc (subseq form 0 n) (cons res (nthcdr (1+ n) form)))))))) (frob form path context)))) + +;;; Given a code location, return the associated form-number +;;; translations and the actual top level form. +(defun get-toplevel-form (location) + (let ((d-source (code-location-debug-source location))) + (let* ((offset (code-location-toplevel-form-offset location)) + (res + (cond ((debug-source-form d-source) + (debug-source-form d-source)) + ((debug-source-namestring d-source) + (get-file-toplevel-form location)) + (t (bug "Don't know how to use a DEBUG-SOURCE without ~ + a namestring or a form."))))) + (values (form-number-translations res offset) res)))) + +;;; To suppress the read-time evaluation #. macro during source read, +;;; *READTABLE* is modified. +;;; +;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which +;;; this code can use for side- effect free #. calls? +;;; +;;; FIXME: This also knows nothing of custom readtables. The assumption +;;; is that the current readtable is a decent approximation for what +;;; we want, but that's lossy. +(defun safe-readtable () + (let ((rt (copy-readtable))) + (set-dispatch-macro-character + #\# #\. (lambda (stream sub-char &rest rest) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token))) + rt) + rt)) + +;;; Locate the source file (if it still exists) and grab the top level +;;; form. If the file is modified, we use the top level form offset +;;; instead of the recorded character offset. +(defun get-file-toplevel-form (location) + (let* ((d-source (code-location-debug-source location)) + (tlf-offset (code-location-toplevel-form-offset location)) + (local-tlf-offset (- tlf-offset + (debug-source-root-number d-source))) + (char-offset + (aref (or (sb!di:debug-source-start-positions d-source) + (error "no start positions map")) + local-tlf-offset)) + (namestring (debug-source-namestring d-source))) + ;; FIXME: External format? + (with-open-file (f namestring :if-does-not-exist nil) + (unless f + (error "The source file no longer exists:~% ~A" namestring)) + (format *debug-io* "~%; file: ~A~%" namestring) + (let ((*readtable* (safe-readtable))) + (cond ((eql (debug-source-created d-source) (file-write-date f)) + (file-position f char-offset)) + (t + (format *debug-io* + "~%; File has been modified since compilation:~%; ~A~@ + ; Using form offset instead of character position.~%" + namestring) + (let ((*read-suppress* t)) + (loop repeat local-tlf-offset + do (read f))))) + (read f))))) ;;;; PREPROCESS-FOR-EVAL @@ -3150,20 +3230,10 @@ register." #!-(or x86 x86-64) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) sb!vm:other-pointer-lowtag)))) - #!-(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)) + ;; We used to set the header value of the LRA here to the + ;; offset from the enclosing component to the LRA header, but + ;; MAKE-LISP-OBJ actually checks the value before we get a + ;; chance to set it, so it's now done in arch-assem.S. (values new-lra code-object (sap- trap-loc src-start)))))) ;;;; miscellaneous