X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=89d1b7a63be61d81e5d467124181e3bc40644773;hb=0223f43d5f199914ebceff12b6f4c60448369edd;hp=234bcbf9ac785e56abd3175ffe5dfc9103b8e3c2;hpb=db97ea04895820f70c90bdeb0399aa0229410b5d;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 234bcbf..89d1b7a 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -479,7 +479,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 +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,17 +526,17 @@ #!-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) (pc system-area-pointer)) -#!+(or x86 x86-64) +#!+gencgc (sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int (pointer system-area-pointer)) @@ -1206,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. @@ -1609,22 +1604,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 @@ -1984,12 +1970,12 @@ register." ;; unbound marker (= val sb!vm:unbound-marker-widetag) ;; pointer - #!+(or x86 x86-64) + #!+gencgc (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) + #!-gencgc (and (logbitp 0 val) (or (< sb!vm:read-only-space-start val (* sb!vm:*read-only-space-free-pointer* @@ -3032,7 +3018,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) @@ -3129,11 +3119,20 @@ 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) + #!-(or gencgc ppc) + (progn + ;; Set the offset from the LRA to the enclosing component. + ;; This does not need to be done on GENCGC targets, as the + ;; pointer validation done in MAKE-LISP-OBJ requires that it + ;; already have been set before we get here. It does not + ;; need to be done on CHENEYGC PPC as it's easier to use the + ;; same fun_end_breakpoint_guts on both, including the LRA + ;; header. + (set-header-data + new-lra + (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1) + 1)) + (sb!vm:sanctify-for-execution code-object)) (values new-lra code-object (sap- trap-loc src-start)))))) ;;;; miscellaneous