;;; 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
-;;; *COMPILED-DEBUG-FUNS*. If there already is a
-;;; COMPILED-DEBUG-FUN, then this returns it from
-;;; *COMPILED-DEBUG-FUNS*.
+;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its
+;;; component. This maps the latter to the former in
+;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN,
+;;; then this returns it from *COMPILED-DEBUG-FUNS*.
+;;;
+;;; FIXME: It seems this table can potentially grow without bounds,
+;;; and retains roots to functions that might otherwise be collected.
(defun make-compiled-debug-fun (compiler-debug-fun component)
- (or (gethash compiler-debug-fun *compiled-debug-funs*)
- (setf (gethash compiler-debug-fun *compiled-debug-funs*)
- (%make-compiled-debug-fun compiler-debug-fun component))))
+ (let ((table *compiled-debug-funs*))
+ (with-locked-hash-table (table)
+ (or (gethash compiler-debug-fun table)
+ (setf (gethash compiler-debug-fun table)
+ (%make-compiled-debug-fun compiler-debug-fun component))))))
(defstruct (bogus-debug-fun
(:include debug-fun)
(%function nil)))
(:copier nil))
%name)
-
-(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq))
\f
;;;; DEBUG-BLOCKs
(:copier nil))
;; code-location information for the block
(code-locations nil :type simple-vector))
-
-(defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
\f
;;;; breakpoints
;;; 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.
((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!c:find-saved-fp-and-pc fp)
+ (when saved-fp
+ (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.
(defun frame-down (frame)
(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
#!-(or x86 x86-64)
(defun compute-calling-frame (caller lra up-frame)
(declare (type system-area-pointer caller))
+ (/noshow0 "entering COMPUTE-CALLING-FRAME")
(when (control-stack-pointer-valid-p caller)
+ (/noshow0 "in WHEN")
(multiple-value-bind (code pc-offset escaped)
(if lra
(multiple-value-bind (word-offset code)
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset)))))
+ (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
(make-compiled-frame caller up-frame d-fun
(code-location-from-pc d-fun pc-offset
escaped)
(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)
#!-(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")
(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)
;; 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
;; 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))))))
+ ;; 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))))))
(values (%make-lisp-obj val) t)
(if errorp
(error "~S is not a valid argument to ~S"
(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!c:sc-offset-offset sc-offset) ,data-width ,offset)
+ sb!vm:n-word-bytes))
+ #!-(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!c:sc-offset-offset sc-offset) ,data-width ,offset)
+ sb!vm:n-word-bytes))
+ #!-(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.
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.
-;;; temporary buffer used to build form-number => source-path translation in
-;;; FORM-NUMBER-TRANSLATIONS
-(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-
-;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
-(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
-
;;; This returns a table mapping form numbers to source-paths. A
;;; source-path indicates a descent into the TOPLEVEL-FORM form,
;;; going directly to the subform corressponding to the form number.
;;; NODE-SOURCE-PATH; that is, the first element is the form number and
;;; the last is the TOPLEVEL-FORM number.
(defun form-number-translations (form tlf-number)
- (clrhash *form-number-circularity-table*)
- (setf (fill-pointer *form-number-temp*) 0)
- (sub-translate-form-numbers form (list tlf-number))
- (coerce *form-number-temp* 'simple-vector))
-(defun sub-translate-form-numbers (form path)
- (unless (gethash form *form-number-circularity-table*)
- (setf (gethash form *form-number-circularity-table*) t)
- (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
- *form-number-temp*)
- (let ((pos 0)
- (subform form)
- (trail form))
- (declare (fixnum pos))
- (macrolet ((frob ()
- '(progn
- (when (atom subform) (return))
- (let ((fm (car subform)))
- (when (consp fm)
- (sub-translate-form-numbers fm (cons pos path)))
- (incf pos))
- (setq subform (cdr subform))
- (when (eq subform trail) (return)))))
- (loop
- (frob)
- (frob)
- (setq trail (cdr trail)))))))
+ (let ((seen nil)
+ (translations (make-array 12 :fill-pointer 0 :adjustable t)))
+ (labels ((translate1 (form path)
+ (unless (member form seen)
+ (push form seen)
+ (vector-push-extend (cons (fill-pointer translations) path)
+ translations)
+ (let ((pos 0)
+ (subform form)
+ (trail form))
+ (declare (fixnum pos))
+ (macrolet ((frob ()
+ '(progn
+ (when (atom subform) (return))
+ (let ((fm (car subform)))
+ (when (consp fm)
+ (translate1 fm (cons pos path)))
+ (incf pos))
+ (setq subform (cdr subform))
+ (when (eq subform trail) (return)))))
+ (loop
+ (frob)
+ (frob)
+ (setq trail (cdr trail))))))))
+ (translate1 form (list tlf-number)))
+ (coerce translations 'simple-vector)))
;;; FORM is a top level form, and path is a source-path into it. This
;;; returns the form indicated by the source-path. Context is the
;;; This maps bogus-lra-components to cookies, so that
;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the
;;; breakpoint hook.
-(defvar *fun-end-cookies* (make-hash-table :test 'eq))
+(defvar *fun-end-cookies* (make-hash-table :test 'eq :synchronized t))
;;; This returns a hook function for the start helper breakpoint
;;; associated with a :FUN-END breakpoint. The returned function
;;;; breakpoint handlers (layer between C and exported interface)
;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
-(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
+(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq :synchronized t))
;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
;;; We use this when there are no longer any active breakpoints
;;; corresponding to DATA.
(defun delete-breakpoint-data (data)
+ ;; Again, this looks brittle. Is there no danger of being interrupted
+ ;; here?
(let* ((component (breakpoint-data-component data))
(offsets (delete (breakpoint-data-offset data)
(gethash component *component-breakpoint-offsets*)
;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
;;; [new C code].
(defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
+ ;; FIXME: This looks brittle: what if we are interrupted somewhere
+ ;; here? ...or do we have interrupts disabled here?
(delete-breakpoint-data data)
(let* ((scp
(locally
(trap-loc (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)
;; sense in signaling the condition.
(when step-info
(let ((*step-frame*
- #+(or x86 x86-64)
+ #!+(or x86 x86-64)
(signal-context-frame (sb!alien::alien-sap context))
- #-(or x86 x86-64)
+ #!-(or x86 x86-64)
;; KLUDGE: Use the first non-foreign frame as the
;; *STACK-TOP-HINT*. Getting the frame from the signal
;; context as on x86 would be cleaner, but
projects / sbcl.git / blobdiff