diff --git a/code/debug-int.lisp b/code/debug-int.lisp index d9d753a6d767a85d1ccb5f556a82ccd5ceceedf0..0274b12f20c35222af581f32a2c5060411c8e866 100644 --- a/code/debug-int.lisp +++ b/code/debug-int.lisp @@ -1,11 +1,11 @@ -;;; -*- Mode: completion; Log: code.log; Package: DI -*- +;;; -*- Mode: Lisp; Log: code.log; Package: DI -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.76 1997/11/18 10:47:56 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.77 1997/11/25 16:18:44 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -14,7 +14,7 @@ ;;; ;;; Written by Bill Chiles and Rob Maclachlan. ;;; -;;; Enhancements/debugging for the x86 port by Douglas Crosher 1996, 1997. +;;; X86 support by Douglas Crosher 1996,1997. (in-package "DEBUG-INTERNALS") @@ -837,10 +837,8 @@ (defun kernel:function-word-offset (fun) (kernel:function-word-offset fun)) ;;; (defsetf kernel:stack-ref kernel:%set-stack-ref) - + (proclaim '(inline cstack-pointer-valid-p)) -;;; This must come before any use (of course) else the cross compiler -;;; uses it's own version which is WRONG for x86!!! (defun cstack-pointer-valid-p (x) (declare (type system:system-area-pointer x)) #-:x86 @@ -857,181 +855,121 @@ x) (zerop (logand (system:sap-int x) #b11)))) -;;;; X86 support. Don't have lra objects so will search back for code header. - -(eval-when (compile eval) - (defmacro c-var-frob (lisp-fun c-var-name) - `(progn - (declaim (inline ,lisp-fun)) - (defun ,lisp-fun () - (alien:extern-alien ,c-var-name (alien:unsigned 32)))))) - -(c-var-frob static-space-start "static_space") -(c-var-frob read-only-space-start "read_only_space") - -(defun compiled-function-from-pc (pc &optional (limit 50000)) - ;;; x86 hack around not having lra objects. - (declare (type system-area-pointer pc) - (fixnum limit)) - (let ((base (int-sap (kernel:32bit-logical-and - (sap-int pc) - (kernel:32bit-logical-not vm:lowtag-mask))))) - (declare (type system-area-pointer base)) - (do ((hdrp (- (sap-int base) vm:word-bytes) - (- hdrp vm:word-bytes)) - (times limit (1- times))) - ((or (zerop times) - (> (read-only-space-start) hdrp)) - nil) - (declare (type (unsigned-byte 32) hdrp) - (fixnum times)) - (let ((hdrval (sap-ref-32 (int-sap hdrp) 0))) - (declare (type (unsigned-byte 32) hdrval)) - #+nil (format t "~&~x ~x~%" hdrp hdrval) - (when (and (= (kernel:32bit-logical-and hdrval vm:type-mask) - vm:function-header-type) - (= (sap-ref-32 (int-sap hdrp) - (* vm:function-self-slot vm:word-bytes)) - (+ hdrp (* vm:function-code-offset vm:word-bytes)))) - (let ((maybe-fcn (kernel:make-lisp-obj - (+ hdrp vm:function-pointer-type)))) - (when (and (functionp maybe-fcn) (compiled-function-p maybe-fcn)) - (return maybe-fcn)))))))) +#+(or gengc x86) +(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer) + (pc system:system-area-pointer)) +#+(or gengc x86) +(defun component-from-component-ptr (component-ptr) + (declare (type system:system-area-pointer component-ptr)) + (kernel:make-lisp-obj + (logior (system:sap-int component-ptr) + vm:other-pointer-type))) +;;;; X86 support. +#+x86 (defun compute-lra-data-from-pc(pc) - ;; pc is offset from dualword aligned function header (declare (type system-area-pointer pc)) - (let ((function (compiled-function-from-pc pc))) - (when function - (let* ((code (kernel:function-code-header function)) - (code-header-len (* (kernel:get-header-data code) - vm:word-bytes)) - (pc-offset - (- (sap-int pc) - (- (kernel:get-lisp-obj-address code) - vm:other-pointer-type) - code-header-len))) -; (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset) - (values pc-offset code))))) - -#+x86 -(defun stack-ref-32 (stack offset) - (declare (type sys:system-area-pointer stack) - (type fixnum offset) - (optimize (speed 3) (safety 0))) - (kernel::get-lisp-obj-address (stack-ref stack offset))) - -;;; maybe these should be generalized in xxx-vm.lisp -;;;(proclaim '(inline old-frame-pointer lisp-return-pc)) -(defun old-frame-pointer(scp) - (declare (type (alien:alien (* unix:sigcontext)) scp)) - (let* #+x86 ((cfp (vm:sigcontext-register scp vm::ebp-offset)) - (ofp (stack-ref-32 (int-sap cfp) vm::ocfp-save-offset))) - #-x86 ((ofp (vm:sigcontext-register scp vm::ocfp-offset))) - (declare (type (unsigned-byte 32) #+x86 cfp ofp)) - (int-sap ofp))) + (let ((component-ptr (component-ptr-from-pc pc))) + (unless (sap= component-ptr (int-sap #x0)) + (let* ((code (component-from-component-ptr component-ptr)) + (code-header-len (* (kernel:get-header-data code) vm:word-bytes)) + (pc-offset (- (sap-int pc) + (- (kernel:get-lisp-obj-address code) + vm:other-pointer-type) + code-header-len))) +; (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset) + (values pc-offset code))))) #+x86 -(defun lisp-return-pc(scp) - ;;; return a value that can be used in computation - (declare (type (alien:alien (* unix:sigcontext)) scp)) - (let* ((cfp (vm:sigcontext-register scp vm::ebp-offset)) - (lra (stack-ref-32 (int-sap cfp) vm::return-pc-save-offset))) - lra)) -#-x86 -(defun lisp-return-pc(scp) - (declare (type (alien:alien (* unix:sigcontext)) scp)) - (vm:sigcontext-register scp vm::lra-offset)) +(defconstant vm::nargs-offset #.vm::ecx-offset) +;;; Check for a valid return address - it could be any valid C/Lisp +;;; address. +;;; +;;; XX Could be a little smarter. #+x86 -(defconstant vm::nargs-offset #.vm::ecx-offset) +(proclaim '(inline cstack-pointer-valid-p)) #+x86 -(progn -(defun lisp-return-pc-valid-p(loc) - (declare (type system-area-pointer loc)) - (let ((code-beg (int-sap (static-space-start))) - (code-end (int-sap (* lisp::*static-space-free-pointer* - vm:word-bytes)))) - (and (sap< code-beg loc) - (sap< loc code-end)))) - -(declaim (inline make-fixnum)) -(defun make-fixnum (sap) - (kernel:make-lisp-obj (ash (sap-int sap) 2))) - -;; These return hopefully correct ofp ret values at a call site -(defun maybe-lisp-from-c(fp) - (declare (type system-area-pointer fp)) - (let ((s0 (stack-ref-32 fp vm::ocfp-save-offset)) - (s1 (stack-ref-32 fp vm::return-pc-save-offset))) - (when (and (kernel:make-lisp-obj s0)(kernel:make-lisp-obj s1)) - (let ((lisp-ofp (int-sap s0)) - (lisp-lra (int-sap s1))) - ;;(format t "~&cf? ~a ~a~%" lisp-ofp lisp-lra) - ;; Check this logic now that C calls with lra. - (when (sap= lisp-ofp lisp-lra) ; Can't happen via Lisp - (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes))) - (cra (sap-ref-sap fp (* 1 vm:word-bytes)))) - ;;(format t "~&cf! ~a ~a~%" cfp cra) - (list (make-fixnum cra) cfp))))))) - -(defun maybe-lisp-from-lisp(fp) - (declare (type system-area-pointer fp)) - (when (cstack-pointer-valid-p fp) - (let ((s0 (stack-ref-32 fp vm::ocfp-save-offset)) - (s1 (stack-ref-32 fp vm::return-pc-save-offset))) - (when (and (kernel:make-lisp-obj s0) - (kernel:make-lisp-obj s1)) - (let ((ofp (int-sap s0)) - (lra (int-sap s1))) - ;;(format t "~&mlf ~a ~a~%" ofp lra) - (and (cstack-pointer-valid-p ofp) - (lisp-return-pc-valid-p lra) - (list (kernel:make-lisp-obj s1) ofp))))))) - -(defun maybe-c-from-c(fp) - (declare (type system-area-pointer fp)) - (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes))) - (cra (sap-ref-sap fp (* 1 vm:word-bytes))) - (end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes)))) - ;;(format t "~&cfc? ~a ~a" cfp cra) - (when (cstack-pointer-valid-p cfp) - (cond ((sap< cra (int-sap (static-space-start))) - ;;(format t "~&cfc!~%") - (list (make-fixnum cra) cfp)) - ;; sigtrap handler from interrupt - ((sap> cra end) - ;;(format t "~&INT~%") - (list nil cfp)))))) - -;;; ^C a running program and get C call semantics with Lisp return address. -(defun maybe-c-from-lisp(fp) - (declare (type system-area-pointer fp)) - (let ((cfp (sap-ref-sap fp (* 0 vm:word-bytes))) - (cra (sap-ref-sap fp (* 1 vm:word-bytes))) - (end (int-sap (* lisp::*static-space-free-pointer* vm:word-bytes)))) - ;;(format t "~&cfl? ~a ~a" cfp cra) - (when (cstack-pointer-valid-p cfp) - (cond ((sap< cra end) - ;;(format t "~&cfl!~%") - (list (make-fixnum cra) cfp)))))) - -(defun x86-call-context(fp) - (declare (type system-area-pointer fp)) - (let ((pair (cond ((maybe-lisp-from-lisp fp)) - ((maybe-lisp-from-c fp)) - ((maybe-c-from-c fp)) - ((maybe-c-from-lisp fp))))) - (if pair - (apply #'values pair) - (error "Debug can't resolve frame ~a" fp)))) -) -;;; end of x86 hacks - +(defun ra-pointer-valid-p (ra) + (declare (type system:system-area-pointer ra)) + ;; Not a Lisp stack pointer. + (or (system:sap< ra (kernel:current-sp)) + (system:sap> ra (alien:alien-sap + (alien:extern-alien "control_stack_end" (* t)))))) +;;; Try to find a valid previous stack. This is complex on the x86 as +;;; it can jump between C and Lisp frames. To help find a valid frame +;;; it searches backwards. +;;; +;;; XX Should probably check if it has reached the bottom of the +;;; stack. +;;; +;;; XX Should handle interrupted frames, both Lisp and C. A present it +;;; manages to find a fp trail, see linux hack below. +;;; +#+x86 +(defun x86-call-context (fp &key (depth 8)) + (declare (type system-area-pointer fp) + (fixnum depth)) +; (format t "*CC ~s ~s~%" fp depth) + (cond + ((not (cstack-pointer-valid-p fp)) + (format t "Debug invalid fp ~s~%" fp) + nil) + (t + ;; Check the two possible frame pointers. + (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ vm::ocfp-save-offset) 4)))) + (lisp-ra (sap-ref-sap fp (- (* (1+ vm::return-pc-save-offset) 4)))) + (c-ocfp (sap-ref-sap fp (* 0 vm:word-bytes))) + (c-ra (sap-ref-sap fp (* 1 vm:word-bytes)))) + (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra) + (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) + (ra-pointer-valid-p c-ra)) +; (format t "*C Both valid ~s ~s ~s ~s~%" +; lisp-ocfp lisp-ra c-ocfp c-ra) + ;; Look forward another step to check their validity. + (let ((lisp-path-fp (x86-call-context lisp-ocfp + :depth (- depth 1))) + (c-path-fp (x86-call-context c-ocfp :depth (- depth 1)))) + (cond ((and lisp-path-fp c-path-fp) + ;; Both still seem valid - choose the smallest. + (format t "Debug: Both still valid ~s ~s ~s ~s~%" + lisp-ocfp lisp-ra c-ocfp c-ra) + (if (sap< lisp-ocfp c-ocfp) + (values lisp-ra lisp-ocfp) + (values c-ra c-ocfp))) + (lisp-path-fp + ;; The lisp convention is looking good. +; (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra) + (values lisp-ra lisp-ocfp)) + (c-path-fp + ;; The C convention is looking good. +; (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra) + (values c-ra c-ocfp)) + (t + ;; Neither seems right? +; (format t "Debug: no valid2 fp found ~s ~s~%" +; lisp-ocfp c-ocfp) + nil)))) + ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra)) + ;; The lisp convention is looking good. +; (format t "*C lisp-ocfp ~s ~s~%" lisp-ocfp lisp-ra) + (values lisp-ra lisp-ocfp)) + ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp) + #-linux (ra-pointer-valid-p c-ra)) + ;; The C convention is looking good. +; (format t "*C c-ocfp ~s ~s~%" c-ocfp c-ra) + (values c-ra c-ocfp)) + (t +; (format t "Debug: no valid fp found ~s ~s~%" lisp-ocfp c-ocfp) + nil)))))) + + ;;; DESCRIPTOR-SAP -- internal ;;; ;;; Convert the descriptor into a SAP. The bits all stay the same, we just @@ -1050,7 +988,8 @@ (kernel:%caller-frame-and-pc) (possibly-an-interpreted-frame (compute-calling-frame (descriptor-sap fp) - #-gengc pc #+gengc (descriptor-sap pc) + #-(or gengc x86) pc + #+(or gengc x86) (descriptor-sap pc) nil) nil))) @@ -1084,7 +1023,7 @@ debug-fun))) (possibly-an-interpreted-frame (compute-calling-frame - ( #-x86 descriptor-sap #+x86 int-sap + (descriptor-sap (get-context-value real vm::ocfp-save-offset (c::compiled-debug-function-old-fp c-d-f))) @@ -1147,18 +1086,37 @@ (escaped (compiled-frame-escaped frame))) (if escaped (ecase stack-slot - (#.vm::ocfp-save-offset - (sub-access-debug-var-slot pointer loc escaped)) - (#.vm::lra-save-offset - (kernel:make-lisp-obj - (sub-access-debug-var-slot pointer loc escaped)))) - (ecase stack-slot - (#.vm::ocfp-save-offset - (stack-ref-32 pointer stack-slot)) - (#.vm::lra-save-offset - (kernel:stack-ref pointer stack-slot)))))) + (#.vm::ocfp-save-offset + (sub-access-debug-var-slot pointer loc escaped)) + (#.vm::lra-save-offset +; (format t "escaped ra: pointer=~s loc=~s (~s ~s)~%" +; pointer loc +; (c:sc-offset-scn loc) (c::sc-offset-offset loc)) + (case (c::sc-offset-scn loc) + ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number) + (format t "escaped ra: pointer=~s loc=~s (~s ~s)~%" + pointer loc + (c:sc-offset-scn loc) (c::sc-offset-offset loc)) + ;; Translate to sap-reg at the same offset. + (setf loc (c::make-sc-offset vm:sap-reg-sc-number + (c:sc-offset-scn loc)))) + (#.vm:control-stack-sc-number + ;; Translate to sap-stack at the same offset. + (setf loc (c::make-sc-offset vm:sap-stack-sc-number + (c:sc-offset-offset loc)))) + (t + (format t "unexpected RA sc location?~%"))) +; (format t " translated to loc=~s (~s ~s)~%" loc +; (c:sc-offset-scn loc) (c::sc-offset-offset loc)) + (sub-access-debug-var-slot pointer loc escaped))) + (ecase stack-slot + (#.vm::ocfp-save-offset + (kernel:stack-ref pointer stack-slot)) + (#.vm::lra-save-offset + (sap-ref-sap pointer (- (* (1+ stack-slot) 4)))))))) ;;; +#-x86 (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type c::sc-offset loc)) @@ -1168,6 +1126,43 @@ (sub-set-debug-var-slot pointer loc value escaped) (setf (kernel:stack-ref pointer stack-slot) value)))) +#+x86 +(defun (setf get-context-value) (value frame stack-slot loc) + (declare (type compiled-frame frame) (type unsigned-byte stack-slot) + (type c::sc-offset loc)) + (let ((pointer (frame-pointer frame)) + (escaped (compiled-frame-escaped frame))) + (if escaped + (ecase stack-slot + (#.vm::ocfp-save-offset + (sub-set-debug-var-slot pointer loc value escaped)) + (#.vm::lra-save-offset +; (format t "escaped ra: pointer=~s loc=~s (~s ~s)~%" +; pointer loc +; (c:sc-offset-scn loc) (c::sc-offset-offset loc)) + (case (c::sc-offset-scn loc) + ((#.vm:any-reg-sc-number #.vm:descriptor-reg-sc-number) + (format t "escaped ra: pointer=~s loc=~s (~s ~s)~%" + pointer loc + (c:sc-offset-scn loc) (c::sc-offset-offset loc)) + ;; Translate to sap-reg at the same offset. + (setf loc (c::make-sc-offset vm:sap-reg-sc-number + (c:sc-offset-scn loc)))) + (#.vm:control-stack-sc-number + ;; Translate to sap-stack at the same offset. + (setf loc (c::make-sc-offset vm:sap-stack-sc-number + (c:sc-offset-offset loc)))) + (t + (format t "unexpected RA sc location?~%"))) +; (format t " translated to loc=~s (~s ~s)~%" loc +; (c:sc-offset-scn loc) (c::sc-offset-offset loc)) + (sub-set-debug-var-slot pointer loc value escaped))) + (ecase stack-slot + (#.vm::ocfp-save-offset + (setf (kernel:stack-ref pointer stack-slot) value)) + (#.vm::lra-save-offset + (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value)))))) + (defvar *debugging-interpreter* nil "When set, the debugger foregoes making interpreted-frames, so you can @@ -1233,35 +1228,22 @@ ;;; into C. In this case, the code object is stored on the stack after the ;;; LRA, and the LRA is the word offset. ;;; -;;;; x86 note. The non-lra version has not been tested with the -;;;; recent changes. I'm probably going to move to just using lra -;;;; and remove the x86-lra feature at some point. -#-gengc +#-(or gengc x86) (defun compute-calling-frame (caller lra up-frame) (declare (type system:system-area-pointer caller)) - ;;(format t "ccf: ~x ~a ~a~%" (sap-int caller) lra up-frame) (when (cstack-pointer-valid-p caller) (multiple-value-bind (code pc-offset escaped) (if lra (multiple-value-bind - (word-offset code) + (word-offset code) (if (ext:fixnump lra) (let ((fp (frame-pointer up-frame))) - #+x86 (declare (ignore fp)) - (values - lra - #-x86 ;; fake-foreign-fcn sticks CODE pointer here - (kernel:stack-ref fp (1+ vm::lra-save-offset)))) - #+(or x86-lra (not x86)) + (values lra + (kernel:stack-ref fp (1+ vm::lra-save-offset)))) (values (kernel:get-header-data lra) - (kernel:lra-code-header lra)) - #+(and x86 (not x86-lra)) - (compute-lra-data-from-pc (int-sap lra))) - + (kernel:lra-code-header lra))) (if code - #+(and x86 (not x86-lra))(values code word-offset nil) - #+(or x86-lra (not x86)) (values code (* (1+ (- word-offset (kernel:get-header-data code))) vm:word-bytes) @@ -1292,6 +1274,57 @@ (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) +#+x86 +(defun compute-calling-frame (caller ra up-frame) + (declare (type system:system-area-pointer caller ra)) +; (format t "ccf: ~a ~a ~a~%" caller ra up-frame) + (when (cstack-pointer-valid-p caller) +; (format t "ccf2~%") + ;; First check for an escaped frame. + (multiple-value-bind + (code pc-offset escaped) + (find-escaped-frame caller) + (cond (code + ;; If it's escaped it may be a function end breakpoint + ;; trap. +; (format t "ccf2: escaped ~s ~s~%" code pc-offset) + (when (and (kernel:code-component-p code) + (eq (kernel:%code-debug-info code) :bogus-lra)) + ;; If :bogus-lra grab the real lra. + (let ((real-ra + (kernel:code-header-ref code real-lra-slot))) + (multiple-value-setq (pc-offset code) + (compute-lra-data-from-pc real-ra)) +; (format t "ccf3 :bogus-lra ~s ~s~%" code pc-offset) + (assert code)))) + (t + ;; Not escaped + (multiple-value-setq (pc-offset code) + (compute-lra-data-from-pc ra)) +; (format t "ccf4 ~s ~s~%" code pc-offset) + (unless code + (setf code :foreign-function + pc-offset 0 + escaped nil)))) + + (let ((d-fun (case code + (:undefined-function + (make-bogus-debug-function + "The Undefined Function")) + (:foreign-function + (make-bogus-debug-function + "Foreign function call land")) + ((nil) + (make-bogus-debug-function + "Bogus stack frame")) + (t + (debug-function-from-pc code pc-offset))))) + (make-compiled-frame caller up-frame d-fun + (code-location-from-pc d-fun pc-offset + escaped) + (if up-frame (1+ (frame-number up-frame)) 0) + escaped))))) + #-(or gengc x86) (defun find-escaped-frame (frame-pointer) (declare (type system:system-area-pointer frame-pointer)) @@ -1325,7 +1358,7 @@ ;; We were in an assembly routine. Therefore, use the LRA as ;; the pc. (setf pc-offset - (- (lisp-return-pc scp) + (- (vm:sigcontext-register scp vm::lra-offset) (kernel:get-lisp-obj-address code) code-header-len))) (return @@ -1343,22 +1376,34 @@ (alien:with-alien ((lisp-interrupt-contexts (array (* unix:sigcontext) nil) :extern)) (let ((scp (alien:deref lisp-interrupt-contexts index))) - (when (sap= frame-pointer - (int-sap (vm:sigcontext-register scp vm::cfp-offset))) + (when (= (system:sap-int frame-pointer) + (vm:sigcontext-register scp vm::cfp-offset)) (system:without-gcing - (multiple-value-bind - (pc-offset code) - (compute-lra-data-from-pc (vm:sigcontext-program-counter scp)) - (when (symbolp code) + (let* ((component-ptr + (component-ptr-from-pc (vm:sigcontext-program-counter scp))) + (code (if (sap= component-ptr (int-sap #x0)) + nil + (component-from-component-ptr component-ptr)))) + (when (null code) (return (values code 0 scp))) - (return - (if (eq (kernel:%code-debug-info code) :bogus-lra) - (let ((real-lra (kernel:code-header-ref - code real-lra-slot))) - (values (kernel:lra-code-header real-lra) - (kernel:get-header-data real-lra) - nil)) - (values code pc-offset scp)))))))))) + (let* ((code-header-len (* (kernel:get-header-data code) + vm:word-bytes)) + (pc-offset + (- (system:sap-int + (vm:sigcontext-program-counter scp)) + (- (kernel:get-lisp-obj-address code) + vm:other-pointer-type) + code-header-len))) + (unless (<= 0 pc-offset + (* (kernel:code-header-ref code + vm:code-code-size-slot) + vm:word-bytes)) + ;; We were in an assembly routine. Therefore, use the LRA as + ;; the pc. + (format t "** pc-offset ~s not in code obj ~s?~%" + pc-offset code)) + (return + (values code pc-offset scp)))))))))) ;;; CODE-OBJECT-FROM-BITS -- internal. ;;; @@ -1389,17 +1434,6 @@ #+gengc (declaim (special kernel::*saved-state-chain*)) -#+gengc -(alien:def-alien-routine component-ptr-from-pc (system:system-area-pointer) - (pc system:system-area-pointer)) - -#+gengc -(defun component-from-component-ptr (component-ptr) - (declare (type system:system-area-pointer component-ptr)) - (kernel:make-lisp-obj - (logior (system:sap-int component-ptr) - vm:other-pointer-type))) - #+gengc (defun lookup-trace-table-entry (component pc) (declare (type code-component component) @@ -1491,7 +1525,8 @@ ;; ### Need to do something real. (values (make-bogus-debug-function "Assembler routine.") 0 - (old-frame-pointer state))) + (system:int-sap + (vm:sigcontext-register state vm::ocfp-offset)))) (#.vm:trace-table-function-prologue (values (make-bogus-debug-function "Function-Prologue in an assembler routine?") @@ -1516,7 +1551,8 @@ (#.vm:trace-table-call-site (values (debug-function-from-pc component pc-offset) pc-offset - (old-frame-pointer state))) + (system:int-sap + (vm:sigcontext-register state vm::ocfp-offset)))) (#.vm:trace-table-function-prologue #+nil ;; ### Need to do something real. (let* ((ra (system:int-sap @@ -1606,8 +1642,6 @@ ;;; the component, for function constants, and the c::compiled-debug-function. ;;; (defun debug-function-from-pc (component pc) - #+x86 ;; until no more bugs at least. - (declare (optimize (safety 1)(debug .5))) (let ((info (kernel:%code-debug-info component))) (cond ((not info) @@ -1679,23 +1713,38 @@ (system:sap-ref-32 catch (* vm:catch-block-current-cont-slot vm:word-bytes)))) - (let* (#-gengc + (let* (#-(or gengc x86) (lra (kernel:stack-ref catch vm:catch-block-entry-pc-slot)) - #+gengc + #+(or gengc x86) (ra (system:sap-ref-sap catch (* vm:catch-block-entry-pc-slot vm:word-bytes))) + #-x86 (component (kernel:stack-ref catch vm:catch-block-current-code-slot)) + #+x86 + (component (component-from-component-ptr + (component-ptr-from-pc ra))) (offset - #-gengc (* (- (1+ (kernel:get-header-data lra)) - (kernel:get-header-data component)) - vm:word-bytes) + #-(or gengc x86) + (* (- (1+ (kernel:get-header-data lra)) + (kernel:get-header-data component)) + vm:word-bytes) #+gengc (+ (- (system:sap-int ra) (kernel:get-lisp-obj-address component) (kernel:get-header-data component)) - vm:other-pointer-type))) - (push (cons (kernel:stack-ref catch vm:catch-block-tag-slot) + vm:other-pointer-type) + #+x86 + (- (system:sap-int ra) + (- (kernel:get-lisp-obj-address component) + vm:other-pointer-type) + (* (kernel:get-header-data component) vm:word-bytes)))) + (push (cons #-x86 + (kernel:stack-ref catch vm:catch-block-tag-slot) + #+x86 + (kernel:make-lisp-obj + (system:sap-ref-32 catch (* vm:catch-block-tag-slot + vm:word-bytes))) (make-compiled-code-location offset (frame-debug-function frame))) res))) @@ -4049,18 +4098,6 @@ ;;; handle breaks for internal errors. ;;; (defun handle-breakpoint (offset component signal-context) -#+x86 - (multiple-value-bind (byte-offset code) - (let* ((pc (vm:sigcontext-program-counter - (alien:sap-alien signal-context (* unix:sigcontext)))) - (fn (compiled-function-from-pc pc))) - (values (- (sap-int pc) - (- (kernel:get-lisp-obj-address fn) - vm:function-pointer-type)) - (kernel:function-code-header fn))) - (setq offset byte-offset - component code)) - (let ((data (breakpoint-data component offset nil))) (unless data (error "Unknown breakpoint in ~S at offset ~S." @@ -4108,7 +4145,7 @@ (breakpoint-do-displaced-inst signal-context (breakpoint-data-instruction data)) ; Under HPUX we can't sigreturn so bp-do-disp-i has to return. - #-(or hpux irix) + #-(or hpux irix x86) (error "BREAKPOINT-DO-DISPLACED-INST returned?")))) (defun invoke-breakpoint-hooks (breakpoints component offset) @@ -4164,17 +4201,20 @@ cookie)))) (defun get-function-end-breakpoint-values (scp) - (let ((ocfp (old-frame-pointer scp)) + (let (#-x86 + (ocfp (system:int-sap (vm:sigcontext-register scp vm::ocfp-offset))) + #+x86 + (ocfp (system:int-sap (vm:sigcontext-register scp vm::ebx-offset))) (nargs (kernel:make-lisp-obj (vm:sigcontext-register scp vm::nargs-offset))) - (reg-arg-offsets '#.vm::register-arg-offsets) + (reg-arg-offsets '#.vm::register-arg-offsets) (results nil)) (system:without-gcing (dotimes (arg-num nargs) (push (if reg-arg-offsets (kernel:make-lisp-obj (vm:sigcontext-register scp (pop reg-arg-offsets))) - (kernel:stack-ref ocfp arg-num)) + (kernel:stack-ref ocfp arg-num)) results))) (nreverse results))) @@ -4200,7 +4240,7 @@ (trap-loc (system:foreign-symbol-address "function_end_breakpoint_trap")) (length (system:sap- src-end src-start)) - (code-object (system:%primitive c:allocate-code-object + (code-object (system:%primitive #-x86 c:allocate-code-object #+x86 c::allocate-dynamic-code-object (1+ bogus-lra-constants) length)) (dst-start (kernel:code-instructions code-object))) @@ -4214,6 +4254,10 @@ (setf (kernel:code-header-ref code-object known-return-p-slot) known-return-p) (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits)) + (vm:sanctify-for-execution code-object) + #+x86 + (values dst-start code-object (system:sap- trap-loc src-start)) + #-x86 (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start) vm:other-pointer-type)))) (kernel:set-header-data