X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=e8a188d31f00afa16e6134c281c9ba5306664a7f;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=26ca084d8705506910499dae842fad1a71eaac5e;hpb=77bf768d096845986af71ca5055c94c4abd626ed;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 26ca084..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 @@ -662,8 +618,9 @@ ;;; this function. (defun top-frame () (/noshow0 "entering TOP-FRAME") - (multiple-value-bind (fp pc) (%caller-frame-and-pc) - (compute-calling-frame (descriptor-sap fp) pc nil))) + (compute-calling-frame (descriptor-sap (%caller-frame)) + (%caller-pc) + nil)) ;;; Flush all of the frames above FRAME, and renumber all the frames ;;; below FRAME. @@ -674,6 +631,15 @@ ((not (frame-p frame))) (setf (frame-number frame) number))) +(defun find-saved-frame-down (fp up-frame) + (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 + t)))) + ;;; Return the frame immediately below FRAME on the stack; or when ;;; FRAME is the bottom of the stack, return NIL. (defun frame-down (frame) @@ -703,8 +669,9 @@ (when (control-stack-pointer-valid-p fp) #!+(or x86 x86-64) (multiple-value-bind (ok ra ofp) (x86-call-context fp) - (and ok - (compute-calling-frame ofp ra frame))) + (if ok + (compute-calling-frame ofp ra frame) + (find-saved-frame-down fp frame))) #!-(or x86 x86-64) (compute-calling-frame #!-alpha @@ -737,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) @@ -754,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))) @@ -826,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. @@ -866,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) @@ -1243,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. @@ -1451,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 @@ -1646,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 @@ -1684,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)) @@ -1698,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 @@ -2008,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 @@ -2020,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" @@ -2043,8 +2040,11 @@ register." (values (make-unprintable-object (format nil "invalid object #x~X" val)) nil)))) -#!-(or x86 x86-64) (defun sub-access-debug-var-slot (fp sc-offset &optional escaped) + ;; NOTE: The long-float support in here is obviously decayed. When + ;; the x86oid and non-x86oid versions of this function were unified, + ;; the behavior of long-floats was preserved, which only served to + ;; highlight its brokenness. (macrolet ((with-escaped-value ((var) &body forms) `(if escaped (let ((,var (sb!vm:context-register @@ -2059,7 +2059,21 @@ register." (sb!c:sc-offset-offset sc-offset) ',format) :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value (format offset) + `(if escaped + (complex + (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) ,offset) ',format)) + :invalid-value-for-unescaped-register-storage)) (with-nfp ((var) &body body) + ;; x86oids have no separate number stack, so dummy it + ;; up for them. + #!+(or x86 x86-64) + `(let ((,var fp)) + ,@body) + #!-(or x86 x86-64) `(let ((,var (if escaped (sb!sys:int-sap (sb!vm:context-register escaped @@ -2071,12 +2085,22 @@ register." (sb!vm::make-number-stack-pointer (sb!sys:sap-ref-32 fp (* nfp-save-offset sb!vm:n-word-bytes)))))) - ,@body))) + ,@body)) + (stack-frame-offset (data-width offset) + #!+(or x86 x86-64) + `(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) + `(* (+ (sb!c:sc-offset-offset sc-offset) ,offset) + sb!vm:n-word-bytes))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number #!+rt #.sb!vm:word-pointer-reg-sc-number) - (sb!sys:without-gcing + (without-gcing (with-escaped-value (val) (make-lisp-obj val nil)))) (#.sb!vm:character-reg-sc-number @@ -2093,8 +2117,10 @@ register." (#.sb!vm:unsigned-reg-sc-number (with-escaped-value (val) val)) + #!-(or x86 x86-64) (#.sb!vm:non-descriptor-reg-sc-number (error "Local non-descriptor register access?")) + #!-(or x86 x86-64) (#.sb!vm:interior-reg-sc-number (error "Local interior register access?")) (#.sb!vm:single-reg-sc-number @@ -2105,187 +2131,57 @@ register." (#.sb!vm:long-reg-sc-number (escaped-float-value long-float)) (#.sb!vm:complex-single-reg-sc-number - (if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'single-float) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float)) - :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value single-float 1)) (#.sb!vm:complex-double-reg-sc-number - (if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'double-float) - (sb!vm:context-float-register - escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) - 'double-float)) - :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value double-float #!+sparc 2 #!-sparc 1)) #!+long-float (#.sb!vm:complex-long-reg-sc-number - (if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'long-float) - (sb!vm:context-float-register - escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - 'long-float)) - :invalid-value-for-unescaped-register-storage)) + (escaped-complex-float-value long-float + #!+sparc 4 #!+(or x86 x86-64) 1 + #!-(or sparc x86 x86-64) 0)) (#.sb!vm:single-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-single nfp (stack-frame-offset 1 0)))) (#.sb!vm:double-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-double nfp (stack-frame-offset 2 0)))) #!+long-float (#.sb!vm:long-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-long nfp (stack-frame-offset 3 0)))) (#.sb!vm:complex-single-stack-sc-number (with-nfp (nfp) (complex - (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))))) + (sb!sys:sap-ref-single nfp (stack-frame-offset 1 0)) + (sb!sys:sap-ref-single nfp (stack-frame-offset 1 1))))) (#.sb!vm:complex-double-stack-sc-number (with-nfp (nfp) (complex - (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))))) + (sb!sys:sap-ref-double nfp (stack-frame-offset 2 0)) + (sb!sys:sap-ref-double nfp (stack-frame-offset 2 2))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (with-nfp (nfp) (complex - (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) - (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset) - #!+sparc 4) - sb!vm:n-word-bytes))))) + (sb!sys:sap-ref-long nfp (stack-frame-offset 3 0)) + (sb!sys:sap-ref-long nfp + (stack-frame-offset 3 #!+sparc 4 + #!+(or x86 x86-64) 3 + #!-(or sparc x86 x86-64) 0))))) (#.sb!vm:control-stack-sc-number - (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset))) + (stack-ref fp (sb!c:sc-offset-offset sc-offset))) (#.sb!vm:character-stack-sc-number (with-nfp (nfp) - (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes))))) + (code-char (sb!sys:sap-ref-word nfp (stack-frame-offset 1 0))))) (#.sb!vm:unsigned-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:sap-ref-word nfp (stack-frame-offset 1 0)))) (#.sb!vm:signed-stack-sc-number (with-nfp (nfp) - (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)))) + (sb!sys:signed-sap-ref-word nfp (stack-frame-offset 1 0)))) (#.sb!vm:sap-stack-sc-number (with-nfp (nfp) - (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes))))))) - -#!+(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) - `(if escaped - (let ((,var (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)))) - ,@forms) - :invalid-value-for-unescaped-register-storage)) - (escaped-float-value (format) - `(if escaped - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - :invalid-value-for-unescaped-register-storage)) - (escaped-complex-float-value (format) - `(if escaped - (complex - (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) ',format) - (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format)) - :invalid-value-for-unescaped-register-storage))) - (ecase (sb!c:sc-offset-scn sc-offset) - ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) - (without-gcing - (with-escaped-value (val) - (make-lisp-obj val nil)))) - (#.sb!vm:character-reg-sc-number - (with-escaped-value (val) - (code-char val))) - (#.sb!vm:sap-reg-sc-number - (with-escaped-value (val) - (int-sap val))) - (#.sb!vm:signed-reg-sc-number - (with-escaped-value (val) - (if (logbitp (1- sb!vm:n-word-bits) val) - (logior val (ash -1 sb!vm:n-word-bits)) - val))) - (#.sb!vm:unsigned-reg-sc-number - (with-escaped-value (val) - val)) - (#.sb!vm:single-reg-sc-number - (escaped-float-value single-float)) - (#.sb!vm:double-reg-sc-number - (escaped-float-value double-float)) - #!+long-float - (#.sb!vm:long-reg-sc-number - (escaped-float-value long-float)) - (#.sb!vm:complex-single-reg-sc-number - (escaped-complex-float-value single-float)) - (#.sb!vm:complex-double-reg-sc-number - (escaped-complex-float-value double-float)) - #!+long-float - (#.sb!vm:complex-long-reg-sc-number - (escaped-complex-float-value long-float)) - (#.sb!vm:single-stack-sc-number - (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) - (#.sb!vm:double-stack-sc-number - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes)))) - #!+long-float - (#.sb!vm:long-stack-sc-number - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes)))) - (#.sb!vm:complex-single-stack-sc-number - (complex - (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))))) - (#.sb!vm:complex-double-stack-sc-number - (complex - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:n-word-bytes))))) - #!+long-float - (#.sb!vm:complex-long-stack-sc-number - (complex - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:n-word-bytes))))) - (#.sb!vm:control-stack-sc-number - (stack-ref fp (sb!c:sc-offset-offset sc-offset))) - (#.sb!vm:character-stack-sc-number - (code-char - (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-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)))) - (#.sb!vm:signed-stack-sc-number - (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))))))) + (sb!sys:sap-ref-sap nfp (stack-frame-offset 1 0))))))) ;;; This stores value as the value of DEBUG-VAR in FRAME. In the ;;; COMPILED-DEBUG-VAR case, access the current value to determine if @@ -2315,8 +2211,22 @@ register." (compiled-debug-var-sc-offset debug-var)) value)))) -#!-(or x86 x86-64) (defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) + ;; Like sub-access-debug-var-slot, this is the unification of two + ;; divergent copy-pasted functions. The astute reviewer will notice + ;; that long-floats are messed up here as well, that x86oids + ;; apparently don't support accessing float values that are in + ;; registers, and that non-x86oids store the real part of a float + ;; for both the real and imaginary parts of a complex on the stack + ;; (but not in registers, oddly enough). Some research has + ;; indicated that the different forms of THE used for validating the + ;; type of complex float components between x86oid and non-x86oid + ;; systems are only significant in the case of using a non-complex + ;; number as input (as the non-x86oid case effectively converts + ;; non-complex numbers to complex ones and the x86oid case will + ;; error out). That said, the error message from entering a value + ;; of the wrong type will be slightly easier to understand on x86oid + ;; systems. (macrolet ((set-escaped-value (val) `(if escaped (setf (sb!vm:context-register @@ -2332,7 +2242,24 @@ register." ',format) ,val) value)) + (set-escaped-complex-float-value (format offset val) + `(progn + (when escaped + (setf (sb!vm:context-float-register + escaped (sb!c:sc-offset-offset sc-offset) ',format) + (realpart value)) + (setf (sb!vm:context-float-register + escaped (+ (sb!c:sc-offset-offset sc-offset) ,offset) + ',format) + (imagpart value))) + ,val)) (with-nfp ((var) &body body) + ;; x86oids have no separate number stack, so dummy it + ;; up for them. + #!+(or x86 x86-64) + `(let ((,var fp)) + ,@body) + #!-(or x86 x86-64) `(let ((,var (if escaped (int-sap (sb!vm:context-register escaped @@ -2346,7 +2273,17 @@ register." (sap-ref-32 fp (* nfp-save-offset sb!vm:n-word-bytes)))))) - ,@body))) + ,@body)) + (stack-frame-offset (data-width offset) + #!+(or x86 x86-64) + `(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) + `(* (+ (sb!c:sc-offset-offset sc-offset) ,offset) + sb!vm:n-word-bytes))) (ecase (sb!c:sc-offset-scn sc-offset) ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number @@ -2362,214 +2299,108 @@ register." (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits))))) (#.sb!vm:unsigned-reg-sc-number (set-escaped-value value)) + #!-(or x86 x86-64) (#.sb!vm:non-descriptor-reg-sc-number (error "Local non-descriptor register access?")) + #!-(or x86 x86-64) (#.sb!vm:interior-reg-sc-number (error "Local interior register access?")) (#.sb!vm:single-reg-sc-number + #!-(or x86 x86-64) ;; don't have escaped floats. (set-escaped-float-value single-float value)) (#.sb!vm:double-reg-sc-number + #!-(or x86 x86-64) ;; don't have escaped floats -- still in npx? (set-escaped-float-value double-float value)) #!+long-float (#.sb!vm:long-reg-sc-number + #!-(or x86 x86-64) ;; don't have escaped floats -- still in npx? (set-escaped-float-value long-float value)) + #!-(or x86 x86-64) (#.sb!vm:complex-single-reg-sc-number - (when escaped - (setf (sb!vm:context-float-register escaped - (sb!c:sc-offset-offset sc-offset) - 'single-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped (1+ (sb!c:sc-offset-offset sc-offset)) - 'single-float) - (imagpart value))) - value) + (set-escaped-complex-float-value single-float 1 value)) + #!-(or x86 x86-64) (#.sb!vm:complex-double-reg-sc-number - (when escaped - (setf (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'double-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped - (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1) - 'double-float) - (imagpart value))) - value) - #!+long-float + (set-escaped-complex-float-value double-float #!+sparc 2 #!-sparc 1 value)) + #!+(and long-float (not (or x86 x86-64))) (#.sb!vm:complex-long-reg-sc-number - (when escaped - (setf (sb!vm:context-float-register - escaped (sb!c:sc-offset-offset sc-offset) 'long-float) - (realpart value)) - (setf (sb!vm:context-float-register - escaped - (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - 'long-float) - (imagpart value))) - value) + (set-escaped-complex-float-value long-float #!+sparc 4 #!-sparc 0 value)) (#.sb!vm:single-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-single nfp (stack-frame-offset 1 0)) (the single-float value)))) (#.sb!vm:double-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-double nfp (stack-frame-offset 2 0)) (the double-float value)))) #!+long-float (#.sb!vm:long-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-long nfp (stack-frame-offset 3 0)) (the long-float value)))) (#.sb!vm:complex-single-stack-sc-number (with-nfp (nfp) (setf (sap-ref-single - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + nfp (stack-frame-offset 1 0)) + #!+(or x86 x86-64) + (realpart (the (complex single-float) value)) + #!-(or x86 x86-64) (the single-float (realpart value))) (setf (sap-ref-single - nfp (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes)) + nfp (stack-frame-offset 1 1)) + #!+(or x86 x86-64) + (imagpart (the (complex single-float) value)) + #!-(or x86 x86-64) (the single-float (realpart value))))) (#.sb!vm:complex-double-stack-sc-number (with-nfp (nfp) (setf (sap-ref-double - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + nfp (stack-frame-offset 2 0)) + #!+(or x86 x86-64) + (realpart (the (complex double-float) value)) + #!-(or x86 x86-64) (the double-float (realpart value))) (setf (sap-ref-double - nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes)) + nfp (stack-frame-offset 2 2)) + #!+(or x86 x86-64) + (imagpart (the (complex double-float) value)) + #!-(or x86 x86-64) (the double-float (realpart value))))) #!+long-float (#.sb!vm:complex-long-stack-sc-number (with-nfp (nfp) (setf (sap-ref-long - nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)) + nfp (stack-frame-offset 3 0)) + #!+(or x86 x86-64) + (realpart (the (complex long-float) value)) + #!-(or x86 x86-64) (the long-float (realpart value))) (setf (sap-ref-long - nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4) - sb!vm:n-word-bytes)) + nfp (stack-frame-offset 3 #!+sparc 4 + #!+(or x86 x86-64) 3 + #!-(or sparc x86 x86-64) 0)) + #!+(or x86 x86-64) + (imagpart (the (complex long-float) value)) + #!-(or x86 x86-64) (the long-float (realpart value))))) (#.sb!vm:control-stack-sc-number (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value)) (#.sb!vm:character-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-word nfp (stack-frame-offset 1 0)) (char-code (the character value))))) (#.sb!vm:unsigned-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-word nfp (stack-frame-offset 1 0)) (the (unsigned-byte 32) value)))) (#.sb!vm:signed-stack-sc-number (with-nfp (nfp) - (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (signed-sap-ref-word nfp (stack-frame-offset 1 0)) (the (signed-byte 32) value)))) (#.sb!vm:sap-stack-sc-number (with-nfp (nfp) - (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset) - sb!vm:n-word-bytes)) + (setf (sap-ref-sap nfp (stack-frame-offset 1 0)) (the system-area-pointer value))))))) -#!+(or x86 x86-64) -(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped) - (macrolet ((set-escaped-value (val) - `(if escaped - (setf (sb!vm:context-register - escaped - (sb!c:sc-offset-offset sc-offset)) - ,val) - value))) - (ecase (sb!c:sc-offset-scn sc-offset) - ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number) - (without-gcing - (set-escaped-value - (get-lisp-obj-address value)))) - (#.sb!vm:character-reg-sc-number - (set-escaped-value (char-code value))) - (#.sb!vm:sap-reg-sc-number - (set-escaped-value (sap-int value))) - (#.sb!vm:signed-reg-sc-number - (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits))))) - (#.sb!vm:unsigned-reg-sc-number - (set-escaped-value value)) - (#.sb!vm:single-reg-sc-number - #+nil ;; don't have escaped floats. - (set-escaped-float-value single-float value)) - (#.sb!vm:double-reg-sc-number - #+nil ;; don't have escaped floats -- still in npx? - (set-escaped-float-value double-float value)) - #!+long-float - (#.sb!vm:long-reg-sc-number - #+nil ;; don't have escaped floats -- still in npx? - (set-escaped-float-value long-float value)) - (#.sb!vm:single-stack-sc-number - (setf (sap-ref-single - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (the single-float value))) - (#.sb!vm:double-stack-sc-number - (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (the double-float value))) - #!+long-float - (#.sb!vm:long-stack-sc-number - (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (the long-float value))) - (#.sb!vm:complex-single-stack-sc-number - (setf (sap-ref-single - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (realpart (the (complex single-float) value))) - (setf (sap-ref-single - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (imagpart (the (complex single-float) value)))) - (#.sb!vm:complex-double-stack-sc-number - (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2) - sb!vm:n-word-bytes))) - (realpart (the (complex double-float) value))) - (setf (sap-ref-double - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4) - sb!vm:n-word-bytes))) - (imagpart (the (complex double-float) value)))) - #!+long-float - (#.sb!vm:complex-long-stack-sc-number - (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3) - sb!vm:n-word-bytes))) - (realpart (the (complex long-float) value))) - (setf (sap-ref-long - fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6) - sb!vm:n-word-bytes))) - (imagpart (the (complex long-float) value)))) - (#.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-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-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-word - fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) - sb!vm:n-word-bytes))) - (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))) - (the system-area-pointer value)))))) - ;;; The method for setting and accessing COMPILED-DEBUG-VAR values use ;;; this to determine if the value stored is the actual value or an ;;; indirection cell. @@ -2588,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. @@ -2713,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 @@ -2728,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) @@ -2736,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 @@ -2768,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 @@ -3099,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)) @@ -3226,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) @@ -3295,13 +3219,12 @@ 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 - (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants) - length)) + (sb!c:allocate-code-object (1+ bogus-lra-constants) length)) (dst-start (code-instructions code-object))) (declare (type system-area-pointer src-start src-end dst-start trap-loc) @@ -3324,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