(define-condition invalid-value (debug-condition)
((debug-var :reader invalid-value-debug-var :initarg :debug-var)
(frame :reader invalid-value-frame :initarg :frame))
(:report (lambda (condition stream)
(define-condition invalid-value (debug-condition)
((debug-var :reader invalid-value-debug-var :initarg :debug-var)
(frame :reader invalid-value-frame :initarg :frame))
(:report (lambda (condition stream)
(define-condition ambiguous-var-name (debug-condition)
((name :reader ambiguous-var-name-name :initarg :name)
(frame :reader ambiguous-var-name-frame :initarg :frame))
(:report (lambda (condition stream)
(define-condition ambiguous-var-name (debug-condition)
((name :reader ambiguous-var-name-name :initarg :name)
(frame :reader ambiguous-var-name-frame :initarg :frame))
(:report (lambda (condition stream)
- (format
- stream
- "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
- (frame-fun-mismatch-code-location condition)
- (frame-fun-mismatch-frame condition)
- (frame-fun-mismatch-form condition)))))
+ (format
+ stream
+ "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
+ (frame-fun-mismatch-code-location condition)
+ (frame-fun-mismatch-frame condition)
+ (frame-fun-mismatch-form condition)))))
;; This indicates whether someone interrupted the frame.
;; (unexported). If escaped, this is a pointer to the state that was
;; saved when we were interrupted, an os_context_t, i.e. the third
;; This indicates whether someone interrupted the frame.
;; (unexported). If escaped, this is a pointer to the state that was
;; saved when we were interrupted, an os_context_t, i.e. the third
;; This is the function invoked when execution encounters the
;; breakpoint. It takes a frame, the breakpoint, and optionally a
;; list of values. Values are supplied for :FUN-END breakpoints as
;; This is the function invoked when execution encounters the
;; breakpoint. It takes a frame, the breakpoint, and optionally a
;; list of values. Values are supplied for :FUN-END breakpoints as
- (:include code-location)
- (:constructor make-known-code-location
- (pc debug-fun %tlf-offset %form-number
- %live-set kind &aux (%unknown-p nil)))
- (:constructor make-compiled-code-location (pc debug-fun))
- (:copier nil))
+ (:include code-location)
+ (:constructor make-known-code-location
+ (pc debug-fun %tlf-offset %form-number
+ %live-set kind &aux (%unknown-p nil)))
+ (:constructor make-compiled-code-location (pc debug-fun))
+ (:copier nil))
- (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))
- (pc-offset (- (sap-int pc)
- (- (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)
- (values pc-offset code)))))
+ (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))
+ (pc-offset (- (sap-int pc)
+ (- (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)
+ (values pc-offset code)))))
- 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))))
+ 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))))
- (ra-pointer-valid-p lisp-ra)
- (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
- (ra-pointer-valid-p c-ra))
- #+nil (format t
- "*C Both valid ~S ~S ~S ~S~%"
- lisp-ocfp lisp-ra c-ocfp c-ra)
- ;; Look forward another step to check their validity.
- (let ((lisp-path-fp (x86-call-context lisp-ocfp
- :depth (1+ depth)))
- (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
- (cond ((and lisp-path-fp c-path-fp)
+ (ra-pointer-valid-p lisp-ra)
+ (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
+ (ra-pointer-valid-p c-ra))
+ #+nil (format t
+ "*C Both valid ~S ~S ~S ~S~%"
+ lisp-ocfp lisp-ra c-ocfp c-ra)
+ ;; Look forward another step to check their validity.
+ (let ((lisp-path-fp (x86-call-context lisp-ocfp
+ :depth (1+ depth)))
+ (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
+ (cond ((and lisp-path-fp c-path-fp)
- (lisp-path-fp
- ;; The lisp convention is looking good.
- #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
- (values lisp-ra lisp-ocfp))
- (c-path-fp
- ;; The C convention is looking good.
- #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
- (values c-ra c-ocfp))
- (t
- ;; Neither seems right?
- #+nil (format t "debug: no valid2 fp found ~S ~S~%"
- lisp-ocfp c-ocfp)
- nil))))
- ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
- (ra-pointer-valid-p lisp-ra))
- ;; The lisp convention is looking good.
- #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
- (values 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.
- #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
- (values c-ra c-ocfp))
- (t
- #+nil (format t "debug: no valid fp found ~S ~S~%"
- lisp-ocfp c-ocfp)
- nil))))))
+ (lisp-path-fp
+ ;; The lisp convention is looking good.
+ #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
+ (values lisp-ra lisp-ocfp))
+ (c-path-fp
+ ;; The C convention is looking good.
+ #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
+ (values c-ra c-ocfp))
+ (t
+ ;; Neither seems right?
+ #+nil (format t "debug: no valid2 fp found ~S ~S~%"
+ lisp-ocfp c-ocfp)
+ nil))))
+ ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
+ (ra-pointer-valid-p lisp-ra))
+ ;; The lisp convention is looking good.
+ #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
+ (values 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.
+ #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
+ (values c-ra c-ocfp))
+ (t
+ #+nil (format t "debug: no valid fp found ~S ~S~%"
+ lisp-ocfp c-ocfp)
+ nil))))))
- (let ((debug-fun (frame-debug-fun frame)))
- (/noshow0 "in DOWN :UNPARSED case")
- (setf (frame-%down frame)
- (etypecase debug-fun
- (compiled-debug-fun
- (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
- debug-fun)))
- (compute-calling-frame
- (descriptor-sap
- (get-context-value
- frame ocfp-save-offset
- (sb!c::compiled-debug-fun-old-fp c-d-f)))
- (get-context-value
- frame lra-save-offset
- (sb!c::compiled-debug-fun-return-pc c-d-f))
- frame)))
- (bogus-debug-fun
- (let ((fp (frame-pointer frame)))
- (when (control-stack-pointer-valid-p fp)
- #!+(or x86 x86-64)
- (multiple-value-bind (ra ofp) (x86-call-context fp)
- (and ra (compute-calling-frame ofp ra frame)))
- #!-(or x86 x86-64)
- (compute-calling-frame
- #!-alpha
- (sap-ref-sap fp (* ocfp-save-offset
- sb!vm:n-word-bytes))
- #!+alpha
- (int-sap
- (sap-ref-32 fp (* ocfp-save-offset
- sb!vm:n-word-bytes)))
-
- (stack-ref fp lra-save-offset)
-
- frame)))))))
- down)))
+ (let ((debug-fun (frame-debug-fun frame)))
+ (/noshow0 "in DOWN :UNPARSED case")
+ (setf (frame-%down frame)
+ (etypecase debug-fun
+ (compiled-debug-fun
+ (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
+ debug-fun)))
+ (compute-calling-frame
+ (descriptor-sap
+ (get-context-value
+ frame ocfp-save-offset
+ (sb!c::compiled-debug-fun-old-fp c-d-f)))
+ (get-context-value
+ frame lra-save-offset
+ (sb!c::compiled-debug-fun-return-pc c-d-f))
+ frame)))
+ (bogus-debug-fun
+ (let ((fp (frame-pointer frame)))
+ (when (control-stack-pointer-valid-p fp)
+ #!+(or x86 x86-64)
+ (multiple-value-bind (ra ofp) (x86-call-context fp)
+ (and ra (compute-calling-frame ofp ra frame)))
+ #!-(or x86 x86-64)
+ (compute-calling-frame
+ #!-alpha
+ (sap-ref-sap fp (* ocfp-save-offset
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 fp (* ocfp-save-offset
+ sb!vm:n-word-bytes)))
+
+ (stack-ref fp lra-save-offset)
+
+ frame)))))))
+ down)))
- (type sb!c:sc-offset loc))
- (let ((pointer (frame-pointer frame))
- (escaped (compiled-frame-escaped frame)))
- (if escaped
- (sub-access-debug-var-slot pointer loc escaped)
- (ecase stack-slot
- (#.ocfp-save-offset
- (stack-ref pointer stack-slot))
- (#.lra-save-offset
- (sap-ref-sap pointer (- (* (1+ stack-slot)
- sb!vm::n-word-bytes))))))))
-
-#!-(or x86 x86-64)
-(defun (setf get-context-value) (value frame stack-slot loc)
- (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
- (type sb!c:sc-offset loc))
+ (type sb!c:sc-offset loc))
- (sub-set-debug-var-slot pointer loc value escaped)
- (ecase 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))))))
+ (sub-set-debug-var-slot pointer loc value escaped)
+ #!-(or x86 x86-64)
+ (setf (stack-ref pointer stack-slot) value)
+ #!+(or x86 x86-64)
+ (ecase 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))))))
- (if lra
- (multiple-value-bind (word-offset code)
- (if (fixnump lra)
- (let ((fp (frame-pointer up-frame)))
- (values lra
- (stack-ref fp (1+ lra-save-offset))))
- (values (get-header-data lra)
- (lra-code-header lra)))
- (if code
- (values code
- (* (1+ (- word-offset (get-header-data code)))
- sb!vm:n-word-bytes)
- nil)
- (values :foreign-function
- 0
- nil)))
- (find-escaped-frame caller))
+ (if lra
+ (multiple-value-bind (word-offset code)
+ (if (fixnump lra)
+ (let ((fp (frame-pointer up-frame)))
+ (values lra
+ (stack-ref fp (1+ lra-save-offset))))
+ (values (get-header-data lra)
+ (lra-code-header lra)))
+ (if code
+ (values code
+ (* (1+ (- word-offset (get-header-data code)))
+ sb!vm:n-word-bytes)
+ nil)
+ (values :foreign-function
+ 0
+ nil)))
+ (find-escaped-frame caller))
- (eq (%code-debug-info code) :bogus-lra))
- (let ((real-lra (code-header-ref code real-lra-slot)))
- (compute-calling-frame caller real-lra up-frame))
- (let ((d-fun (case code
- (:undefined-function
- (make-bogus-debug-fun
- "undefined function"))
- (:foreign-function
- (make-bogus-debug-fun
- (foreign-function-backtrace-name
- (int-sap (get-lisp-obj-address lra)))))
- ((nil)
- (make-bogus-debug-fun
- "bogus stack frame"))
- (t
- (debug-fun-from-pc code pc-offset)))))
- (make-compiled-frame caller up-frame d-fun
- (code-location-from-pc d-fun pc-offset
- escaped)
- (if up-frame (1+ (frame-number up-frame)) 0)
- escaped))))))
+ (eq (%code-debug-info code) :bogus-lra))
+ (let ((real-lra (code-header-ref code real-lra-slot)))
+ (compute-calling-frame caller real-lra up-frame))
+ (let ((d-fun (case code
+ (:undefined-function
+ (make-bogus-debug-fun
+ "undefined function"))
+ (:foreign-function
+ (make-bogus-debug-fun
+ (foreign-function-backtrace-name
+ (int-sap (get-lisp-obj-address lra)))))
+ ((nil)
+ (make-bogus-debug-fun
+ "bogus stack frame"))
+ (t
+ (debug-fun-from-pc code pc-offset)))))
+ (make-compiled-frame caller up-frame d-fun
+ (code-location-from-pc d-fun pc-offset
+ escaped)
+ (if up-frame (1+ (frame-number up-frame)) 0)
+ escaped))))))
+
- ;; If it's escaped it may be a function end breakpoint trap.
- (when (and (code-component-p code)
- (eq (%code-debug-info code) :bogus-lra))
- ;; If :bogus-lra grab the real lra.
- (setq pc-offset (code-header-ref
- code (1+ real-lra-slot)))
- (setq code (code-header-ref code real-lra-slot))
- (aver code)))
- ((not escaped)
- (multiple-value-setq (pc-offset code)
- (compute-lra-data-from-pc ra))
- (unless code
- (setf code :foreign-function
- pc-offset 0))))
+ ;; If it's escaped it may be a function end breakpoint trap.
+ (when (and (code-component-p code)
+ (eq (%code-debug-info code) :bogus-lra))
+ ;; If :bogus-lra grab the real lra.
+ (setq pc-offset (code-header-ref
+ code (1+ real-lra-slot)))
+ (setq code (code-header-ref code real-lra-slot))
+ (aver code)))
+ ((not escaped)
+ (multiple-value-setq (pc-offset code)
+ (compute-lra-data-from-pc ra))
+ (unless code
+ (setf code :foreign-function
+ pc-offset 0))))
- (:undefined-function
- (make-bogus-debug-fun
- "undefined function"))
- (:foreign-function
- (make-bogus-debug-fun
- (foreign-function-backtrace-name ra)))
- ((nil)
- (make-bogus-debug-fun
- "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)
- (if up-frame (1+ (frame-number up-frame)) 0)
- escaped)))))
+ (:undefined-function
+ (make-bogus-debug-fun
+ "undefined function"))
+ (:foreign-function
+ (make-bogus-debug-fun
+ (foreign-function-backtrace-name ra)))
+ ((nil)
+ (make-bogus-debug-fun
+ "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)
+ (if up-frame (1+ (frame-number up-frame)) 0)
+ escaped)))))
- (/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
- (- (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)))))))))
+ (/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
+ (- (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)))))))))
- (sb!vm:context-register scp sb!vm::cfp-offset))
- (without-gcing
- (let ((code (code-object-from-bits
- (sb!vm:context-register scp sb!vm::code-offset))))
- (when (symbolp code)
- (return (values code 0 scp)))
- (let* ((code-header-len (* (get-header-data code)
- sb!vm:n-word-bytes))
- (pc-offset
+ (sb!vm:context-register scp sb!vm::cfp-offset))
+ (without-gcing
+ (let ((code (code-object-from-bits
+ (sb!vm:context-register scp sb!vm::code-offset))))
+ (when (symbolp code)
+ (return (values code 0 scp)))
+ (let* ((code-header-len (* (get-header-data code)
+ sb!vm:n-word-bytes))
+ (pc-offset
- (setf pc-offset 0)))))
- (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))))))))))
+ (setf pc-offset 0)))))
+ (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 (fun-code-header object)
- :undefined-function)
- (let ((lowtag (lowtag-of object)))
- (if (= lowtag sb!vm:other-pointer-lowtag)
- (let ((widetag (widetag-of object)))
- (cond ((= widetag sb!vm:code-header-widetag)
- object)
- ((= widetag sb!vm:return-pc-header-widetag)
- (lra-code-header object))
- (t
- nil))))))))
+ (or (fun-code-header object)
+ :undefined-function)
+ (let ((lowtag (lowtag-of object)))
+ (when (= lowtag sb!vm:other-pointer-lowtag)
+ (let ((widetag (widetag-of object)))
+ (cond ((= widetag sb!vm:code-header-widetag)
+ object)
+ ((= widetag sb!vm:return-pc-header-widetag)
+ (lra-code-header object))
+ (t
+ nil))))))))
- (len (length fun-map)))
- (declare (type simple-vector fun-map))
- (if (= len 1)
- (make-compiled-debug-fun (svref fun-map 0) component)
- (let ((i 1)
- (elsewhere-p
- (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
- (svref fun-map 0)))))
- (declare (type sb!int:index i))
- (loop
- (when (or (= i len)
- (< pc (if elsewhere-p
- (sb!c::compiled-debug-fun-elsewhere-pc
- (svref fun-map (1+ i)))
- (svref fun-map i))))
- (return (make-compiled-debug-fun
- (svref fun-map (1- i))
- component)))
- (incf i 2)))))))))
+ (len (length fun-map)))
+ (declare (type simple-vector fun-map))
+ (if (= len 1)
+ (make-compiled-debug-fun (svref fun-map 0) component)
+ (let ((i 1)
+ (elsewhere-p
+ (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
+ (svref fun-map 0)))))
+ (declare (type sb!int:index i))
+ (loop
+ (when (or (= i len)
+ (< pc (if elsewhere-p
+ (sb!c::compiled-debug-fun-elsewhere-pc
+ (svref fun-map (1+ i)))
+ (svref fun-map i))))
+ (return (make-compiled-debug-fun
+ (svref fun-map (1- i))
+ component)))
+ (incf i 2)))))))))
- escaped
- (let ((data (breakpoint-data
- (compiled-debug-fun-component debug-fun)
- pc nil)))
- (when (and data (breakpoint-data-breakpoints data))
- (let ((what (breakpoint-what
- (first (breakpoint-data-breakpoints data)))))
- (when (compiled-code-location-p what)
- what)))))
+ escaped
+ (let ((data (breakpoint-data
+ (compiled-debug-fun-component debug-fun)
+ pc nil)))
+ (when (and data (breakpoint-data-breakpoints data))
+ (let ((what (breakpoint-what
+ (first (breakpoint-data-breakpoints data)))))
+ (when (compiled-code-location-p what)
+ what)))))
- finally (return (nreverse reversed-result))
- do
- (when (sap= fp
- #!-alpha
- (sap-ref-sap catch
- (* sb!vm:catch-block-current-cont-slot
- sb!vm:n-word-bytes))
- #!+alpha
- (int-sap
- (sap-ref-32 catch
- (* sb!vm:catch-block-current-cont-slot
- sb!vm:n-word-bytes))))
- (let* (#!-(or x86 x86-64)
- (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
- #!+(or x86 x86-64)
- (ra (sap-ref-sap
- catch (* sb!vm:catch-block-entry-pc-slot
- sb!vm:n-word-bytes)))
- #!-(or x86 x86-64)
- (component
- (stack-ref catch sb!vm:catch-block-current-code-slot))
- #!+(or x86 x86-64)
- (component (component-from-component-ptr
- (component-ptr-from-pc ra)))
- (offset
- #!-(or x86 x86-64)
- (* (- (1+ (get-header-data lra))
- (get-header-data component))
- sb!vm:n-word-bytes)
- #!+(or x86 x86-64)
- (- (sap-int ra)
- (- (get-lisp-obj-address component)
- sb!vm:other-pointer-lowtag)
- (* (get-header-data component) sb!vm:n-word-bytes))))
- (push (cons #!-(or x86 x86-64)
- (stack-ref catch sb!vm:catch-block-tag-slot)
- #!+(or x86 x86-64)
- (make-lisp-obj
- (sap-ref-word catch (* sb!vm:catch-block-tag-slot
- sb!vm:n-word-bytes)))
- (make-compiled-code-location
- offset (frame-debug-fun frame)))
- reversed-result)))
- (setf catch
- #!-alpha
- (sap-ref-sap catch
- (* sb!vm:catch-block-previous-catch-slot
- sb!vm:n-word-bytes))
- #!+alpha
- (int-sap
- (sap-ref-32 catch
- (* sb!vm:catch-block-previous-catch-slot
- sb!vm:n-word-bytes)))))))
+ finally (return (nreverse reversed-result))
+ do
+ (when (sap= fp
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:n-word-bytes))))
+ (let* (#!-(or x86 x86-64)
+ (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
+ #!+(or x86 x86-64)
+ (ra (sap-ref-sap
+ catch (* sb!vm:catch-block-entry-pc-slot
+ sb!vm:n-word-bytes)))
+ #!-(or x86 x86-64)
+ (component
+ (stack-ref catch sb!vm:catch-block-current-code-slot))
+ #!+(or x86 x86-64)
+ (component (component-from-component-ptr
+ (component-ptr-from-pc ra)))
+ (offset
+ #!-(or x86 x86-64)
+ (* (- (1+ (get-header-data lra))
+ (get-header-data component))
+ sb!vm:n-word-bytes)
+ #!+(or x86 x86-64)
+ (- (sap-int ra)
+ (- (get-lisp-obj-address component)
+ sb!vm:other-pointer-lowtag)
+ (* (get-header-data component) sb!vm:n-word-bytes))))
+ (push (cons #!-(or x86 x86-64)
+ (stack-ref catch sb!vm:catch-block-tag-slot)
+ #!+(or x86 x86-64)
+ (make-lisp-obj
+ (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+ sb!vm:n-word-bytes)))
+ (make-compiled-code-location
+ offset (frame-debug-fun frame)))
+ reversed-result)))
+ (setf catch
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:n-word-bytes)))))))
`(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
(declare (simple-vector ,blocks))
(dotimes (,i (length ,blocks) ,result)
`(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
(declare (simple-vector ,blocks))
(dotimes (,i (length ,blocks) ,result)
- (dotimes (,i (length ,vars) ,result)
- (let ((,var (svref ,vars ,i)))
- ,@body))
- ,result))))
+ (dotimes (,i (length ,vars) ,result)
+ (let ((,var (svref ,vars ,i)))
+ ,@body))
+ ,result))))
- (setf (debug-fun-%function debug-fun)
- (etypecase debug-fun
- (compiled-debug-fun
- (let ((component
- (compiled-debug-fun-component debug-fun))
- (start-pc
- (sb!c::compiled-debug-fun-start-pc
- (compiled-debug-fun-compiler-debug-fun debug-fun))))
- (do ((entry (%code-entry-points component)
- (%simple-fun-next entry)))
- ((null entry) nil)
- (when (= start-pc
- (sb!c::compiled-debug-fun-start-pc
- (compiled-debug-fun-compiler-debug-fun
- (fun-debug-fun entry))))
- (return entry)))))
- (bogus-debug-fun nil)))
- cached-value)))
+ (setf (debug-fun-%function debug-fun)
+ (etypecase debug-fun
+ (compiled-debug-fun
+ (let ((component
+ (compiled-debug-fun-component debug-fun))
+ (start-pc
+ (sb!c::compiled-debug-fun-start-pc
+ (compiled-debug-fun-compiler-debug-fun debug-fun))))
+ (do ((entry (%code-entry-points component)
+ (%simple-fun-next entry)))
+ ((null entry) nil)
+ (when (= start-pc
+ (sb!c::compiled-debug-fun-start-pc
+ (compiled-debug-fun-compiler-debug-fun
+ (fun-debug-fun entry))))
+ (return entry)))))
+ (bogus-debug-fun nil)))
+ cached-value)))
- (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)))))))
+ (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)))))))
;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
- (let* ((len (length variables))
- (prefix-len (length name-prefix-string))
- (pos (find-var name-prefix-string variables len))
- (res nil))
- (when pos
- ;; Find names from pos to variable's len that contain prefix.
- (do ((i pos (1+ i)))
- ((= i len))
- (let* ((var (svref variables i))
- (name (debug-var-symbol-name var))
- (name-len (length name)))
- (declare (simple-string name))
- (when (/= (or (string/= name-prefix-string name
- :end1 prefix-len :end2 name-len)
- prefix-len)
- prefix-len)
- (return))
- (push var res)))
- (setq res (nreverse res)))
- res))))
+ (let* ((len (length variables))
+ (prefix-len (length name-prefix-string))
+ (pos (find-var name-prefix-string variables len))
+ (res nil))
+ (when pos
+ ;; Find names from pos to variable's len that contain prefix.
+ (do ((i pos (1+ i)))
+ ((= i len))
+ (let* ((var (svref variables i))
+ (name (debug-var-symbol-name var))
+ (name-len (length name)))
+ (declare (simple-string name))
+ (when (/= (or (string/= name-prefix-string name
+ :end1 prefix-len :end2 name-len)
+ prefix-len)
+ prefix-len)
+ (return))
+ (push var res)))
+ (setq res (nreverse res)))
+ res))))
;;; This returns a position in VARIABLES for one containing NAME as an
;;; initial substring. END is the length of VARIABLES if supplied.
(defun find-var (name variables &optional end)
(declare (simple-vector variables)
;;; This returns a position in VARIABLES for one containing NAME as an
;;; initial substring. END is the length of VARIABLES if supplied.
(defun find-var (name variables &optional end)
(declare (simple-vector variables)
- :test (lambda (x y)
- (let* ((y (debug-var-symbol-name y))
- (y-len (length y)))
- (declare (simple-string y))
- (and (>= y-len name-len)
- (string= x y :end1 name-len :end2 name-len))))
- :end (or end (length variables)))))
+ :test (lambda (x y)
+ (let* ((y (debug-var-symbol-name y))
+ (y-len (length y)))
+ (declare (simple-string y))
+ (and (>= y-len name-len)
+ (string= x y :end1 name-len :end2 name-len))))
+ :end (or end (length variables)))))
- (multiple-value-bind (args argsp)
- (parse-compiled-debug-fun-lambda-list debug-fun)
- (setf (debug-fun-%lambda-list debug-fun) args)
- (if argsp
- args
- (debug-signal 'lambda-list-unavailable
- :debug-fun debug-fun))))
- (lambda-list)
- ((bogus-debug-fun-p debug-fun)
- nil)
- ((sb!c::compiled-debug-fun-arguments
- (compiled-debug-fun-compiler-debug-fun debug-fun))
- ;; If the packed information is there (whether empty or not) as
- ;; opposed to being nil, then returned our cached value (nil).
- nil)
- (t
- ;; Our cached value is nil, and the packed lambda-list information
- ;; is nil, so we don't have anything available.
- (debug-signal 'lambda-list-unavailable
- :debug-fun debug-fun)))))
+ (multiple-value-bind (args argsp)
+ (parse-compiled-debug-fun-lambda-list debug-fun)
+ (setf (debug-fun-%lambda-list debug-fun) args)
+ (if argsp
+ args
+ (debug-signal 'lambda-list-unavailable
+ :debug-fun debug-fun))))
+ (lambda-list)
+ ((bogus-debug-fun-p debug-fun)
+ nil)
+ ((sb!c::compiled-debug-fun-arguments
+ (compiled-debug-fun-compiler-debug-fun debug-fun))
+ ;; If the packed information is there (whether empty or not) as
+ ;; opposed to being nil, then returned our cached value (nil).
+ nil)
+ (t
+ ;; Our cached value is nil, and the packed lambda-list information
+ ;; is nil, so we don't have anything available.
+ (debug-signal 'lambda-list-unavailable
+ :debug-fun debug-fun)))))
- (i 0)
- (len (length args))
- (res nil)
- (optionalp nil))
- (declare (type (or null simple-vector) vars))
- (loop
- (when (>= i len) (return))
- (let ((ele (aref args i)))
- (cond
- ((symbolp ele)
- (case ele
- (sb!c::deleted
- ;; Deleted required arg at beginning of args array.
- (push :deleted res))
- (sb!c::optional-args
- (setf optionalp t))
- (sb!c::supplied-p
- ;; SUPPLIED-P var immediately following keyword or
- ;; optional. Stick the extra var in the result
- ;; element representing the keyword or optional,
- ;; which is the previous one.
+ (i 0)
+ (len (length args))
+ (res nil)
+ (optionalp nil))
+ (declare (type (or null simple-vector) vars))
+ (loop
+ (when (>= i len) (return))
+ (let ((ele (aref args i)))
+ (cond
+ ((symbolp ele)
+ (case ele
+ (sb!c::deleted
+ ;; Deleted required arg at beginning of args array.
+ (push :deleted res))
+ (sb!c::optional-args
+ (setf optionalp t))
+ (sb!c::supplied-p
+ ;; SUPPLIED-P var immediately following keyword or
+ ;; optional. Stick the extra var in the result
+ ;; element representing the keyword or optional,
+ ;; which is the previous one.
- (nconc (car res)
- (list (compiled-debug-fun-lambda-list-var
- args (incf i) vars))))
- (sb!c::rest-arg
- (push (list :rest
- (compiled-debug-fun-lambda-list-var
- 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)
- (t
- ;; &KEY arg
- (push (list :keyword
- ele
- (compiled-debug-fun-lambda-list-var
- args (incf i) vars))
- res))))
- (optionalp
- ;; We saw an optional marker, so the following
- ;; non-symbols are indexes indicating optional
- ;; variables.
- (push (list :optional (svref vars ele)) res))
- (t
- ;; Required arg at beginning of args array.
- (push (svref vars ele) res))))
- (incf i))
- (values (nreverse res) t))))))
+ (nconc (car res)
+ (list (compiled-debug-fun-lambda-list-var
+ args (incf i) vars))))
+ (sb!c::rest-arg
+ (push (list :rest
+ (compiled-debug-fun-lambda-list-var
+ 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)
+ (t
+ ;; &KEY arg
+ (push (list :keyword
+ ele
+ (compiled-debug-fun-lambda-list-var
+ args (incf i) vars))
+ res))))
+ (optionalp
+ ;; We saw an optional marker, so the following
+ ;; non-symbols are indexes indicating optional
+ ;; variables.
+ (push (list :optional (svref vars ele)) res))
+ (t
+ ;; Required arg at beginning of args array.
+ (push (svref vars ele) res))))
+ (incf i))
+ (values (nreverse res) t))))))
- (let ((,buffer-var *parsing-buffer*)
- ,@(if other-var `((,other-var *other-parsing-buffer*))))
- (setf (fill-pointer ,buffer-var) 0)
- ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
- (macrolet ((result (buf)
- `(let* ((,',len (length ,buf))
- (,',res (make-array ,',len)))
- (replace ,',res ,buf :end1 ,',len :end2 ,',len)
- (fill ,buf nil :end ,',len)
- (setf (fill-pointer ,buf) 0)
- ,',res)))
- ,@body))
+ (let ((,buffer-var *parsing-buffer*)
+ ,@(if other-var `((,other-var *other-parsing-buffer*))))
+ (setf (fill-pointer ,buffer-var) 0)
+ ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
+ (macrolet ((result (buf)
+ `(let* ((,',len (length ,buf))
+ (,',res (make-array ,',len)))
+ (replace ,',res ,buf :end1 ,',len :end2 ,',len)
+ (fill ,buf nil :end ,',len)
+ (setf (fill-pointer ,buf) 0)
+ ,',res)))
+ ,@body))
- (setf (debug-fun-blocks debug-fun)
- (parse-debug-blocks debug-fun))
- (unless (debug-fun-blocks debug-fun)
- (debug-signal 'no-debug-blocks
- :debug-fun debug-fun))
- (debug-fun-blocks debug-fun))
- (blocks)
- (t
- (debug-signal 'no-debug-blocks
- :debug-fun debug-fun)))))
+ (setf (debug-fun-blocks debug-fun)
+ (parse-debug-blocks debug-fun))
+ (unless (debug-fun-blocks debug-fun)
+ (debug-signal 'no-debug-blocks
+ :debug-fun debug-fun))
+ (debug-fun-blocks debug-fun))
+ (blocks)
+ (t
+ (debug-signal 'no-debug-blocks
+ :debug-fun debug-fun)))))
- (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
- debug-fun))
- (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
- ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
- ;; element size of the packed binary representation of the
- ;; blocks data.
- (live-set-len (ceiling var-count 8))
- (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
+ (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
+ debug-fun))
+ (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
+ ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
+ ;; element size of the packed binary representation of the
+ ;; blocks data.
+ (live-set-len (ceiling var-count 8))
+ (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
(unless blocks
(return-from parse-compiled-debug-blocks nil))
(macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
(with-parsing-buffer (blocks-buffer locations-buffer)
(unless blocks
(return-from parse-compiled-debug-blocks nil))
(macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
(with-parsing-buffer (blocks-buffer locations-buffer)
- (let ((i 0)
- (len (length blocks))
- (last-pc 0))
- (loop
- (when (>= i len) (return))
- (let ((succ-and-flags (aref+ blocks i))
- (successors nil))
- (declare (type (unsigned-byte 8) succ-and-flags)
- (list successors))
- (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
- succ-and-flags))
- (push (sb!c:read-var-integer blocks i) successors))
- (let* ((locations
- (dotimes (k (sb!c:read-var-integer blocks i)
- (result locations-buffer))
- (let ((kind (svref sb!c::*compiled-code-location-kinds*
- (aref+ blocks i)))
- (pc (+ last-pc
- (sb!c:read-var-integer blocks i)))
- (tlf-offset (or tlf-number
- (sb!c:read-var-integer blocks i)))
- (form-number (sb!c:read-var-integer blocks i))
- (live-set (sb!c:read-packed-bit-vector
- live-set-len blocks i)))
- (vector-push-extend (make-known-code-location
- pc debug-fun tlf-offset
- form-number live-set kind)
- locations-buffer)
- (setf last-pc pc))))
- (block (make-compiled-debug-block
- locations successors
- (not (zerop (logand
- sb!c::compiled-debug-block-elsewhere-p
- succ-and-flags))))))
- (vector-push-extend block blocks-buffer)
- (dotimes (k (length locations))
- (setf (code-location-%debug-block (svref locations k))
- block))))))
- (let ((res (result blocks-buffer)))
- (declare (simple-vector res))
- (dotimes (i (length res))
- (let* ((block (svref res i))
- (succs nil))
- (dolist (ele (debug-block-successors block))
- (push (svref res ele) succs))
- (setf (debug-block-successors block) succs)))
- res)))))
+ (let ((i 0)
+ (len (length blocks))
+ (last-pc 0))
+ (loop
+ (when (>= i len) (return))
+ (let ((succ-and-flags (aref+ blocks i))
+ (successors nil))
+ (declare (type (unsigned-byte 8) succ-and-flags)
+ (list successors))
+ (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
+ succ-and-flags))
+ (push (sb!c:read-var-integer blocks i) successors))
+ (let* ((locations
+ (dotimes (k (sb!c:read-var-integer blocks i)
+ (result locations-buffer))
+ (let ((kind (svref sb!c::*compiled-code-location-kinds*
+ (aref+ blocks i)))
+ (pc (+ last-pc
+ (sb!c:read-var-integer blocks i)))
+ (tlf-offset (or tlf-number
+ (sb!c:read-var-integer blocks i)))
+ (form-number (sb!c:read-var-integer blocks i))
+ (live-set (sb!c:read-packed-bit-vector
+ live-set-len blocks i)))
+ (vector-push-extend (make-known-code-location
+ pc debug-fun tlf-offset
+ form-number live-set kind)
+ locations-buffer)
+ (setf last-pc pc))))
+ (block (make-compiled-debug-block
+ locations successors
+ (not (zerop (logand
+ sb!c::compiled-debug-block-elsewhere-p
+ succ-and-flags))))))
+ (vector-push-extend block blocks-buffer)
+ (dotimes (k (length locations))
+ (setf (code-location-%debug-block (svref locations k))
+ block))))))
+ (let ((res (result blocks-buffer)))
+ (declare (simple-vector res))
+ (dotimes (i (length res))
+ (let* ((block (svref res i))
+ (succs nil))
+ (dolist (ele (debug-block-successors block))
+ (push (svref res ele) succs))
+ (setf (debug-block-successors block) succs)))
+ res)))))
- (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
- ((>= i (length packed-vars))
- (let ((result (coerce buffer 'simple-vector)))
- (when args-minimal
- (assign-minimal-var-names result))
- result))
- (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
- (let* ((flags (geti))
- (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
- (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
- (live (logtest sb!c::compiled-debug-var-environment-live
- flags))
- (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
- (symbol (if minimal nil (geti)))
- (id (if (logtest sb!c::compiled-debug-var-id-p flags)
- (geti)
- 0))
- (sc-offset (if deleted 0 (geti)))
- (save-sc-offset (if save (geti) nil)))
- (aver (not (and args-minimal (not minimal))))
- (vector-push-extend (make-compiled-debug-var symbol
- id
- live
- sc-offset
- save-sc-offset)
- buffer)))))))
+ (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+ ((>= i (length packed-vars))
+ (let ((result (coerce buffer 'simple-vector)))
+ (when args-minimal
+ (assign-minimal-var-names result))
+ result))
+ (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
+ (let* ((flags (geti))
+ (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
+ (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
+ (live (logtest sb!c::compiled-debug-var-environment-live
+ flags))
+ (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
+ (symbol (if minimal nil (geti)))
+ (id (if (logtest sb!c::compiled-debug-var-id-p flags)
+ (geti)
+ 0))
+ (sc-offset (if deleted 0 (geti)))
+ (save-sc-offset (if save (geti) nil)))
+ (aver (not (and args-minimal (not minimal))))
+ (vector-push-extend (make-compiled-debug-var symbol
+ id
+ live
+ sc-offset
+ save-sc-offset)
+ buffer)))))))
- (etypecase basic-code-location
- (compiled-code-location
- (compute-compiled-code-location-debug-block 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.)
- )
- block)))
+ (etypecase basic-code-location
+ (compiled-code-location
+ (compute-compiled-code-location-debug-block 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.)
+ )
+ block)))
- (if (= len 1)
- (svref blocks 0)
- (do ((i 1 (1+ i))
- (end (1- len)))
- ((= i end)
- (let ((last (svref blocks end)))
- (cond
- ((debug-block-elsewhere-p last)
- (if (< pc
- (sb!c::compiled-debug-fun-elsewhere-pc
- (compiled-debug-fun-compiler-debug-fun
- debug-fun)))
- (svref blocks (1- end))
- last))
- ((< pc
- (compiled-code-location-pc
- (svref (compiled-debug-block-code-locations last)
- 0)))
- (svref blocks (1- end)))
- (t last))))
- (declare (type index i end))
- (when (< pc
- (compiled-code-location-pc
- (svref (compiled-debug-block-code-locations
- (svref blocks i))
- 0)))
- (return (svref blocks (1- i)))))))))
+ (if (= len 1)
+ (svref blocks 0)
+ (do ((i 1 (1+ i))
+ (end (1- len)))
+ ((= i end)
+ (let ((last (svref blocks end)))
+ (cond
+ ((debug-block-elsewhere-p last)
+ (if (< pc
+ (sb!c::compiled-debug-fun-elsewhere-pc
+ (compiled-debug-fun-compiler-debug-fun
+ debug-fun)))
+ (svref blocks (1- end))
+ last))
+ ((< pc
+ (compiled-code-location-pc
+ (svref (compiled-debug-block-code-locations last)
+ 0)))
+ (svref blocks (1- end)))
+ (t last))))
+ (declare (type index i end))
+ (when (< pc
+ (compiled-code-location-pc
+ (svref (compiled-debug-block-code-locations
+ (svref blocks i))
+ 0)))
+ (return (svref blocks (1- i)))))))))
- (etypecase code-location
- (compiled-code-location
- (let* ((info (compiled-debug-fun-debug-info
- (code-location-debug-fun code-location)))
- (sources (sb!c::compiled-debug-info-source info))
- (len (length sources)))
- (declare (list sources))
- (when (zerop len)
- (debug-signal 'no-debug-blocks :debug-fun
- (code-location-debug-fun code-location)))
- (if (= len 1)
- (car sources)
- (do ((prev sources src)
- (src (cdr sources) (cdr src))
- (offset (code-location-toplevel-form-offset code-location)))
- ((null src) (car prev))
- (when (< offset (sb!c::debug-source-source-root (car src)))
- (return (car prev)))))))
- ;; (There used to be more cases back before sbcl-0.7.0, when we
- ;; did special tricks to debug the IR1 interpreter.)
- ))
+ (let ((info (compiled-debug-fun-debug-info
+ (code-location-debug-fun code-location))))
+ (or (sb!c::debug-info-source info)
+ (debug-signal 'no-debug-blocks :debug-fun
+ (code-location-debug-fun code-location)))))
- (etypecase code-location
- (compiled-code-location
- (unless (fill-in-code-location code-location)
- ;; This check should be unnecessary. We're missing
- ;; debug info the compiler should have dumped.
- (bug "unknown code location"))
- (code-location-%tlf-offset code-location))
- ;; (There used to be more cases back before sbcl-0.7.0,,
- ;; when we did special tricks to debug the IR1
- ;; interpreter.)
- ))
- (t tlf-offset))))
+ (etypecase code-location
+ (compiled-code-location
+ (unless (fill-in-code-location code-location)
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ (bug "unknown code location"))
+ (code-location-%tlf-offset code-location))
+ ;; (There used to be more cases back before sbcl-0.7.0,,
+ ;; when we did special tricks to debug the IR1
+ ;; interpreter.)
+ ))
+ (t tlf-offset))))
- (etypecase code-location
- (compiled-code-location
- (unless (fill-in-code-location code-location)
- ;; This check should be unnecessary. We're missing
- ;; debug info the compiler should have dumped.
- (bug "unknown code location"))
- (code-location-%form-number code-location))
- ;; (There used to be more cases back before sbcl-0.7.0,,
- ;; when we did special tricks to debug the IR1
- ;; interpreter.)
- ))
- (t form-num))))
+ (etypecase code-location
+ (compiled-code-location
+ (unless (fill-in-code-location code-location)
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ (bug "unknown code location"))
+ (code-location-%form-number code-location))
+ ;; (There used to be more cases back before sbcl-0.7.0,,
+ ;; when we did special tricks to debug the IR1
+ ;; interpreter.)
+ ))
+ (t form-num))))
;;; Return the kind of CODE-LOCATION, one of:
;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
;;; Return the kind of CODE-LOCATION, one of:
;;; :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
- ((not (fill-in-code-location code-location))
- ;; This check should be unnecessary. We're missing
- ;; debug info the compiler should have dumped.
- (bug "unknown code location"))
- (t
- (compiled-code-location-kind code-location)))))
+ ((not (fill-in-code-location code-location))
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ (bug "unknown code location"))
+ (t
+ (compiled-code-location-kind code-location)))))
- (cond ((eq live-set :unparsed)
- (unless (fill-in-code-location code-location)
- ;; This check should be unnecessary. We're missing
- ;; debug info the compiler should have dumped.
- ;;
- ;; FIXME: This error and comment happen over and over again.
- ;; Make them a shared function.
- (bug "unknown code location"))
- (compiled-code-location-%live-set code-location))
- (t live-set)))))
+ (cond ((eq live-set :unparsed)
+ (unless (fill-in-code-location code-location)
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ ;;
+ ;; FIXME: This error and comment happen over and over again.
+ ;; Make them a shared function.
+ (bug "unknown code location"))
+ (compiled-code-location-%live-set code-location))
+ (t live-set)))))
- (locations (compiled-debug-block-code-locations block)))
- (declare (simple-vector locations))
- (dotimes (j (length locations))
- (let ((loc (svref locations j)))
- (when (sub-compiled-code-location= code-location loc)
- (setf (code-location-%debug-block code-location) block)
- (setf (code-location-%tlf-offset code-location)
- (code-location-%tlf-offset loc))
- (setf (code-location-%form-number code-location)
- (code-location-%form-number loc))
- (setf (compiled-code-location-%live-set code-location)
- (compiled-code-location-%live-set loc))
- (setf (compiled-code-location-kind code-location)
- (compiled-code-location-kind loc))
- (return-from fill-in-code-location t))))))))
+ (locations (compiled-debug-block-code-locations block)))
+ (declare (simple-vector locations))
+ (dotimes (j (length locations))
+ (let ((loc (svref locations j)))
+ (when (sub-compiled-code-location= code-location loc)
+ (setf (code-location-%debug-block code-location) block)
+ (setf (code-location-%tlf-offset code-location)
+ (code-location-%tlf-offset loc))
+ (setf (code-location-%form-number code-location)
+ (code-location-%form-number loc))
+ (setf (compiled-code-location-%live-set code-location)
+ (compiled-code-location-%live-set loc))
+ (setf (compiled-code-location-kind code-location)
+ (compiled-code-location-kind loc))
+ (return-from fill-in-code-location t))))))))
\f
;;;; operations on DEBUG-BLOCKs
;;; Execute FORMS in a context with CODE-VAR bound to each
;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
(defmacro do-debug-block-locations ((code-var debug-block &optional result)
\f
;;;; operations on DEBUG-BLOCKs
;;; Execute FORMS in a context with CODE-VAR bound to each
;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
(defmacro do-debug-block-locations ((code-var debug-block &optional result)
`(let ((,code-locations (debug-block-code-locations ,debug-block)))
(declare (simple-vector ,code-locations))
(dotimes (,i (length ,code-locations) ,result)
`(let ((,code-locations (debug-block-code-locations ,debug-block)))
(declare (simple-vector ,code-locations))
(dotimes (,i (length ,code-locations) ,result)
- ;; Check that the pointer is valid. XXX Could do a better
- ;; job. FIXME: e.g. by calling out to an is_valid_pointer
- ;; routine in the C runtime support code
- (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))
- (< sb!vm:dynamic-space-start val
- (sap-int (dynamic-space-free-pointer))))))
+ ;; Check that the pointer is valid. XXX Could do a better
+ ;; job. FIXME: e.g. by calling out to an is_valid_pointer
+ ;; routine in the C runtime support code
+ (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))))))
- `(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)))
+ `(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)))
- (sub-set-debug-var-slot (frame-pointer frame)
- (compiled-debug-var-sc-offset debug-var)
- value escaped)
- (sub-set-debug-var-slot
- (frame-pointer frame)
- (or (compiled-debug-var-save-sc-offset debug-var)
- (compiled-debug-var-sc-offset debug-var))
- value))))
+ (sub-set-debug-var-slot (frame-pointer frame)
+ (compiled-debug-var-sc-offset debug-var)
+ value escaped)
+ (sub-set-debug-var-slot
+ (frame-pointer frame)
+ (or (compiled-debug-var-save-sc-offset debug-var)
+ (compiled-debug-var-sc-offset debug-var))
+ value))))
- `(if escaped
- (setf (sb!vm:context-register
- escaped
- (sb!c:sc-offset-offset sc-offset))
- ,val)
- value))
- (set-escaped-float-value (format val)
- `(if escaped
- (setf (sb!vm:context-float-register
- escaped
- (sb!c:sc-offset-offset sc-offset)
- ',format)
- ,val)
- value))
- (with-nfp ((var) &body body)
- `(let ((,var (if escaped
- (int-sap
- (sb!vm:context-register escaped
- sb!vm::nfp-offset))
- #!-alpha
- (sap-ref-sap fp
- (* nfp-save-offset
- sb!vm:n-word-bytes))
- #!+alpha
- (sb!vm::make-number-stack-pointer
- (sap-ref-32 fp
- (* nfp-save-offset
- sb!vm:n-word-bytes))))))
- ,@body)))
+ `(if escaped
+ (setf (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))
+ ,val)
+ value))
+ (set-escaped-float-value (format val)
+ `(if escaped
+ (setf (sb!vm:context-float-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset)
+ ',format)
+ ,val)
+ value))
+ (with-nfp ((var) &body body)
+ `(let ((,var (if escaped
+ (int-sap
+ (sb!vm:context-register escaped
+ sb!vm::nfp-offset))
+ #!-alpha
+ (sap-ref-sap fp
+ (* nfp-save-offset
+ sb!vm:n-word-bytes))
+ #!+alpha
+ (sb!vm::make-number-stack-pointer
+ (sap-ref-32 fp
+ (* nfp-save-offset
+ sb!vm:n-word-bytes))))))
+ ,@body)))
- (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)))
+ (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)))
- (setf (sap-ref-single
- nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
- (the single-float (realpart value)))
- (setf (sap-ref-single
- nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
- sb!vm:n-word-bytes))
- (the single-float (realpart value)))))
+ (setf (sap-ref-single
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
+ (the single-float (realpart value)))
+ (setf (sap-ref-single
+ nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:n-word-bytes))
+ (the single-float (realpart value)))))
- (setf (sap-ref-double
- nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
- (the double-float (realpart value)))
- (setf (sap-ref-double
- nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
- sb!vm:n-word-bytes))
- (the double-float (realpart value)))))
+ (setf (sap-ref-double
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
+ (the double-float (realpart value)))
+ (setf (sap-ref-double
+ nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:n-word-bytes))
+ (the double-float (realpart value)))))
- (setf (sap-ref-long
- nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
- (the long-float (realpart value)))
- (setf (sap-ref-long
- nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
- sb!vm:n-word-bytes))
- (the long-float (realpart value)))))
+ (setf (sap-ref-long
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
+ (the long-float (realpart value)))
+ (setf (sap-ref-long
+ nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
+ sb!vm:n-word-bytes))
+ (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
(setf (sap-ref-word fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
(#.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))
- (let ((debug-fun (code-location-debug-fun basic-code-location)))
- (if (>= (compiled-code-location-pc basic-code-location)
- (sb!c::compiled-debug-fun-start-pc
- (compiled-debug-fun-compiler-debug-fun debug-fun)))
- :valid
- :invalid)))
- ((code-location-unknown-p basic-code-location) :unknown)
- (t
- (let ((pos (position debug-var
- (debug-fun-debug-vars
- (code-location-debug-fun
- basic-code-location)))))
- (unless pos
- (error 'unknown-debug-var
- :debug-var debug-var
- :debug-fun
- (code-location-debug-fun basic-code-location)))
- ;; There must be live-set info since basic-code-location is known.
- (if (zerop (sbit (compiled-code-location-live-set
- basic-code-location)
- pos))
- :invalid
- :valid)))))
+ (let ((debug-fun (code-location-debug-fun basic-code-location)))
+ (if (>= (compiled-code-location-pc basic-code-location)
+ (sb!c::compiled-debug-fun-start-pc
+ (compiled-debug-fun-compiler-debug-fun debug-fun)))
+ :valid
+ :invalid)))
+ ((code-location-unknown-p basic-code-location) :unknown)
+ (t
+ (let ((pos (position debug-var
+ (debug-fun-debug-vars
+ (code-location-debug-fun
+ basic-code-location)))))
+ (unless pos
+ (error 'unknown-debug-var
+ :debug-var debug-var
+ :debug-fun
+ (code-location-debug-fun basic-code-location)))
+ ;; There must be live-set info since basic-code-location is known.
+ (if (zerop (sbit (compiled-code-location-live-set
+ basic-code-location)
+ pos))
+ :invalid
+ :valid)))))
- '(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)))))))
+ '(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)))))))
- (if (or (zerop level) (null path))
- (if (zerop context)
- form
- `(#:***here*** ,form))
- (let ((n (first path)))
- (unless (and (listp form) (< n (length form)))
- (error "Source path no longer exists."))
- (let ((res (frob (elt form n) (rest path) (1- level))))
- (nconc (subseq form 0 n)
- (cons res (nthcdr (1+ n) form))))))))
+ (if (or (zerop level) (null path))
+ (if (zerop context)
+ form
+ `(#:***here*** ,form))
+ (let ((n (first path)))
+ (unless (and (listp form) (< n (length form)))
+ (error "Source path no longer exists."))
+ (let ((res (frob (elt form n) (rest path) (1- level))))
+ (nconc (subseq form 0 n)
+ (cons res (nthcdr (1+ n) form))))))))
- (let ((validity (debug-var-validity var loc)))
- (unless (eq validity :invalid)
- (let* ((sym (debug-var-symbol var))
- (found (assoc sym (binds))))
- (if found
- (setf (second found) :ambiguous)
- (binds (list sym validity var)))))))
+ (let ((validity (debug-var-validity var loc)))
+ (unless (eq validity :invalid)
+ (let* ((sym (debug-var-symbol var))
+ (found (assoc sym (binds))))
+ (if found
+ (setf (second found) :ambiguous)
+ (binds (list sym validity var)))))))
- (let ((name (first bind))
- (var (third bind)))
- (ecase (second bind)
- (:valid
- (specs `(,name (debug-var-value ',var ,n-frame))))
- (:unknown
- (specs `(,name (debug-signal 'invalid-value
- :debug-var ',var
- :frame ,n-frame))))
- (:ambiguous
- (specs `(,name (debug-signal 'ambiguous-var-name
- :name ',name
- :frame ,n-frame)))))))
+ (let ((name (first bind))
+ (var (third bind)))
+ (ecase (second bind)
+ (:valid
+ (specs `(,name (debug-var-value ',var ,n-frame))))
+ (:unknown
+ (specs `(,name (debug-signal 'invalid-value
+ :debug-var ',var
+ :frame ,n-frame))))
+ (:ambiguous
+ (specs `(,name (debug-signal 'ambiguous-var-name
+ :name ',name
+ :frame ,n-frame)))))))
- (declare (ignorable ,n-frame))
- (symbol-macrolet ,(specs) ,form))
- 'function)))
- (lambda (frame)
- ;; This prevents these functions from being used in any
- ;; location other than a function return location, so maybe
- ;; this should only check whether FRAME's DEBUG-FUN is the
- ;; same as LOC's.
- (unless (code-location= (frame-code-location frame) loc)
- (debug-signal 'frame-fun-mismatch
- :code-location loc :form form :frame frame))
- (funcall res frame))))))
+ (declare (ignorable ,n-frame))
+ (symbol-macrolet ,(specs) ,form))
+ 'function)))
+ (lambda (frame)
+ ;; This prevents these functions from being used in any
+ ;; location other than a function return location, so maybe
+ ;; this should only check whether FRAME's DEBUG-FUN is the
+ ;; same as LOC's.
+ (unless (code-location= (frame-code-location frame) loc)
+ (debug-signal 'frame-fun-mismatch
+ :code-location loc :form form :frame frame))
+ (funcall res frame))))))
- (compiled-code-location
- ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
- (when (eq (compiled-code-location-kind what) :unknown-return)
- (let ((other-bpt (%make-breakpoint hook-fun what
- :unknown-return-partner
- info)))
- (setf (breakpoint-unknown-return-partner bpt) other-bpt)
- (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
- ;; (There used to be more cases back before sbcl-0.7.0,,
- ;; when we did special tricks to debug the IR1
- ;; interpreter.)
- )
+ (compiled-code-location
+ ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
+ (when (eq (compiled-code-location-kind what) :unknown-return)
+ (let ((other-bpt (%make-breakpoint hook-fun what
+ :unknown-return-partner
+ info)))
+ (setf (breakpoint-unknown-return-partner bpt) other-bpt)
+ (setf (breakpoint-unknown-return-partner other-bpt) bpt))))
+ ;; (There used to be more cases back before sbcl-0.7.0,,
+ ;; when we did special tricks to debug the IR1
+ ;; interpreter.)
+ )
- (let* ((bpt (%make-breakpoint hook-fun what kind info))
- (starter (compiled-debug-fun-end-starter what)))
- (unless starter
- (setf starter (%make-breakpoint #'list what :fun-start nil))
- (setf (breakpoint-hook-fun starter)
- (fun-end-starter-hook starter what))
- (setf (compiled-debug-fun-end-starter what) starter))
- (setf (breakpoint-start-helper bpt) starter)
- (push bpt (breakpoint-%info starter))
- (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
- bpt))))))
+ (let* ((bpt (%make-breakpoint hook-fun what kind info))
+ (starter (compiled-debug-fun-end-starter what)))
+ (unless starter
+ (setf starter (%make-breakpoint #'list what :fun-start nil))
+ (setf (breakpoint-hook-fun starter)
+ (fun-end-starter-hook starter what))
+ (setf (compiled-debug-fun-end-starter what) starter))
+ (setf (breakpoint-start-helper bpt) starter)
+ (push bpt (breakpoint-%info starter))
+ (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
+ bpt))))))
- (make-bogus-lra
- (get-context-value frame
- lra-save-offset
- lra-sc-offset))
- (setf (get-context-value frame
- lra-save-offset
- lra-sc-offset)
- lra)
- (let ((end-bpts (breakpoint-%info starter-bpt)))
- (let ((data (breakpoint-data component offset)))
- (setf (breakpoint-data-breakpoints data) end-bpts)
- (dolist (bpt end-bpts)
- (setf (breakpoint-internal-data bpt) data)))
- (let ((cookie (make-fun-end-cookie lra debug-fun)))
- (setf (gethash component *fun-end-cookies*) cookie)
- (dolist (bpt end-bpts)
- (let ((fun (breakpoint-cookie-fun bpt)))
- (when fun (funcall fun frame cookie))))))))))
+ (make-bogus-lra
+ (get-context-value frame
+ lra-save-offset
+ lra-sc-offset))
+ (setf (get-context-value frame
+ lra-save-offset
+ lra-sc-offset)
+ lra)
+ (let ((end-bpts (breakpoint-%info starter-bpt)))
+ (let ((data (breakpoint-data component offset)))
+ (setf (breakpoint-data-breakpoints data) end-bpts)
+ (dolist (bpt end-bpts)
+ (setf (breakpoint-internal-data bpt) data)))
+ (let ((cookie (make-fun-end-cookie lra debug-fun)))
+ (setf (gethash component *fun-end-cookies*) cookie)
+ (dolist (bpt end-bpts)
+ (let ((fun (breakpoint-cookie-fun bpt)))
+ (when fun (funcall fun frame cookie))))))))))
- (etypecase loc
- (compiled-code-location
- (activate-compiled-code-location-breakpoint breakpoint)
- (let ((other (breakpoint-unknown-return-partner breakpoint)))
- (when other
- (activate-compiled-code-location-breakpoint other))))
- ;; (There used to be more cases back before sbcl-0.7.0, when
- ;; we did special tricks to debug the IR1 interpreter.)
- )))
+ (etypecase loc
+ (compiled-code-location
+ (activate-compiled-code-location-breakpoint breakpoint)
+ (let ((other (breakpoint-unknown-return-partner breakpoint)))
+ (when other
+ (activate-compiled-code-location-breakpoint other))))
+ ;; (There used to be more cases back before sbcl-0.7.0, when
+ ;; we did special tricks to debug the IR1 interpreter.)
+ )))
- (compiled-debug-fun
- (let ((starter (breakpoint-start-helper breakpoint)))
- (unless (eq (breakpoint-status starter) :active)
- ;; may already be active by some other :FUN-END breakpoint
- (activate-compiled-fun-start-breakpoint starter)))
- (setf (breakpoint-status breakpoint) :active))
- ;; (There used to be more cases back before sbcl-0.7.0, when
- ;; we did special tricks to debug the IR1 interpreter.)
- ))))
+ (compiled-debug-fun
+ (let ((starter (breakpoint-start-helper breakpoint)))
+ (unless (eq (breakpoint-status starter) :active)
+ ;; may already be active by some other :FUN-END breakpoint
+ (activate-compiled-fun-start-breakpoint starter)))
+ (setf (breakpoint-status breakpoint) :active))
+ ;; (There used to be more cases back before sbcl-0.7.0, when
+ ;; we did special tricks to debug the IR1 interpreter.)
+ ))))
- (code-location-debug-fun loc))
- (+ (compiled-code-location-pc loc)
- (if (or (eq (breakpoint-kind breakpoint)
- :unknown-return-partner)
- (eq (compiled-code-location-kind loc)
- :single-value-return))
- sb!vm:single-value-return-byte-offset
- 0))))))
+ (code-location-debug-fun loc))
+ (+ (compiled-code-location-pc loc)
+ (if (or (eq (breakpoint-kind breakpoint)
+ :unknown-return-partner)
+ (eq (compiled-code-location-kind loc)
+ :single-value-return))
+ sb!vm:single-value-return-byte-offset
+ 0))))))
- ((or compiled-code-location compiled-debug-fun)
- (deactivate-compiled-breakpoint breakpoint)
- (let ((other (breakpoint-unknown-return-partner breakpoint)))
- (when other
- (deactivate-compiled-breakpoint other))))
- ;; (There used to be more cases back before sbcl-0.7.0, when
- ;; we did special tricks to debug the IR1 interpreter.)
- ))))
+ ((or compiled-code-location compiled-debug-fun)
+ (deactivate-compiled-breakpoint breakpoint)
+ (let ((other (breakpoint-unknown-return-partner breakpoint)))
+ (when other
+ (deactivate-compiled-breakpoint other))))
+ ;; (There used to be more cases back before sbcl-0.7.0, when
+ ;; we did special tricks to debug the IR1 interpreter.)
+ ))))
- (unless (find-if (lambda (bpt)
- (and (not (eq bpt breakpoint))
- (eq (breakpoint-status bpt) :active)))
- (breakpoint-%info starter))
- (deactivate-compiled-breakpoint starter)))
+ (unless (find-if (lambda (bpt)
+ (and (not (eq bpt breakpoint))
+ (eq (breakpoint-status bpt) :active)))
+ (breakpoint-%info starter))
+ (deactivate-compiled-breakpoint starter)))
- (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
- (setf (breakpoint-internal-data breakpoint) nil)
- (setf (breakpoint-data-breakpoints data) bpts)
- (unless bpts
- (without-gcing
- (breakpoint-remove (get-lisp-obj-address
- (breakpoint-data-component data))
- (breakpoint-data-offset data)
- (breakpoint-data-instruction data)))
- (delete-breakpoint-data data))))
+ (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
+ (setf (breakpoint-internal-data breakpoint) nil)
+ (setf (breakpoint-data-breakpoints data) bpts)
+ (unless bpts
+ (without-gcing
+ (breakpoint-remove (get-lisp-obj-address
+ (breakpoint-data-component data))
+ (breakpoint-data-offset data)
+ (breakpoint-data-instruction data)))
+ (delete-breakpoint-data data))))
- (let* ((starter (breakpoint-start-helper breakpoint))
- (breakpoints (delete breakpoint
- (the list (breakpoint-info starter)))))
- (setf (breakpoint-info starter) breakpoints)
- (unless breakpoints
- (delete-breakpoint starter)
- (setf (compiled-debug-fun-end-starter
- (breakpoint-what breakpoint))
- nil))))))
+ (let* ((starter (breakpoint-start-helper breakpoint))
+ (breakpoints (delete breakpoint
+ (the list (breakpoint-info starter)))))
+ (setf (breakpoint-info starter) breakpoints)
+ (unless breakpoints
+ (delete-breakpoint starter)
+ (setf (compiled-debug-fun-end-starter
+ (breakpoint-what breakpoint))
+ nil))))))
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
(flet ((install-breakpoint-data ()
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
(flet ((install-breakpoint-data ()
- (eq (breakpoint-kind (car breakpoints)) :fun-end))
- (handle-fun-end-breakpoint-aux breakpoints data signal-context)
- (handle-breakpoint-aux breakpoints data
- offset component signal-context)))))
+ (eq (breakpoint-kind (car breakpoints)) :fun-end))
+ (handle-fun-end-breakpoint-aux breakpoints data signal-context)
+ (handle-breakpoint-aux breakpoints data
+ offset component signal-context)))))
- (let ((data (breakpoint-data component offset nil)))
- (when (and data (breakpoint-data-breakpoints data))
- ;; The breakpoint is still active, so we need to execute the
- ;; displaced instruction and leave the breakpoint instruction
- ;; behind. The best way to do this is different on each machine,
- ;; so we just leave it up to the C code.
- (breakpoint-do-displaced-inst signal-context
- (breakpoint-data-instruction data))
- ;; Some platforms have no usable sigreturn() call. If your
- ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
- ;; it's polite to warn here
- #!+(and sparc solaris)
- (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
-
-(defun invoke-breakpoint-hooks (breakpoints component offset)
- (let* ((debug-fun (debug-fun-from-pc component offset))
- (frame (do ((f (top-frame) (frame-down f)))
- ((eq debug-fun (frame-debug-fun f)) f))))
+ (setf data (breakpoint-data component offset nil))
+ (when (and data (breakpoint-data-breakpoints data))
+ ;; The breakpoint is still active, so we need to execute the
+ ;; displaced instruction and leave the breakpoint instruction
+ ;; behind. The best way to do this is different on each machine,
+ ;; so we just leave it up to the C code.
+ (breakpoint-do-displaced-inst signal-context
+ (breakpoint-data-instruction data))
+ ;; Some platforms have no usable sigreturn() call. If your
+ ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
+ ;; it's polite to warn here
+ #!+(and sparc solaris)
+ (error "BREAKPOINT-DO-DISPLACED-INST returned?")))
+
+(defun invoke-breakpoint-hooks (breakpoints signal-context)
+ (let* ((frame (signal-context-frame signal-context)))
- frame
- ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
- ;; hook function the original breakpoint, so that users
- ;; aren't forced to confront the fact that some
- ;; breakpoints really are two.
- (if (eq (breakpoint-kind bpt) :unknown-return-partner)
- (breakpoint-unknown-return-partner bpt)
- bpt)))))
+ frame
+ ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
+ ;; hook function the original breakpoint, so that users
+ ;; aren't forced to confront the fact that some
+ ;; breakpoints really are two.
+ (if (eq (breakpoint-kind bpt) :unknown-return-partner)
+ (breakpoint-unknown-return-partner bpt)
+ bpt)))))
+
+(defun signal-context-frame (signal-context)
+ (let* ((scp
+ (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (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)
+ nil)))
- (locally
- (declare (optimize (inhibit-warnings 3)))
- (sb!alien:sap-alien signal-context (* os-context-t))))
- (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
- (f (top-frame) (frame-down f)))
- ((= cfp (sap-int (frame-pointer f))) f)
- (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp))))
- (component (breakpoint-data-component data))
- (cookie (gethash component *fun-end-cookies*)))
+ (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien signal-context (* os-context-t))))
+ (frame (signal-context-frame signal-context))
+ (component (breakpoint-data-component data))
+ (cookie (gethash component *fun-end-cookies*)))
- (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
- (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
- (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
- (length (sap- src-end src-start))
- (code-object
- (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants)
- length))
- (dst-start (code-instructions code-object)))
+ (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"))
+ (length (sap- src-end src-start))
+ (code-object
+ (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants)
+ length))
+ (dst-start (code-instructions code-object)))
(system-area-ub8-copy src-start 0 dst-start 0 length)
(sb!vm:sanctify-for-execution code-object)
#!+(or x86 x86-64)
(values dst-start code-object (sap- trap-loc src-start))
#!-(or x86 x86-64)
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
(system-area-ub8-copy src-start 0 dst-start 0 length)
(sb!vm:sanctify-for-execution code-object)
#!+(or x86 x86-64)
(values dst-start code-object (sap- trap-loc src-start))
#!-(or x86 x86-64)
(let ((new-lra (make-lisp-obj (+ (sap-int dst-start)