X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=e8a188d31f00afa16e6134c281c9ba5306664a7f;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=d5dd4c7ede485f2fac6ebb80c51681dae10bad64;hpb=3eb973282e2b515702c012cc2dca1dc1a9b58fb0;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index d5dd4c7..e8a188d 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -632,7 +632,8 @@ (setf (frame-number frame) number))) (defun find-saved-frame-down (fp up-frame) - (multiple-value-bind (saved-fp saved-pc) (sb!c:find-saved-fp-and-pc fp) + (multiple-value-bind (saved-fp saved-pc) + (sb!alien-internals:find-saved-fp-and-pc fp) (when saved-fp (compute-calling-frame (descriptor-sap saved-fp) (descriptor-sap saved-pc) @@ -847,6 +848,22 @@ #!+alpha (* 2 n))) (* os-context-t))) +;;;; Perform the lookup which FOREIGN-SYMBOL-ADDRESS would do if the +;;;; linkage table were disabled, i.e. always return the actual symbol +;;;; address, not the linkage table trampoline, even if the symbol would +;;;; ordinarily go through the linkage table. Important when +;;;; SB-DYNAMIC-CORE is enabled and our caller assumes `name' to be a +;;;; "static" symbol; a concept which doesn't exist in such builds. +(defun true-foreign-symbol-address (name) + #!+linkage-table ;we have dlsym -- let's use it. + (find-dynamic-foreign-symbol-address name) + #!-linkage-table ;possibly no dlsym, but hence no indirection anyway. + (foreign-symbol-address)) + +;;;; See above. +(defun true-foreign-symbol-sap (name) + (int-sap (true-foreign-symbol-address name))) + #!+(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) @@ -866,7 +883,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 (< (true-foreign-symbol-address "undefined_tramp") + (sap-int (sb!vm:context-pc context)) + (true-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 @@ -1997,6 +2022,15 @@ 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 (not (zerop (valid-lisp-pointer-p (int-sap val))))) (values (%make-lisp-obj val) t) @@ -2508,6 +2542,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 @@ -2921,14 +3019,14 @@ register." ;;; which GC is disabled, so that Lisp doesn't move objects around ;;; that C is pointing to. (sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int - (code-obj sb!alien:unsigned-long) + (code-obj sb!alien:unsigned) (pc-offset sb!alien:int)) ;;; This removes the break instruction and replaces the original ;;; instruction. You must call this in a context in which GC is disabled ;;; so Lisp doesn't move objects around that C is pointing to. (sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void - (code-obj sb!alien:unsigned-long) + (code-obj sb!alien:unsigned) (pc-offset sb!alien:int) (old-inst sb!alien:unsigned-int)) @@ -3121,9 +3219,9 @@ register." (without-gcing ;; These are really code labels, not variables: but this way we get ;; their addresses. - (let* ((src-start (foreign-symbol-sap "fun_end_breakpoint_guts")) - (src-end (foreign-symbol-sap "fun_end_breakpoint_end")) - (trap-loc (foreign-symbol-sap "fun_end_breakpoint_trap")) + (let* ((src-start (true-foreign-symbol-sap "fun_end_breakpoint_guts")) + (src-end (true-foreign-symbol-sap "fun_end_breakpoint_end")) + (trap-loc (true-foreign-symbol-sap "fun_end_breakpoint_trap")) (length (sap- src-end src-start)) (code-object (sb!c:allocate-code-object (1+ bogus-lra-constants) length))