X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=2d960c7652d3836dc77d8042c6a494e6ce6ddf8b;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=9964063c1915c3314192dbe9b38bd45230033c7e;hpb=55ba706ac509b215da17b3b0ce775795e5b5ed62;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 9964063..2d960c7 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -371,7 +371,7 @@ ;; This is the byte offset into the component. (offset nil :type index) ;; The original instruction replaced by the breakpoint. - (instruction nil :type (or null (unsigned-byte 32))) + (instruction nil :type (or null sb!vm::word)) ;; A list of user breakpoints at this location. (breakpoints nil :type list)) (def!method print-object ((obj breakpoint-data) str) @@ -539,9 +539,9 @@ (make-lisp-obj (logior (sap-int component-ptr) sb!vm:other-pointer-lowtag))) -;;;; X86 support +;;;; (OR X86 X86-64) support -#!+x86 +#!+(or x86 x86-64) (progn (defun compute-lra-data-from-pc (pc) @@ -587,18 +587,21 @@ (defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) - ;;(format t "*CC ~S ~S~%" fp depth) +;; (format t "*CC ~S ~S~%" fp depth) (cond ((not (control-stack-pointer-valid-p fp)) #+nil (format t "debug invalid fp ~S~%" fp) nil) (t ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4)))) + (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) - 4)))) + 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)))) + #+nil (format t " lisp-ocfp=~S~% lisp-ra=~S~% c-ocfp=~S~% c-ra=~S~%" + lisp-ocfp lisp-ra c-ocfp c-ra) (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) @@ -701,10 +704,10 @@ (bogus-debug-fun (let ((fp (frame-pointer frame))) (when (control-stack-pointer-valid-p fp) - #!+x86 + #!+(or x86 x86-64) (multiple-value-bind (ra ofp) (x86-call-context fp) (and ra (compute-calling-frame ofp ra frame))) - #!-x86 + #!-(or x86 x86-64) (compute-calling-frame #!-alpha (sap-ref-sap fp (* ocfp-save-offset @@ -722,7 +725,7 @@ ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the ;;; standard save location offset on the stack. LOC is the saved ;;; SC-OFFSET describing the main location. -#!-x86 +#!-(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -731,7 +734,7 @@ (if escaped (sub-access-debug-var-slot pointer loc escaped) (stack-ref pointer stack-slot)))) -#!+x86 +#!+(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -743,9 +746,10 @@ (#.ocfp-save-offset (stack-ref pointer stack-slot)) (#.lra-save-offset - (sap-ref-sap pointer (- (* (1+ stack-slot) 4)))))))) + (sap-ref-sap pointer (- (* (1+ stack-slot) + sb!vm::n-word-bytes)))))))) -#!-x86 +#!-(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -755,7 +759,7 @@ (sub-set-debug-var-slot pointer loc value escaped) (setf (stack-ref pointer stack-slot) value)))) -#!+x86 +#!+(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -767,7 +771,8 @@ (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) (#.lra-save-offset - (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value)))))) + (setf (sap-ref-sap pointer (- (* (1+ stack-slot) + sb!vm::n-word-bytes))) value)))))) (defun foreign-function-backtrace-name (sap) (let ((name (foreign-symbol-in-address sap))) @@ -789,7 +794,7 @@ ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp ;;; calls into C. In this case, the code object is stored on the stack ;;; after the LRA, and the LRA is the word offset. -#!-x86 +#!-(or x86 x86-64) (defun compute-calling-frame (caller lra up-frame) (declare (type system-area-pointer caller)) (when (control-stack-pointer-valid-p caller) @@ -833,7 +838,7 @@ escaped) (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) -#!+x86 +#!+(or x86 x86-64) (defun compute-calling-frame (caller ra up-frame) (declare (type system-area-pointer caller ra)) (/noshow0 "entering COMPUTE-CALLING-FRAME") @@ -883,7 +888,7 @@ (+ sb!vm::thread-interrupt-contexts-offset n)) (* os-context-t))) -#!+x86 +#!+(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (/noshow0 "entering FIND-ESCAPED-FRAME") @@ -923,7 +928,7 @@ (return (values code pc-offset context))))))))) -#!-x86 +#!-(or x86 x86-64) (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) @@ -983,7 +988,7 @@ nil)) (values code pc-offset scp)))))))))) -#!-x86 +#!-(or x86 x86-64) (defun find-pc-from-assembly-fun (code scp) "Finds the PC for the return from an assembly routine properly. For some architectures (such as PPC) this will not be the $LRA @@ -1092,34 +1097,34 @@ register." (sap-ref-32 catch (* sb!vm:catch-block-current-cont-slot sb!vm:n-word-bytes)))) - (let* (#!-x86 + (let* (#!-(or x86 x86-64) (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot)) - #!+x86 + #!+(or x86 x86-64) (ra (sap-ref-sap catch (* sb!vm:catch-block-entry-pc-slot sb!vm:n-word-bytes))) - #!-x86 + #!-(or x86 x86-64) (component (stack-ref catch sb!vm:catch-block-current-code-slot)) - #!+x86 + #!+(or x86 x86-64) (component (component-from-component-ptr (component-ptr-from-pc ra))) (offset - #!-x86 + #!-(or x86 x86-64) (* (- (1+ (get-header-data lra)) (get-header-data component)) sb!vm:n-word-bytes) - #!+x86 + #!+(or x86 x86-64) (- (sap-int ra) (- (get-lisp-obj-address component) sb!vm:other-pointer-lowtag) (* (get-header-data component) sb!vm:n-word-bytes)))) - (push (cons #!-x86 + (push (cons #!-(or x86 x86-64) (stack-ref catch sb!vm:catch-block-tag-slot) - #!+x86 + #!+(or x86 x86-64) (make-lisp-obj - (sap-ref-32 catch (* sb!vm:catch-block-tag-slot - sb!vm:n-word-bytes))) + (sap-ref-word catch (* sb!vm:catch-block-tag-slot + sb!vm:n-word-bytes))) (make-compiled-code-location offset (frame-debug-fun frame))) reversed-result))) @@ -1403,6 +1408,9 @@ register." ;; optional. Stick the extra var in the result ;; element representing the keyword or optional, ;; which is the previous one. + ;; + ;; FIXME: NCONC used for side-effect: the effect is defined, + ;; but this is bad style no matter what. (nconc (car res) (list (compiled-debug-fun-lambda-list-var args (incf i) vars)))) @@ -1984,14 +1992,14 @@ register." (defun make-valid-lisp-obj (val) (if (or ;; fixnum - (zerop (logand val 3)) + (zerop (logand val sb!vm:fixnum-tag-mask)) ;; character - (and (zerop (logand val #xffff0000)) ; Top bits zero + (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero (= (logand val #xff) sb!vm:character-widetag)) ; char tag ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer - (and (logand val 1) + (and (logbitp 0 val) ;; Check that the pointer is valid. XXX Could do a better ;; job. FIXME: e.g. by calling out to an is_valid_pointer ;; routine in the C runtime support code @@ -2006,7 +2014,7 @@ register." (make-lisp-obj val) :invalid-object)) -#!-x86 +#!-(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (macrolet ((with-escaped-value ((var) &body forms) `(if escaped @@ -2149,7 +2157,7 @@ register." (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))))))) -#!+x86 +#!+(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) (declare (type system-area-pointer fp)) (macrolet ((with-escaped-value ((var) &body forms) @@ -2238,14 +2246,14 @@ register." (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:character-stack-sc-number (code-char - (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))) + (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))))) (#.sb!vm:unsigned-stack-sc-number - (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes)))) (#.sb!vm:signed-stack-sc-number - (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) + (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes)))) (#.sb!vm:sap-stack-sc-number (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))))))) @@ -2278,7 +2286,7 @@ register." (compiled-debug-var-sc-offset debug-var)) value)))) -#!-x86 +#!-(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped @@ -2437,7 +2445,7 @@ register." sb!vm:n-word-bytes)) (the system-area-pointer value))))))) -#!+x86 +#!+(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) (macrolet ((set-escaped-value (val) `(if escaped @@ -2516,18 +2524,18 @@ register." (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:character-stack-sc-number - (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) + (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) (char-code (the character value)))) (#.sb!vm:unsigned-stack-sc-number - (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the (unsigned-byte 32) value))) + (setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) + sb!vm:n-word-bytes))) + (the sb!vm:word value))) (#.sb!vm:signed-stack-sc-number - (setf (signed-sap-ref-32 + (setf (signed-sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))) - (the (signed-byte 32) value))) + (the (signed-byte #.sb!vm:n-word-bits) value))) (#.sb!vm:sap-stack-sc-number (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:n-word-bytes))) @@ -2891,7 +2899,7 @@ register." (do ((frame frame (frame-down frame))) ((not frame) nil) (when (and (compiled-frame-p frame) - (#!-x86 eq #!+x86 sap= + (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap= lra (get-context-value frame lra-save-offset lra-sc-offset))) (return t))))) @@ -3225,8 +3233,8 @@ register." (defun get-fun-end-breakpoint-values (scp) (let ((ocfp (int-sap (sb!vm:context-register scp - #!-x86 sb!vm::ocfp-offset - #!+x86 sb!vm::ebx-offset))) + #!-(or x86 x86-64) sb!vm::ocfp-offset + #!+(or x86 x86-64) sb!vm::ebx-offset))) (nargs (make-lisp-obj (sb!vm:context-register scp sb!vm::nargs-offset))) (reg-arg-offsets '#.sb!vm::*register-arg-offsets*) @@ -3243,9 +3251,9 @@ register." ;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints) (defconstant bogus-lra-constants - #!-x86 2 #!+x86 3) + #!-(or x86 x86-64) 2 #!+(or x86 x86-64) 3) (defconstant known-return-p-slot - (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2)) + (+ sb!vm:code-constants-offset #!-(or x86 x86-64) 1 #!+(or x86 x86-64) 2)) ;;; Make a bogus LRA object that signals a breakpoint trap when ;;; returned to. If the breakpoint trap handler returns, REAL-LRA is @@ -3270,19 +3278,19 @@ register." (setf (%code-debug-info code-object) :bogus-lra) (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot) length) - #!-x86 + #!-(or x86 x86-64) (setf (code-header-ref code-object real-lra-slot) real-lra) - #!+x86 + #!+(or x86 x86-64) (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra) (setf (code-header-ref code-object real-lra-slot) code) (setf (code-header-ref code-object (1+ real-lra-slot)) offset)) (setf (code-header-ref code-object known-return-p-slot) known-return-p) - (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits)) + (system-area-ub8-copy src-start 0 dst-start 0 length) (sb!vm:sanctify-for-execution code-object) - #!+x86 + #!+(or x86 x86-64) (values dst-start code-object (sap- trap-loc src-start)) - #!-x86 + #!-(or x86 x86-64) (let ((new-lra (make-lisp-obj (+ (sap-int dst-start) sb!vm:other-pointer-lowtag)))) (set-header-data