X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=d02edaefdd697d35913c17ee6c2aeff50356f471;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=5ec3f41b9ecdf03abc936e2a6d59a558b7d09c9b;hpb=3cbc1e7cfb59875d7ebec4af3c7c744cab0b76ae;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 5ec3f41..d02edae 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -298,7 +298,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 @@ -515,7 +515,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,11 +526,11 @@ #!-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) sb!vm:fixnum-tag-mask)))) #!+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) sb!vm:fixnum-tag-mask)))))) (declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) @@ -558,7 +558,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 +594,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 +616,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 @@ -746,8 +699,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 +715,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))) @@ -881,7 +833,9 @@ (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))) #!+(or x86 x86-64) @@ -1252,35 +1206,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. @@ -2100,8 +2049,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 +2237,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) @@ -2609,6 +2560,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