X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=e8a188d31f00afa16e6134c281c9ba5306664a7f;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=5ec3f41b9ecdf03abc936e2a6d59a558b7d09c9b;hpb=3cbc1e7cfb59875d7ebec4af3c7c744cab0b76ae;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 5ec3f41..e8a188d 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 @@ -298,7 +299,7 @@ ;;; This maps SB!C::COMPILED-DEBUG-FUNs to ;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not ;;; duplicate COMPILED-DEBUG-FUN structures. -(defvar *compiled-debug-funs* (make-hash-table :test 'eq)) +(defvar *compiled-debug-funs* (make-hash-table :test 'eq :weakness :key)) ;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its ;;; component. This maps the latter to the former in @@ -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)))))) @@ -479,7 +480,7 @@ ;; valid value at this code-location. (unexported). (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; (unexported) To see SB!C::LOCATION-KIND, do - ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND). + ;; (SB!KERNEL:TYPEXPAND 'SB!C::LOCATION-KIND). (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)) (step-info :unparsed :type (or (member :unparsed :foo) simple-string))) @@ -515,7 +516,7 @@ (defun fun-word-offset (fun) (fun-word-offset fun)) #!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) -(defun control-stack-pointer-valid-p (x) +(defun control-stack-pointer-valid-p (x &optional (aligned t)) (declare (type system-area-pointer x)) (let* (#!-stack-grows-downward-not-upward (control-stack-start @@ -526,17 +527,19 @@ #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) (sap<= control-stack-start x) - (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) - (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)) -#!+(or x86 x86-64) +(declaim (inline valid-lisp-pointer-p)) (sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int (pointer system-area-pointer)) @@ -558,7 +561,7 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) -; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) + ;;(format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) (values pc-offset code))))) #!+(or x86 x86-64) @@ -594,61 +597,14 @@ (declaim (maybe-inline x86-call-context)) (defun x86-call-context (fp) (declare (type system-area-pointer fp)) - (labels ((fail () - (values nil - (int-sap 0) - (int-sap 0))) - (handle (fp) - (cond - ((not (control-stack-pointer-valid-p fp)) - (fail)) - (t - ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) - sb!vm::n-word-bytes)))) - (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) - sb!vm::n-word-bytes)))) - (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) - (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) - (cond ((and (sap> lisp-ocfp fp) - (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra) - (sap> c-ocfp fp) - (control-stack-pointer-valid-p c-ocfp) - (ra-pointer-valid-p c-ra)) - ;; Look forward another step to check their validity. - (let ((lisp-ok (handle lisp-ocfp)) - (c-ok (handle c-ocfp))) - (cond ((and lisp-ok c-ok) - ;; Both still seem valid - choose the lisp frame. - #!+freebsd - (if (sap> lisp-ocfp c-ocfp) - (values t lisp-ra lisp-ocfp) - (values t c-ra c-ocfp)) - #!-freebsd - (values t lisp-ra lisp-ocfp)) - (lisp-ok - ;; The lisp convention is looking good. - (values t lisp-ra lisp-ocfp)) - (c-ok - ;; The C convention is looking good. - (values t c-ra c-ocfp)) - (t - ;; Neither seems right? - (fail))))) - ((and (sap> lisp-ocfp fp) - (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra)) - ;; The lisp convention is looking good. - (values t lisp-ra lisp-ocfp)) - ((and (sap> c-ocfp fp) - (control-stack-pointer-valid-p c-ocfp) - #!-linux (ra-pointer-valid-p c-ra)) - ;; The C convention is looking good. - (values t c-ra c-ocfp)) - (t - (fail)))))))) - (handle fp))) + (let ((ocfp (sap-ref-sap fp (sb!vm::frame-byte-offset ocfp-save-offset))) + (ra (sap-ref-sap fp (sb!vm::frame-byte-offset return-pc-save-offset)))) + (if (and (control-stack-pointer-valid-p fp) + (sap> ocfp fp) + (control-stack-pointer-valid-p ocfp) + (ra-pointer-valid-p ra)) + (values t ra ocfp) + (values nil (int-sap 0) (int-sap 0))))) ) ; #+x86 PROGN @@ -663,7 +619,7 @@ (defun top-frame () (/noshow0 "entering TOP-FRAME") (compute-calling-frame (descriptor-sap (%caller-frame)) - (descriptor-sap (%caller-pc)) + (%caller-pc) nil)) ;;; Flush all of the frames above FRAME, and renumber all the frames @@ -676,11 +632,13 @@ (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) - up-frame)))) + up-frame + t)))) ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. @@ -746,8 +704,7 @@ (#.ocfp-save-offset (stack-ref pointer stack-slot)) (#.lra-save-offset - (sap-ref-sap pointer (- (* (1+ stack-slot) - sb!vm::n-word-bytes)))))))) + (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot))))))) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) @@ -763,8 +720,8 @@ (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) (#.lra-save-offset - (setf (sap-ref-sap pointer (- (* (1+ stack-slot) - sb!vm::n-word-bytes))) value)))))) + (setf (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot)) + value)))))) (defun foreign-function-backtrace-name (sap) (let ((name (sap-foreign-symbol sap))) @@ -835,13 +792,14 @@ escaped)))))) #!+(or x86 x86-64) -(defun compute-calling-frame (caller ra up-frame) +(defun compute-calling-frame (caller ra up-frame &optional savedp) (declare (type system-area-pointer caller ra)) (/noshow0 "entering COMPUTE-CALLING-FRAME") (when (control-stack-pointer-valid-p caller) (/noshow0 "in WHEN") ;; First check for an escaped frame. - (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller) + (multiple-value-bind (code pc-offset escaped off-stack) + (find-escaped-frame caller) (/noshow0 "at COND") (cond (code ;; If it's escaped it may be a function end breakpoint trap. @@ -875,115 +833,145 @@ (code-location-from-pc d-fun pc-offset escaped) (if up-frame (1+ (frame-number up-frame)) 0) - escaped))))) + ;; If we have an interrupt-context that's not on + ;; our stack at all, and we're computing the + ;; from from a saved FP, we're probably looking + ;; at an interrupted syscall. + (or escaped (and savedp off-stack))))))) (defun nth-interrupt-context (n) (declare (type (unsigned-byte 32) n) (optimize (speed 3) (safety 0))) (sb!alien:sap-alien (sb!vm::current-thread-offset-sap - (+ sb!vm::thread-interrupt-contexts-offset n)) + (+ sb!vm::thread-interrupt-contexts-offset + #!-alpha n + #!+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)) (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (/noshow0 "at head of WITH-ALIEN") - (let ((context (nth-interrupt-context index))) - (/noshow0 "got CONTEXT") - (when (= (sap-int frame-pointer) - (sb!vm:context-register context sb!vm::cfp-offset)) - (without-gcing - (/noshow0 "in WITHOUT-GCING") - (let* ((component-ptr (component-ptr-from-pc - (sb!vm:context-pc context))) - (code (unless (sap= component-ptr (int-sap #x0)) - (component-from-component-ptr component-ptr)))) - (/noshow0 "got CODE") - (when (null code) - (return (values code 0 context))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset + (let* ((context (nth-interrupt-context index)) + (cfp (int-sap (sb!vm:context-register context sb!vm::cfp-offset)))) + (/noshow0 "got CONTEXT") + (unless (control-stack-pointer-valid-p cfp) + (return (values nil nil nil t))) + (when (sap= frame-pointer cfp) + (without-gcing + (/noshow0 "in WITHOUT-GCING") + (let* ((component-ptr (component-ptr-from-pc + (sb!vm:context-pc context))) + (code (unless (sap= component-ptr (int-sap #x0)) + (component-from-component-ptr component-ptr)))) + (/noshow0 "got CODE") + (when (null code) + ;; 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 (- (sap-int (sb!vm:context-pc context)) (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - (/noshow "got PC-OFFSET") - (unless (<= 0 pc-offset - (* (code-header-ref code sb!vm:code-code-size-slot) - sb!vm:n-word-bytes)) - ;; We were in an assembly routine. Therefore, use the - ;; LRA as the pc. - ;; - ;; FIXME: Should this be WARN or ERROR or what? - (format t "** pc-offset ~S not in code obj ~S?~%" - pc-offset code)) - (/noshow0 "returning from FIND-ESCAPED-FRAME") - (return - (values code pc-offset context))))))))) + (/noshow "got PC-OFFSET") + (unless (<= 0 pc-offset + (* (code-header-ref code sb!vm:code-code-size-slot) + sb!vm:n-word-bytes)) + ;; We were in an assembly routine. Therefore, use the + ;; LRA as the pc. + ;; + ;; FIXME: Should this be WARN or ERROR or what? + (format t "** pc-offset ~S not in code obj ~S?~%" + pc-offset code)) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (return + (values code pc-offset context))))))))) #!-(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (/noshow0 "at head of WITH-ALIEN") (let ((scp (nth-interrupt-context index))) - (/noshow0 "got SCP") + (/noshow0 "got SCP") (when (= (sap-int frame-pointer) (sb!vm:context-register scp sb!vm::cfp-offset)) (without-gcing - (/noshow0 "in WITHOUT-GCING") - (let ((code (code-object-from-bits - (sb!vm:context-register scp sb!vm::code-offset)))) - (/noshow0 "got CODE") - (when (symbolp code) - (return (values code 0 scp))) - (let* ((code-header-len (* (get-header-data code) - sb!vm:n-word-bytes)) - (pc-offset - (- (sap-int (sb!vm:context-pc scp)) - (- (get-lisp-obj-address code) - sb!vm:other-pointer-lowtag) - code-header-len))) - (let ((code-size (* (code-header-ref code - sb!vm:code-code-size-slot) - sb!vm:n-word-bytes))) - (unless (<= 0 pc-offset code-size) - ;; We were in an assembly routine. - (multiple-value-bind (new-pc-offset computed-return) - (find-pc-from-assembly-fun code scp) - (setf pc-offset new-pc-offset) - (unless (<= 0 pc-offset code-size) - (cerror - "Set PC-OFFSET to zero and continue backtrace." - 'bug - :format-control - "~@" - :format-arguments - (list pc-offset - (sap-int (sb!vm:context-pc scp)) - code - (%code-entry-points code) - (sb!vm:context-register scp sb!vm::lra-offset) - computed-return)) - ;; We failed to pinpoint where PC is, but set - ;; pc-offset to 0 to keep the backtrace from - ;; exploding. - (setf pc-offset 0))))) - (/noshow0 "returning from FIND-ESCAPED-FRAME") - (return - (if (eq (%code-debug-info code) :bogus-lra) - (let ((real-lra (code-header-ref code - real-lra-slot))) - (values (lra-code-header real-lra) - (get-header-data real-lra) - nil)) - (values code pc-offset scp)))))))))) + :format-arguments + (list pc-offset + (sap-int (sb!vm:context-pc scp)) + code + (%code-entry-points code) + (sb!vm:context-register scp sb!vm::lra-offset) + computed-return)) + ;; We failed to pinpoint where PC is, but set + ;; pc-offset to 0 to keep the backtrace from + ;; exploding. + (setf pc-offset 0))))) + (/noshow0 "returning from FIND-ESCAPED-FRAME") + (return + (if (eq (%code-debug-info code) :bogus-lra) + (let ((real-lra (code-header-ref code + real-lra-slot))) + (values (lra-code-header real-lra) + (get-header-data real-lra) + nil)) + (values code pc-offset scp)))))))))) #!-(or x86 x86-64) (defun find-pc-from-assembly-fun (code scp) @@ -1252,35 +1240,30 @@ register." ;;; Return a DEBUG-FUN that represents debug information for FUN. (defun fun-debug-fun (fun) (declare (type function fun)) - (ecase (widetag-of fun) - (#.sb!vm:closure-header-widetag - (fun-debug-fun (%closure-fun fun))) - (#.sb!vm:funcallable-instance-header-widetag - (fun-debug-fun (funcallable-instance-fun fun))) - (#.sb!vm:simple-fun-header-widetag - (let* ((name (%simple-fun-name fun)) - (component (fun-code-header fun)) - (res (find-if - (lambda (x) - (and (sb!c::compiled-debug-fun-p x) - (eq (sb!c::compiled-debug-fun-name x) name) - (eq (sb!c::compiled-debug-fun-kind x) nil))) - (sb!c::compiled-debug-info-fun-map - (%code-debug-info component))))) - (if res - (make-compiled-debug-fun res component) - ;; KLUDGE: comment from CMU CL: - ;; This used to be the non-interpreted branch, but - ;; William wrote it to return the debug-fun of fun's XEP - ;; instead of fun's debug-fun. The above code does this - ;; more correctly, but it doesn't get or eliminate all - ;; appropriate cases. It mostly works, and probably - ;; works for all named functions anyway. - ;; -- WHN 20000120 - (debug-fun-from-pc component - (* (- (fun-word-offset fun) - (get-header-data component)) - sb!vm:n-word-bytes))))))) + (let ((simple-fun (%fun-fun fun))) + (let* ((name (%simple-fun-name simple-fun)) + (component (fun-code-header simple-fun)) + (res (find-if + (lambda (x) + (and (sb!c::compiled-debug-fun-p x) + (eq (sb!c::compiled-debug-fun-name x) name) + (eq (sb!c::compiled-debug-fun-kind x) nil))) + (sb!c::compiled-debug-info-fun-map + (%code-debug-info component))))) + (if res + (make-compiled-debug-fun res component) + ;; KLUDGE: comment from CMU CL: + ;; This used to be the non-interpreted branch, but + ;; William wrote it to return the debug-fun of fun's XEP + ;; instead of fun's debug-fun. The above code does this + ;; more correctly, but it doesn't get or eliminate all + ;; appropriate cases. It mostly works, and probably + ;; works for all named functions anyway. + ;; -- WHN 20000120 + (debug-fun-from-pc component + (* (- (fun-word-offset simple-fun) + (get-header-data component)) + sb!vm:n-word-bytes)))))) ;;; Return the kind of the function, which is one of :OPTIONAL, ;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL. @@ -1460,10 +1443,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 @@ -1655,22 +1641,13 @@ register." (without-package-locks (setf (compiled-debug-var-symbol (svref vars i)) (intern (format nil "ARG-~V,'0D" width i) - ;; KLUDGE: It's somewhat nasty to have a bare - ;; package name string here. It would be - ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG") - ;; instead, since then at least it would transform - ;; correctly under package renaming and stuff. - ;; However, genesis can't handle dumped packages.. - ;; -- WHN 20000129 - ;; - ;; FIXME: Maybe this could be fixed by moving the - ;; whole debug-int.lisp file to warm init? (after - ;; which dumping a #.(FIND-PACKAGE ..) expression - ;; would work fine) If this is possible, it would - ;; probably be a good thing, since minimizing the - ;; amount of stuff in cold init is basically good. - (or (find-package "SB-DEBUG") - (find-package "SB!DEBUG")))))))) + ;; The cross-compiler won't dump literal package + ;; references because the target package objects + ;; aren't created until partway through + ;; cold-init. In lieu of adding smarts to the + ;; build framework to handle this, we use an + ;; explicit load-time-value form. + (load-time-value (find-package "SB!DEBUG")))))))) ;;; Parse the packed representation of DEBUG-VARs from ;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector @@ -1693,6 +1670,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)) @@ -1707,7 +1686,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 @@ -2017,6 +1998,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 @@ -2029,22 +2022,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 - #!+(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)))))) + (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" @@ -2100,8 +2088,9 @@ register." ,@body)) (stack-frame-offset (data-width offset) #!+(or x86 x86-64) - `(- (* (+ (sb!c:sc-offset-offset sc-offset) ,data-width ,offset) - sb!vm:n-word-bytes)) + `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset) + (1- ,data-width) + ,offset)) #!-(or x86 x86-64) (declare (ignore data-width)) #!-(or x86 x86-64) @@ -2287,8 +2276,9 @@ register." ,@body)) (stack-frame-offset (data-width offset) #!+(or x86 x86-64) - `(- (* (+ (sb!c:sc-offset-offset sc-offset) ,data-width ,offset) - sb!vm:n-word-bytes)) + `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset) + (1- ,data-width) + ,offset)) #!-(or x86 x86-64) (declare (ignore data-width)) #!-(or x86 x86-64) @@ -2429,12 +2419,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. @@ -2554,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 @@ -2569,7 +2621,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) @@ -2577,17 +2631,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 @@ -2609,6 +2679,15 @@ register." (debug-signal 'frame-fun-mismatch :code-location loc :form form :frame frame)) (funcall res frame)))))) + +;;; EVAL-IN-FRAME + +(defun eval-in-frame (frame form) + (declare (type frame frame)) + #!+sb-doc + "Evaluate FORM in the lexical context of FRAME's current code location, + returning the results of the evaluation." + (funcall (preprocess-for-eval form (frame-code-location frame)) frame)) ;;;; breakpoints @@ -2940,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)) @@ -3067,7 +3146,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) @@ -3136,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)) @@ -3164,11 +3247,10 @@ 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) + ;; 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