;;; 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
;; 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)))
\f
(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
#!-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)
(- (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)
(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
\f
;;; 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.
(defun find-saved-frame-down (fp up-frame)
(multiple-value-bind (saved-fp saved-pc) (sb!c:find-saved-fp-and-pc fp)
(when saved-fp
- (compute-calling-frame (descriptor-sap saved-fp) saved-pc up-frame))))
+ (compute-calling-frame (descriptor-sap saved-fp)
+ (descriptor-sap saved-pc)
+ up-frame))))
;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(#.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)
(#.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)))
(declare (type (unsigned-byte 32) n)
(optimize (speed 3) (safety 0)))
(sb!alien:sap-alien (sb!vm::current-thread-offset-sap
- (+ sb!vm::thread-interrupt-contexts-offset n))
+ (+ sb!vm::thread-interrupt-contexts-offset
+ #!-alpha n
+ #!+alpha (* 2 n)))
(* os-context-t)))
#!+(or x86 x86-64)
;;; 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.
(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
(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
(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
(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
(#.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
(#.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
(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
',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
(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
(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.
(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))
\f
;;;; breakpoints
projects / sbcl.git / blobdiff