Rename RETURN-PC-HEADER-WIDETAG to RETURN-PC-WIDETAG

[sbcl.git] / src / code / debug-int.lisp

;;;; the implementation of the programmer's interface to writing
;;;; debugging tools

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!DI")

;;; FIXME: There are an awful lot of package prefixes in this code.
;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
\f
;;;; conditions

;;;; The interface to building debugging tools signals conditions that
;;;; prevent it from adhering to its contract. These are
;;;; serious-conditions because the program using the interface must
;;;; handle them before it can correctly continue execution. These
;;;; debugging conditions are not errors since it is no fault of the
;;;; programmers that the conditions occur. The interface does not
;;;; provide for programs to detect these situations other than
;;;; calling a routine that detects them and signals a condition. For
;;;; example, programmers call A which may fail to return successfully
;;;; due to a lack of debug information, and there is no B the they
;;;; could have called to realize A would fail. It is not an error to
;;;; have called A, but it is an error for the program to then ignore
;;;; the signal generated by A since it cannot continue without A's
;;;; correctly returning a value or performing some operation.
;;;;
;;;; Use DEBUG-SIGNAL to signal these conditions.

(define-condition debug-condition (serious-condition)
  ()
  (:documentation
   "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
    that must be handled, but they are not programmer errors."))

(define-condition no-debug-fun-returns (debug-condition)
  ((debug-fun :reader no-debug-fun-returns-debug-fun
              :initarg :debug-fun))
  (:documentation
   "The system could not return values from a frame with DEBUG-FUN since
    it lacked information about returning values.")
  (:report (lambda (condition stream)
             (let ((fun (debug-fun-fun
                         (no-debug-fun-returns-debug-fun condition))))
               (format stream
                       "~&Cannot return values from ~:[frame~;~:*~S~] since ~
                        the debug information lacks details about returning ~
                        values here."
                       fun)))))

(define-condition no-debug-blocks (debug-condition)
  ((debug-fun :reader no-debug-blocks-debug-fun
              :initarg :debug-fun))
  (:documentation "The debug-fun has no debug-block information.")
  (:report (lambda (condition stream)
             (format stream "~&~S has no debug-block information."
                     (no-debug-blocks-debug-fun condition)))))

(define-condition no-debug-vars (debug-condition)
  ((debug-fun :reader no-debug-vars-debug-fun
              :initarg :debug-fun))
  (:documentation "The DEBUG-FUN has no DEBUG-VAR information.")
  (:report (lambda (condition stream)
             (format stream "~&~S has no debug variable information."
                     (no-debug-vars-debug-fun condition)))))

(define-condition lambda-list-unavailable (debug-condition)
  ((debug-fun :reader lambda-list-unavailable-debug-fun
              :initarg :debug-fun))
  (:documentation
   "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are
    unavailable.")
  (:report (lambda (condition stream)
             (format stream "~&~S has no lambda-list information available."
                     (lambda-list-unavailable-debug-fun condition)))))

(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)
             (format stream "~&~S has :invalid or :unknown value in ~S."
                     (invalid-value-debug-var condition)
                     (invalid-value-frame condition)))))

(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 "~&~S names more than one valid variable in ~S."
                     (ambiguous-var-name-name condition)
                     (ambiguous-var-name-frame condition)))))
\f
;;;; errors and DEBUG-SIGNAL

;;; The debug-internals code tries to signal all programmer errors as
;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
;;; come up.
;;;
;;; While under development, this code also signals errors in code
;;; branches that remain unimplemented.

(define-condition debug-error (error) ()
  (:documentation
   "All programmer errors from using the interface for building debugging
    tools inherit from this type."))

(define-condition unhandled-debug-condition (debug-error)
  ((condition :reader unhandled-debug-condition-condition :initarg :condition))
  (:report (lambda (condition stream)
             (format stream "~&unhandled DEBUG-CONDITION:~%~A"
                     (unhandled-debug-condition-condition condition)))))

(define-condition unknown-code-location (debug-error)
  ((code-location :reader unknown-code-location-code-location
                  :initarg :code-location))
  (:report (lambda (condition stream)
             (format stream "~&invalid use of an unknown code-location: ~S"
                     (unknown-code-location-code-location condition)))))

(define-condition unknown-debug-var (debug-error)
  ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
   (debug-fun :reader unknown-debug-var-debug-fun
              :initarg :debug-fun))
  (:report (lambda (condition stream)
             (format stream "~&~S is not in ~S."
                     (unknown-debug-var-debug-var condition)
                     (unknown-debug-var-debug-fun condition)))))

(define-condition invalid-control-stack-pointer (debug-error)
  ()
  (:report (lambda (condition stream)
             (declare (ignore condition))
             (fresh-line stream)
             (write-string "invalid control stack pointer" stream))))

(define-condition frame-fun-mismatch (debug-error)
  ((code-location :reader frame-fun-mismatch-code-location
                  :initarg :code-location)
   (frame :reader frame-fun-mismatch-frame :initarg :frame)
   (form :reader frame-fun-mismatch-form :initarg :form))
  (: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)))))

;;; This signals debug-conditions. If they go unhandled, then signal
;;; an UNHANDLED-DEBUG-CONDITION error.
;;;
;;; ??? Get SIGNAL in the right package!
(defmacro debug-signal (datum &rest arguments)
  `(let ((condition (make-condition ,datum ,@arguments)))
     (signal condition)
     (error 'unhandled-debug-condition :condition condition)))
\f
;;;; structures
;;;;
;;;; Most of these structures model information stored in internal
;;;; data structures created by the compiler. Whenever comments
;;;; preface an object or type with "compiler", they refer to the
;;;; internal compiler thing, not to the object or type with the same
;;;; name in the "SB-DI" package.

;;;; DEBUG-VARs

;;; These exist for caching data stored in packed binary form in
;;; compiler DEBUG-FUNs.
(defstruct (debug-var (:constructor nil)
                      (:copier nil))
  ;; the name of the variable
  (symbol (missing-arg) :type symbol)
  ;; a unique integer identification relative to other variables with the same
  ;; symbol
  (id 0 :type index :read-only t)
  ;; Does the variable always have a valid value?
  (alive-p nil :type boolean :read-only t))
(defmethod print-object ((debug-var debug-var) stream)
  (print-unreadable-object (debug-var stream :type t :identity t)
    (format stream
            "~S ~W"
            (debug-var-symbol debug-var)
            (debug-var-id debug-var))))

(setf (fdocumentation 'debug-var-id 'function)
  "Return the integer that makes DEBUG-VAR's name and package unique
   with respect to other DEBUG-VARs in the same function.")

(defstruct (compiled-debug-var
            (:include debug-var)
            (:constructor make-compiled-debug-var
                (symbol id alive-p
                 sc-offset save-sc-offset indirect-sc-offset info))
            (:copier nil))
  ;; storage class and offset (unexported)
  (sc-offset nil :type sb!c:sc-offset :read-only t)
  ;; storage class and offset when saved somewhere
  (save-sc-offset nil :type (or sb!c:sc-offset null) :read-only t)
  ;; For indirect closures the fp of the parent frame is stored in the
  ;; normal sc-offsets above, and this has the offset into the frame
  (indirect-sc-offset nil :type (or sb!c:sc-offset null) :read-only t)
  (info nil :read-only t))

;;;; DEBUG-FUNs

;;; These exist for caching data stored in packed binary form in
;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN
;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
;;; for any function; that is, all CODE-LOCATIONs and other objects
;;; that reference DEBUG-FUNs point to unique objects. This is
;;; due to the overhead in cached information.

(defstruct (debug-fun (:constructor nil)
                      (:copier nil))
  ;; some representation of the function arguments. See
  ;; DEBUG-FUN-LAMBDA-LIST.
  ;; NOTE: must parse vars before parsing arg list stuff.
  (%lambda-list :unparsed)
  ;; cached DEBUG-VARS information (unexported).
  ;; These are sorted by their name.
  (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
  ;; cached debug-block information. This is NIL when we have tried to
  ;; parse the packed binary info, but none is available.
  (blocks :unparsed :type (or simple-vector null (member :unparsed)))
  ;; the actual function if available
  (%function :unparsed :type (or null function (member :unparsed))))
(defmethod print-object ((obj debug-fun) stream)
  (print-unreadable-object (obj stream :type t)
    (prin1 (debug-fun-name obj) stream)))

(defstruct (bogus-debug-fun
            (:include debug-fun)
            (:constructor make-bogus-debug-fun
                          (%name &aux
                                 (%lambda-list nil)
                                 (%debug-vars nil)
                                 (blocks nil)
                                 (%function nil)))
            (:copier nil))
  (%name nil :read-only t))

;;;; DEBUG-BLOCKs

;;; These exist for caching data stored in packed binary form in compiler
;;; DEBUG-BLOCKs.
(defstruct (debug-block (:constructor nil)
                        (:copier nil))
  ;; This indicates whether the block is a special glob of code shared
  ;; by various functions and tucked away elsewhere in a component.
  ;; This kind of block has no start code-location. This slot is in
  ;; all debug-blocks since it is an exported interface.
  (elsewhere-p nil :type boolean))
(defmethod print-object ((obj debug-block) str)
  (print-unreadable-object (obj str :type t)
    (prin1 (debug-block-fun-name obj) str)))

(setf (fdocumentation 'debug-block-elsewhere-p 'function)
  "Return whether debug-block represents elsewhere code.")

(defstruct (compiled-debug-block (:include debug-block)
                                 (:copier nil))
  ;; code-location information for the block
  (code-locations #() :type simple-vector))

(defstruct (code-location (:constructor nil)
                          (:copier nil))
  ;; the DEBUG-FUN containing this CODE-LOCATION
  (debug-fun nil :type debug-fun :read-only t)
  ;; This is initially :UNSURE. Upon first trying to access an
  ;; :UNPARSED slot, if the data is unavailable, then this becomes T,
  ;; and the code-location is unknown. If the data is available, this
  ;; becomes NIL, a known location. We can't use a separate type
  ;; code-location for this since we must return code-locations before
  ;; we can tell whether they're known or unknown. For example, when
  ;; parsing the stack, we don't want to unpack all the variables and
  ;; blocks just to make frames.
  (%unknown-p :unsure :type (member t nil :unsure))
  ;; the DEBUG-BLOCK containing CODE-LOCATION. XXX Possibly toss this
  ;; out and just find it in the blocks cache in DEBUG-FUN.
  (%debug-block :unparsed :type (or debug-block (member :unparsed)))
  ;; This is the depth-first number of the node that begins
  ;; code-location within its top level form.
  (%form-number :unparsed :type (or index (member :unparsed))))

;;;; frames

;;; These represent call frames on the stack.
(defstruct (frame (:constructor nil)
                  (:copier nil))
  ;; the next frame up, or NIL when top frame
  (up nil :type (or frame null))
  ;; the previous frame down, or NIL when the bottom frame. Before
  ;; computing the next frame down, this slot holds the frame pointer
  ;; to the control stack for the given frame. This lets us get the
  ;; next frame down and the return-pc for that frame.
  (%down :unparsed :type (or frame (member nil :unparsed)))
  ;; the DEBUG-FUN for the function whose call this frame represents
  (debug-fun nil :type debug-fun :read-only t)
  ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
  ;; running when program execution returns to this frame. If someone
  ;; interrupted this frame, the result could be an unknown
  ;; CODE-LOCATION.
  (code-location nil :type code-location :read-only t)
  ;; an a-list of catch-tags to code-locations
  (%catches :unparsed :type (or list (member :unparsed)))
  ;; pointer to frame on control stack (unexported)
  (pointer nil :read-only t)
  ;; This is the frame's number for prompt printing. Top is zero.
  (number 0 :type index))

(defstruct (compiled-frame
            (:include frame)
            (:constructor make-compiled-frame
                          (pointer up debug-fun code-location number
                                   &optional escaped))
            (:copier nil))
  ;; 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
  ;; argument to an SA_SIGACTION-style signal handler.
  (escaped nil :read-only t))
(defmethod print-object ((obj compiled-frame) str)
  (print-unreadable-object (obj str :type t)
    (format str
            "~S~:[~;, interrupted~]"
            (debug-fun-name (frame-debug-fun obj))
            (compiled-frame-escaped obj))))
\f

;;; 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 :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*.
;;;
;;; 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)
  (let ((table *compiled-debug-funs*))
    (with-locked-system-table (table)
      (or (gethash compiler-debug-fun table)
          (setf (gethash compiler-debug-fun table)
                (%make-compiled-debug-fun compiler-debug-fun component))))))
\f
;;;; breakpoints

;;; This is an internal structure that manages information about a
;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
(defstruct (breakpoint-data (:constructor make-breakpoint-data
                                          (component offset))
                            (:copier nil))
  ;; This is the component in which the breakpoint lies.
  (component nil :read-only t)
  ;; This is the byte offset into the component.
  (offset nil :type index :read-only t)
  ;; The original instruction replaced by the breakpoint.
  (instruction nil :type (or null sb!vm::word))
  ;; A list of user breakpoints at this location.
  (breakpoints nil :type list))
(defmethod print-object ((obj breakpoint-data) str)
  (print-unreadable-object (obj str :type t)
    (format str "~S at ~S"
            (debug-fun-name
             (debug-fun-from-pc (breakpoint-data-component obj)
                                (breakpoint-data-offset obj)))
            (breakpoint-data-offset obj))))

(defstruct (breakpoint (:constructor %make-breakpoint
                                     (hook-fun what kind %info))
                       (:copier nil))
  ;; 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
  ;; values to return for the function containing the breakpoint.
  ;; :FUN-END breakpoint hook functions also take a cookie argument.
  ;; See the COOKIE-FUN slot.
  (hook-fun (required-arg) :type function)
  ;; CODE-LOCATION or DEBUG-FUN
  (what nil :type (or code-location debug-fun) :read-only t)
  ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind
  ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
  ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
  (kind nil :type (member :code-location :fun-start :fun-end
                          :unknown-return-partner)
            :read-only t)
  ;; Status helps the user and the implementation.
  (status :inactive :type (member :active :inactive :deleted))
  ;; This is a backpointer to a breakpoint-data.
  (internal-data nil :type (or null breakpoint-data))
  ;; With code-locations whose type is :UNKNOWN-RETURN, there are
  ;; really two breakpoints: one at the multiple-value entry point,
  ;; and one at the single-value entry point. This slot holds the
  ;; breakpoint for the other one, or NIL if this isn't at an
  ;; :UNKNOWN-RETURN code location.
  (unknown-return-partner nil :type (or null breakpoint))
  ;; :FUN-END breakpoints use a breakpoint at the :FUN-START
  ;; to establish the end breakpoint upon function entry. We do this
  ;; by frobbing the LRA to jump to a special piece of code that
  ;; breaks and provides the return values for the returnee. This slot
  ;; points to the start breakpoint, so we can activate, deactivate,
  ;; and delete it.
  (start-helper nil :type (or null breakpoint))
  ;; This is a hook users supply to get a dynamically unique cookie
  ;; for identifying :FUN-END breakpoint executions. That is, if
  ;; there is one :FUN-END breakpoint, but there may be multiple
  ;; pending calls of its function on the stack. This function takes
  ;; the cookie, and the hook function takes the cookie too.
  (cookie-fun nil :type (or null function))
  ;; This slot users can set with whatever information they find useful.
  (%info nil))
(defmethod print-object ((obj breakpoint) str)
  (let ((what (breakpoint-what obj)))
    (print-unreadable-object (obj str :type t)
      (format str
              "~S~:[~;~:*~S~]"
              (etypecase what
                (code-location what)
                (debug-fun (debug-fun-name what)))
              (etypecase what
                (code-location nil)
                (debug-fun (breakpoint-kind obj)))))))

(defstruct (compiled-debug-fun
            (:include debug-fun)
            (:constructor %make-compiled-debug-fun
                          (compiler-debug-fun component))
            (:copier nil))
  ;; compiler's dumped DEBUG-FUN information (unexported)
  (compiler-debug-fun nil :type sb!c::compiled-debug-fun
                          :read-only t)
  ;; code object (unexported).
  (component nil :read-only t)
  ;; the :FUN-START breakpoint (if any) used to facilitate
  ;; function end breakpoints
  (end-starter nil :type (or null breakpoint)))
\f
;;;; CODE-LOCATIONs

(defmethod print-object ((obj code-location) str)
  (print-unreadable-object (obj str :type t)
    (prin1 (debug-fun-name (code-location-debug-fun obj))
           str)))

(defstruct (compiled-code-location
             (:include code-location)
             (:constructor make-known-code-location
                           (pc debug-fun %debug-block %form-number
                               %live-set kind step-info context &aux (%unknown-p nil)))
             (:constructor make-compiled-code-location (pc debug-fun))
             (:copier nil))
  ;; an index into DEBUG-FUN's component slot
  (pc nil :type index :read-only t)
  ;; a bit-vector indexed by a variable's position in
  ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a
  ;; valid value at this code-location. (unexported).
  (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
  ;; (unexported) To see SB!C::LOCATION-KIND, do
  ;; (SB!KERNEL:TYPEXPAND 'SB!C::LOCATION-KIND).
  (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))
  (step-info :unparsed :type (or (member :unparsed :foo) simple-string))
  (context :unparsed))
\f
;;;; frames

;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
;;; and LRAs used for :FUN-END breakpoints. When a component's
;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the
;;; real component to continue executing, as opposed to the bogus
;;; component which appeared in some frame's LRA location.
(defconstant real-lra-slot
  ;; X86 stores a fixup vector at the first constant slot
  #!-x86 sb!vm:code-constants-offset
  #!+x86 (1+ sb!vm:code-constants-offset))

;;; These are magically converted by the compiler.
(defun current-sp () (current-sp))
(defun current-fp () (current-fp))
(defun stack-ref (s n) (stack-ref s n))
(defun %set-stack-ref (s n value) (%set-stack-ref s n value))
(defun fun-code-header (fun) (fun-code-header fun))
(defun lra-code-header (lra) (lra-code-header lra))
(defun %make-lisp-obj (value) (%make-lisp-obj value))
(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
(defun fun-word-offset (fun) (fun-word-offset fun))

#!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
(defun control-stack-pointer-valid-p (x &optional (aligned t))
  (declare (type system-area-pointer x))
  (let* (#!-stack-grows-downward-not-upward
         (control-stack-start
          (descriptor-sap *control-stack-start*))
         #!+stack-grows-downward-not-upward
         (control-stack-end
          (descriptor-sap *control-stack-end*)))
    #!-stack-grows-downward-not-upward
    (and (sap< x (current-sp))
         (sap<= control-stack-start x)
         (or (not aligned) (zerop (logand (sap-int x)
                                          (1- (ash 1 sb!vm:word-shift))))))
    #!+stack-grows-downward-not-upward
    (and (sap>= x (current-sp))
         (sap> control-stack-end x)
         (or (not aligned) (zerop (logand (sap-int x)
                                          (1- (ash 1 sb!vm:word-shift))))))))

(declaim (inline component-ptr-from-pc))
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
  (pc system-area-pointer))

(declaim (inline valid-lisp-pointer-p))
(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
  (pointer system-area-pointer))

(declaim (inline component-from-component-ptr))
(defun component-from-component-ptr (component-ptr)
  (declare (type system-area-pointer component-ptr))
  (make-lisp-obj (logior (sap-int component-ptr)
                         sb!vm:other-pointer-lowtag)))

;;;; (OR X86 X86-64) support

(defun compute-lra-data-from-pc (pc)
  (declare (type system-area-pointer pc))
  (let ((component-ptr (component-ptr-from-pc pc)))
    (unless (sap= component-ptr (int-sap #x0))
       (let* ((code (component-from-component-ptr component-ptr))
              (code-header-len (* (code-header-words 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)))))

#!+(or x86 x86-64)
(progn

(defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset)

;;; Check for a valid return address - it could be any valid C/Lisp
;;; address.
;;;
;;; XXX Could be a little smarter.
#!-sb-fluid (declaim (inline ra-pointer-valid-p))
(defun ra-pointer-valid-p (ra)
  (declare (type system-area-pointer ra))
  (and
   ;; not the first page (which is unmapped)
   ;;
   ;; FIXME: Where is this documented? Is it really true of every CPU
   ;; architecture? Is it even necessarily true in current SBCL?
   (>= (sap-int ra) 4096)
   ;; not a Lisp stack pointer
   (not (control-stack-pointer-valid-p ra))))

;;; Try to find a valid previous stack. This is complex on the x86 as
;;; it can jump between C and Lisp frames. To help find a valid frame
;;; it searches backwards.
;;;
;;; XXX Should probably check whether it has reached the bottom of the
;;; stack.
;;;
;;; XXX Should handle interrupted frames, both Lisp and C. At present
;;; it manages to find a fp trail, see linux hack below.
(declaim (maybe-inline x86-call-context))
(defun x86-call-context (fp)
  (declare (type system-area-pointer fp))
  (let ((ocfp (sap-ref-sap fp (sb!vm::frame-byte-offset ocfp-save-offset)))
        (ra (sap-ref-sap fp (sb!vm::frame-byte-offset return-pc-save-offset))))
    (if (and (control-stack-pointer-valid-p fp)
             (sap> ocfp fp)
             (control-stack-pointer-valid-p ocfp)
             (ra-pointer-valid-p ra))
        (values t ra ocfp)
        (values nil (int-sap 0) (int-sap 0)))))

) ; #+x86 PROGN
\f
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
  (/noshow0 "entering TOP-FRAME")
  (compute-calling-frame (descriptor-sap (%caller-frame))
                         (%caller-pc)
                         nil))

;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
(defun flush-frames-above (frame)
  (setf (frame-up frame) nil)
  (do ((number 0 (1+ number))
       (frame frame (frame-%down 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!alien-internals:find-saved-fp-and-pc fp)
    (when saved-fp
      (compute-calling-frame saved-fp saved-pc up-frame t))))

;;; Return the frame immediately below FRAME on the stack; or when
;;; FRAME is the bottom of the stack, return NIL.
(defun frame-down (frame)
  (/noshow0 "entering FRAME-DOWN")
  ;; We have to access the old-fp and return-pc out of frame and pass
  ;; them to COMPUTE-CALLING-FRAME.
  (let ((down (frame-%down frame)))
    (if (eq down :unparsed)
        (let ((debug-fun (frame-debug-fun frame)))
          (/noshow0 "in DOWN :UNPARSED case")
          (setf (frame-%down frame)
                (etypecase debug-fun
                  (compiled-debug-fun
                   (let (#!-fp-and-pc-standard-save
                         (c-d-f (compiled-debug-fun-compiler-debug-fun
                                 debug-fun)))
                     (compute-calling-frame
                      (descriptor-sap
                       (get-context-value
                        frame ocfp-save-offset
                        #!-fp-and-pc-standard-save
                        (sb!c::compiled-debug-fun-old-fp c-d-f)
                        #!+fp-and-pc-standard-save
                        sb!c:old-fp-passing-offset))
                      (get-context-value
                       frame lra-save-offset
                       #!-fp-and-pc-standard-save
                       (sb!c::compiled-debug-fun-return-pc c-d-f)
                       #!+fp-and-pc-standard-save
                       sb!c:return-pc-passing-offset)
                      frame)))
                  (bogus-debug-fun
                   (let ((fp (frame-pointer frame)))
                     (when (control-stack-pointer-valid-p fp)
                       #!+(or x86 x86-64)
                       (multiple-value-bind (ok ra ofp) (x86-call-context fp)
                         (if ok
                             (compute-calling-frame ofp ra frame)
                             (find-saved-frame-down fp 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)))

;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
;;; standard save location offset on the stack. LOC is the saved
;;; SC-OFFSET describing the main location.
(defun get-context-value (frame stack-slot loc)
  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
           (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)
        #!-(or x86 x86-64)
        (stack-ref pointer stack-slot)
        #!+(or x86 x86-64)
        (ecase stack-slot
          (#.ocfp-save-offset
           (stack-ref pointer stack-slot))
          (#.lra-save-offset
           (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot)))))))

(defun (setf get-context-value) (value frame stack-slot loc)
  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
           (type sb!c:sc-offset loc))
  (let ((pointer (frame-pointer frame))
        (escaped (compiled-frame-escaped frame)))
    (if escaped
        (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 (sb!vm::frame-byte-offset stack-slot))
                 value))))))

(defun foreign-function-backtrace-name (sap)
  (let ((name (sap-foreign-symbol sap)))
    (if name
        (format nil "foreign function: ~A" name)
        (format nil "foreign function: #x~X" (sap-int sap)))))

;;; This returns a frame for the one existing in time immediately
;;; prior to the frame referenced by current-fp. This is current-fp's
;;; caller or the next frame down the control stack. If there is no
;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
;;; is the up link for the resulting frame object, and it is null when
;;; we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous
;;; frame we want, and the current frame contains the pc at which we
;;; will continue executing upon returning to that previous frame.
;;;
;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
;;; calls into C. In this case, the code object is stored on the stack
;;; after the LRA, and the LRA is the word offset.
#!-(or x86 x86-64)
(defun compute-calling-frame (caller lra up-frame &optional savedp)
  (declare (type system-area-pointer caller)
           (ignore savedp))
  (/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)
                (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 (code-header-words code)))
                             sb!vm:n-word-bytes)
                          nil)
                  (values :foreign-function
                          0
                          nil)))
            (find-escaped-frame caller))
      (if (and (code-component-p code)
               (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)))))
            (/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))))))

#!+(or x86 x86-64)
(defun compute-calling-frame (caller ra up-frame &optional savedp)
  (declare (type system-area-pointer caller ra))
  (/noshow0 "entering COMPUTE-CALLING-FRAME")
  (when (control-stack-pointer-valid-p caller)
    (/noshow0 "in WHEN")
    ;; First check for an escaped frame.
    (multiple-value-bind (code pc-offset escaped off-stack)
        (find-escaped-frame caller)
      (/noshow0 "at COND")
      (cond (code
             ;; 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))))
      (let ((d-fun (case code
                     (: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 escaped)))))
        (/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)
                             ;; If we have an interrupt-context that's not on
                             ;; our stack at all, and we're computing the
                             ;; from from a saved FP, we're probably looking
                             ;; at an interrupted syscall.
                             (or escaped (and savedp off-stack)))))))

(defun nth-interrupt-context (n)
  (declare (muffle-conditions t))
  (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
                          #!-alpha n
                          #!+alpha (* 2 n)))
                      (* os-context-t)))

;;; On SB-DYNAMIC-CORE symbols which come from the runtime go through
;;; an indirection table, but the debugger needs to know the actual
;;; address.
(defun static-foreign-symbol-address (name)
  #!+sb-dynamic-core
  (find-dynamic-foreign-symbol-address name)
  #!-sb-dynamic-core
  (foreign-symbol-address name))

;;;; See above.
(defun static-foreign-symbol-sap (name)
  (int-sap (static-foreign-symbol-address name)))

#!+(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
  (declare (type system-area-pointer frame-pointer))
  (/noshow0 "entering FIND-ESCAPED-FRAME")
  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
    (let* ((context (nth-interrupt-context index))
           (cfp (int-sap (context-register context sb!vm::cfp-offset))))
      (/noshow0 "got CONTEXT")
      (unless (control-stack-pointer-valid-p cfp)
        (return (values nil nil nil t)))
      (when (sap= frame-pointer cfp)
        (without-gcing
          (/noshow0 "in WITHOUT-GCING")
          (let* ((pc (context-pc context))
                 (component-ptr (component-ptr-from-pc pc))
                 (code (unless (sap= component-ptr (int-sap #x0))
                         (component-from-component-ptr component-ptr))))
            (/noshow0 "got CODE")
            (when (null code)
              ;; KLUDGE: Detect undefined functions by a range-check
              ;; against the trampoline address and the following
              ;; function in the runtime.
              (return (values code 0 context)))
            (let* ((code-header-len (* (code-header-words code)
                                       sb!vm:n-word-bytes))
                   (pc-offset
                     (- (sap-int pc)
                        (- (get-lisp-obj-address code)
                           sb!vm:other-pointer-lowtag)
                        code-header-len)))
              (/noshow "got PC-OFFSET")
              (unless (<= 0 pc-offset (%code-code-size code))
                ;; We were in an assembly routine. Therefore, use the
                ;; LRA as the pc.
                ;;
                ;; FIXME: Should this be WARN or ERROR or what?
                (format t "** pc-offset ~S not in code obj ~S?~%"
                        pc-offset code))
              (/noshow0 "returning from FIND-ESCAPED-FRAME")
              (return
                (values code pc-offset context)))))))))

#!-(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
  (declare (type system-area-pointer frame-pointer))
  (/noshow0 "entering FIND-ESCAPED-FRAME")
  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
    (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 (* (code-header-words code)
                                       sb!vm:n-word-bytes))
                   (pc-offset
                     (- (sap-int (sb!vm:context-pc scp))
                        (- (get-lisp-obj-address code)
                           sb!vm:other-pointer-lowtag)
                        code-header-len)))
              (let ((code-size (%code-code-size code)))
                (unless (<= 0 pc-offset code-size)
                  ;; We were in an assembly routine.
                  (multiple-value-bind (new-pc-offset computed-return)
                      (find-pc-from-assembly-fun code scp)
                    (setf pc-offset new-pc-offset)
                    (unless (<= 0 pc-offset code-size)
                      (cerror
                       "Set PC-OFFSET to zero and continue backtrace."
                       'bug
                       :format-control
                       "~@<PC-OFFSET (~D) not in code object. Frame details:~
                       ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
                       #X~X~:@_COMPUTED RETURN: #X~X.~:>"
                       :format-arguments
                       (list pc-offset
                             (sap-int (sb!vm:context-pc scp))
                             code
                             (%code-entry-point code 0)
                             #!-(or arm arm64)
                             (sb!vm:context-register scp sb!vm::lra-offset)
                             #!+(or arm arm64)
                             (stack-ref frame-pointer lra-save-offset)
                             computed-return))
                      ;; We failed to pinpoint where PC is, but set
                      ;; pc-offset to 0 to keep the backtrace from
                      ;; exploding.
                      (setf pc-offset 0)))))
              (/noshow0 "returning from FIND-ESCAPED-FRAME")
              (return
                (if (eq (%code-debug-info code) :bogus-lra)
                    (let ((real-lra (code-header-ref code
                                                     real-lra-slot)))
                      (values (lra-code-header real-lra)
                              (get-header-data real-lra)
                              nil))
                    (values code pc-offset scp))))))))))

#!-(or x86 x86-64)
(defun find-pc-from-assembly-fun (code scp)
  "Finds the PC for the return from an assembly routine properly.
For some architectures (such as PPC) this will not be the $LRA
register."
  (let ((return-machine-address (sb!vm::return-machine-address scp))
        (code-header-len (* (code-header-words code) sb!vm:n-word-bytes)))
    (values (- return-machine-address
               (- (get-lisp-obj-address code)
                  sb!vm:other-pointer-lowtag)
               code-header-len)
            return-machine-address)))

;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
#!-(or x86 x86-64)
(defun code-object-from-bits (bits)
  (declare (type word bits))
  (let ((object (make-lisp-obj bits nil)))
    (if (functionp object)
        (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-widetag)
                     (lra-code-header object))
                    (t
                     nil))))))))
\f
;;;; frame utilities

(defun find-assembly-routine (component pc)
  (let* ((start (sap-int (code-instructions component)))
         (end (+ start pc))
         (min-name)
         (min-diff))
    (loop for name being the hash-key of sb!fasl:*assembler-routines*
          using (hash-value address)
          when (and (<= start address end)
                    (or (not min-diff)
                        (< (- end address) min-diff)))
          do (setf min-name name
                   min-diff (- end address)))
    min-name))

(defun compiled-debug-fun-from-pc (debug-info pc &optional escaped)
  (let* ((fun-map (sb!c::compiled-debug-info-fun-map debug-info))
         (len (length fun-map)))
    (declare (type simple-vector fun-map))
    (if (= len 1)
        (svref fun-map 0)
        (let* ((i 1)
               (first-elsewhere-pc (sb!c::compiled-debug-fun-elsewhere-pc
                                    (svref fun-map 0)))
               (elsewhere-p
                 (if escaped ;; See the comment below
                     (>= pc first-elsewhere-pc)
                     (> pc first-elsewhere-pc))))
          (declare (type sb!int:index i))
          (loop
           (when (or (= i len)
                     (let ((next-pc (if elsewhere-p
                                        (sb!c::compiled-debug-fun-elsewhere-pc
                                         (svref fun-map (1+ i)))
                                        (svref fun-map i))))
                       (if escaped
                           (< pc next-pc)
                           ;; Non-escaped frame means that this frame calls something.
                           ;; And the PC points to where something should return.
                           ;; The return adress may be in the next
                           ;; function, e.g. in local tail calls the
                           ;; function will be entered just after the
                           ;; CALL.
                           ;; See debug.impure.lisp/:local-tail-call for a test-case
                           (<= pc next-pc))))
             (return (svref fun-map (1- i))))
           (incf i 2))))))

;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
;;; reference the COMPONENT, for function constants, and the
;;; SB!C::COMPILED-DEBUG-FUN.
(defun debug-fun-from-pc (component pc &optional (escaped t))
  (let ((info (%code-debug-info component)))
    (cond
      ((not info)
       (let ((routine (find-assembly-routine component pc)))
         (make-bogus-debug-fun (cond ((not routine)
                                      "no debug information for frame")
                                     ((memq routine '(sb!vm::undefined-tramp
                                                      sb!vm::undefined-alien-tramp))
                                      "undefined function")
                                     (routine)))))
     ((eq info :bogus-lra)
      (make-bogus-debug-fun "function end breakpoint"))
     (t
      (make-compiled-debug-fun (compiled-debug-fun-from-pc info pc escaped) component)))))

;;; This returns a code-location for the COMPILED-DEBUG-FUN,
;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
;;; make an :UNSURE code location, so it can be filled in when we
;;; figure out what is going on.
(defun code-location-from-pc (debug-fun pc escaped)
  (or (and (compiled-debug-fun-p debug-fun)
           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)))))
      (make-compiled-code-location pc debug-fun)))

;;; Return an alist mapping catch tags to CODE-LOCATIONs. These are
;;; CODE-LOCATIONs at which execution would continue with frame as the
;;; top frame if someone threw to the corresponding tag.
(defun frame-catches (frame)
  (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
        (reversed-result nil)
        (fp (frame-pointer frame)))
    (loop until (zerop (sap-int catch))
          finally (return (nreverse reversed-result))
          do
          (when (sap= fp
                      #!-alpha
                      (sap-ref-sap catch
                                   (* sb!vm:catch-block-cfp-slot
                                      sb!vm:n-word-bytes))
                      #!+alpha
                      (int-sap
                       (sap-ref-32 catch
                                   (* sb!vm:catch-block-cfp-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-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))
                          (code-header-words component))
                       sb!vm:n-word-bytes)
                    #!+(or x86 x86-64)
                    (- (sap-int ra)
                       (- (get-lisp-obj-address component)
                          sb!vm:other-pointer-lowtag)
                       (* (code-header-words 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)))))))

;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
(defun replace-frame-catch-tag (frame old-tag new-tag)
  (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
        (fp (frame-pointer frame)))
    (loop until (zerop (sap-int catch))
          do (when (sap= fp
                         #!-alpha
                         (sap-ref-sap catch
                                      (* sb!vm:catch-block-cfp-slot
                                         sb!vm:n-word-bytes))
                         #!+alpha
                         (int-sap
                          (sap-ref-32 catch
                                      (* sb!vm:catch-block-cfp-slot
                                         sb!vm:n-word-bytes))))
               (let ((current-tag
                      #!-(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)))))
                 (when (eq current-tag old-tag)
                   #!-(or x86 x86-64)
                   (setf (stack-ref catch sb!vm:catch-block-tag-slot) new-tag)
                   #!+(or x86 x86-64)
                   (setf (sap-ref-word catch (* sb!vm:catch-block-tag-slot
                                                sb!vm:n-word-bytes))
                         (get-lisp-obj-address new-tag)))))
          do (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)))))))


\f
;;;; operations on DEBUG-FUNs

;;; Execute the forms in a context with BLOCK-VAR bound to each
;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
;;; returns nil if there is no result form. This signals a
;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
;;; DEBUG-BLOCK information.
(defmacro do-debug-fun-blocks ((block-var debug-fun &optional result)
                               &body body)
  (let ((blocks (gensym))
        (i (gensym)))
    `(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))
       (declare (simple-vector ,blocks))
       (dotimes (,i (length ,blocks) ,result)
         (let ((,block-var (svref ,blocks ,i)))
           ,@body)))))

;;; Execute body in a context with VAR bound to each DEBUG-VAR in
;;; DEBUG-FUN. This returns the value of executing result (defaults to
;;; nil). This may iterate over only some of DEBUG-FUN's variables or
;;; none depending on debug policy; for example, possibly the
;;; compilation only preserved argument information.
(defmacro do-debug-fun-vars ((var debug-fun &optional result) &body body)
  (let ((vars (gensym))
        (i (gensym)))
    `(let ((,vars (debug-fun-debug-vars ,debug-fun)))
       (declare (type (or null simple-vector) ,vars))
       (if ,vars
           (dotimes (,i (length ,vars) ,result)
             (let ((,var (svref ,vars ,i)))
               ,@body))
           ,result))))

(defun function-start-pc-offset (function)
  (let* ((fun (%fun-fun function))
         (code (fun-code-header fun)))
    (- (* (fun-word-offset fun) n-word-bytes)
       (code-header-words code))))

;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
;;; or NIL if the function is unavailable or is non-existent as a user
;;; callable function object.
(defun debug-fun-fun (debug-fun)
  (let ((cached-value (debug-fun-%function debug-fun)))
    (if (eq cached-value :unparsed)
        (setf (debug-fun-%function debug-fun)
              (etypecase debug-fun
                (compiled-debug-fun
                 (let (result)
                   (loop with component = (compiled-debug-fun-component debug-fun)
                         with start-pc = (sb!c::compiled-debug-fun-start-pc
                                          (compiled-debug-fun-compiler-debug-fun debug-fun))
                         for i below (code-n-entries component)
                         for entry = (%code-entry-point component i)
                         while (> start-pc (function-start-pc-offset entry))
                         do (setf result entry))
                   result))
                (bogus-debug-fun nil)))
        cached-value)))

;;; Return the name of the function represented by DEBUG-FUN. This may
;;; be a string or a cons; do not assume it is a symbol.
(defun debug-fun-name (debug-fun &optional (pretty t))
  (declare (type debug-fun debug-fun) (ignorable pretty))
  (etypecase debug-fun
    (compiled-debug-fun
     (let ((name (sb!c::compiled-debug-fun-name
                  (compiled-debug-fun-compiler-debug-fun debug-fun))))
       ;; Frames named (.EVAL. special-operator) should show the operator name
       ;; in backtraces, but if the debugger needs to detect that the frame is
       ;; interpreted for other purposes, it can specify PRETTY = NIL.
       (cond #!+sb-fasteval
             ((and (typep name '(cons (eql sb!interpreter::.eval.)))
                   pretty)
              (if (singleton-p (cdr name)) (cadr name) (cdr name)))
             (t name))))
    (bogus-debug-fun
     (bogus-debug-fun-%name debug-fun))))

(defun interrupted-frame-error (frame)
  (declare (special sb!kernel::*current-internal-error*))
  (when (and (compiled-frame-p frame)
             (compiled-frame-escaped frame)
             sb!kernel::*current-internal-error*
             (array-in-bounds-p sb!c:+backend-internal-errors+
                                sb!kernel::*current-internal-error*))
    (cadr (svref sb!c:+backend-internal-errors+
                 sb!kernel::*current-internal-error*))))

(defun all-args-available-p (frame)
  (let ((error (interrupted-frame-error frame))
        (df (frame-debug-fun frame)))
    (or #!+precise-arg-count-error
        (and (eq error 'invalid-arg-count-error)
             (eq (debug-fun-kind df) :external))
        (and (eq error 'undefined-fun-error)
             (bogus-debug-fun-p df)))))

;; Return the name of the closure, if named, otherwise nil.
(defun debug-fun-closure-name (debug-fun frame)
  (unless (typep debug-fun 'compiled-debug-fun)
    (return-from debug-fun-closure-name nil))
  (let ((compiler-debug-fun (compiled-debug-fun-compiler-debug-fun debug-fun)))
    (acond
       ;; Frames named (.APPLY. something) are interpreted function applicators.
       ;; Show them as the name of the interpreted function being applied.
       #!+sb-fasteval
       ((let ((name (sb!c::compiled-debug-fun-name compiler-debug-fun)))
          (when (typep name '(cons (eql sb!interpreter::.apply.)))
            ;; Find a variable named FUN.
            (awhen (car (debug-fun-symbol-vars debug-fun 'sb!interpreter::fun))
              (let ((val (debug-var-value it frame))) ; Ensure it's a function
                (when (typep val 'sb!interpreter:interpreted-function)
                  (%fun-name val))))))) ; Get its name
       ((sb!c::compiled-debug-fun-closure-save compiler-debug-fun)
        (sb!impl::closure-name
         (if (all-args-available-p frame)
             (sub-access-debug-var-slot (frame-pointer frame)
                                        sb!c:closure-sc
                                        (compiled-frame-escaped frame))
             (sub-access-debug-var-slot (frame-pointer frame) it)))))))

;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun)
  (declare (type function fun))
  (let ((simple-fun (%fun-fun fun)))
    (let* ((name (%simple-fun-name simple-fun))
           (component (fun-code-header simple-fun))
           (res (find-if
                 (lambda (x)
                   (and (sb!c::compiled-debug-fun-p x)
                        (eq (sb!c::compiled-debug-fun-name x) name)
                        (eq (sb!c::compiled-debug-fun-kind x) nil)))
                 (sb!c::compiled-debug-info-fun-map
                  (%code-debug-info component)))))
      (if res
          (make-compiled-debug-fun res component)
          ;; KLUDGE: comment from CMU CL:
          ;;   This used to be the non-interpreted branch, but
          ;;   William wrote it to return the debug-fun of fun's XEP
          ;;   instead of fun's debug-fun. The above code does this
          ;;   more correctly, but it doesn't get or eliminate all
          ;;   appropriate cases. It mostly works, and probably
          ;;   works for all named functions anyway.
          ;; -- WHN 20000120
          (debug-fun-from-pc component
                             (* (- (fun-word-offset simple-fun)
                                   (code-header-words component))
                                sb!vm:n-word-bytes))))))

;;; Return the kind of the function, which is one of :OPTIONAL, :MORE
;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
(defun debug-fun-kind (debug-fun)
  ;; FIXME: This "is one of" information should become part of the function
  ;; declamation, not just a doc string
  (etypecase debug-fun
    (compiled-debug-fun
     (sb!c::compiled-debug-fun-kind
      (compiled-debug-fun-compiler-debug-fun debug-fun)))
    (bogus-debug-fun
     nil)))

;;; Is there any variable information for DEBUG-FUN?
(defun debug-var-info-available (debug-fun)
  (not (not (debug-fun-debug-vars debug-fun))))

;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
;;; a list of DEBUG-VARs without package names and with the same name
;;; as symbol. The result of this function is limited to the
;;; availability of variable information in DEBUG-FUN; for
;;; example, possibly DEBUG-FUN only knows about its arguments.
(defun debug-fun-symbol-vars (debug-fun symbol)
  (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
        (package (and (symbol-package symbol)
                      (package-name (symbol-package symbol)))))
    (delete-if (if (stringp package)
                   (lambda (var)
                     (let ((p (debug-var-package-name var)))
                       (or (not (stringp p))
                           (string/= p package))))
                   (lambda (var)
                     (stringp (debug-var-package-name var))))
               vars)))

;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
;;; NAME-PREFIX-STRING as an initial substring. The result of this
;;; function is limited to the availability of variable information in
;;; debug-fun; for example, possibly debug-fun only knows
;;; about its arguments.
(defun ambiguous-debug-vars (debug-fun name-prefix-string)
  (declare (simple-string name-prefix-string))
  (let ((variables (debug-fun-debug-vars debug-fun)))
    (declare (type (or null simple-vector) variables))
    (if variables
        (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)
           (simple-string name))
  (let ((name-len (length name)))
    (position name 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)))))

;;; Return a list representing the lambda-list for DEBUG-FUN. The
;;; list has the following structure:
;;;   (required-var1 required-var2
;;;    ...
;;;    (:optional var3 suppliedp-var4)
;;;    (:optional var5)
;;;    ...
;;;    (:rest var6) (:rest var7)
;;;    ...
;;;    (:keyword keyword-symbol var8 suppliedp-var9)
;;;    (:keyword keyword-symbol var10)
;;;    ...
;;;   )
;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
;;; it is unreferenced in DEBUG-FUN. This signals a
;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
;;; information.
(defun debug-fun-lambda-list (debug-fun)
  (etypecase debug-fun
    (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun))
    (bogus-debug-fun nil)))

;;; Note: If this has to compute the lambda list, it caches it in DEBUG-FUN.
(defun compiled-debug-fun-lambda-list (debug-fun)
  (let ((lambda-list (debug-fun-%lambda-list debug-fun)))
    (cond ((eq lambda-list :unparsed)
           (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)))))

;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
;;; returns the lambda list as the first value and whether there was
;;; any argument information as the second value. Therefore,
;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
;;; means there was no argument information.
(defun parse-compiled-debug-fun-lambda-list (debug-fun)
  (let ((args (sb!c::compiled-debug-fun-arguments
               (compiled-debug-fun-compiler-debug-fun debug-fun))))
    (cond
      ((not args)
       (values nil nil))
      ((eq args :minimal)
       (values (coerce (debug-fun-debug-vars debug-fun) 'list)
               t))
      (t
       (values (parse-compiled-debug-fun-lambda-list/args-available
                (debug-fun-debug-vars debug-fun) args)
               t)))))

(defun parse-compiled-debug-fun-lambda-list/args-available (vars args)
  (declare (type (or null simple-vector) vars))
  (let ((i 0)
        (len (length args))
        (optionalp nil)
        (keyword nil)
        (result '()))
    (flet ((push-var (tag-and-info &optional var-count)
             (push (if var-count
                       (append tag-and-info
                               (loop :repeat var-count :collect
                                  (compiled-debug-fun-lambda-list-var
                                   args (incf i) vars)))
                       tag-and-info)
                   result))
           (var-or-deleted (index-or-deleted)
             (if (eq index-or-deleted sb!c::debug-info-var-deleted)
                 :deleted
                 (svref vars index-or-deleted))))
      (loop
         :while (< i len)
         :for ele = (aref args i) :do
         (cond
           ((eq ele sb!c::debug-info-var-optional)
            (setf optionalp t))
           ((eq ele sb!c::debug-info-var-rest)
            (push-var '(:rest) 1))
           ;; The next two args are the &MORE arg context and
           ;; count.
           ((eq ele sb!c::debug-info-var-more)
            (push-var '(:more) 2))
           ;; 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.
           ((eq ele sb!c::debug-info-var-supplied-p)
            (push-var (pop result) 1))
           ;; The keyword of a keyword parameter. Store it so the next
           ;; element can be used to form a (:keyword KEYWORD VALUE)
           ;; entry.
           ((typep ele 'symbol)
            (setf keyword ele))
           ;; The previous element was the keyword of a keyword
           ;; parameter and is stored in KEYWORD. The current element
           ;; is the index of the value (or a deleted
           ;; marker). Construct and push the complete entry.
           (keyword
            (push-var (list :keyword keyword (var-or-deleted ele))))
           ;; We saw an optional marker, so the following non-symbols
           ;; are indexes (or deleted markers) indicating optional
           ;; variables.
           (optionalp
            (push-var (list :optional (var-or-deleted ele))))
           ;; Deleted required, optional or keyword argument.
           ((eq ele sb!c::debug-info-var-deleted)
            (push-var :deleted))
           ;; Required arg at beginning of args array.
           (t
            (push-var (svref vars ele))))
         (incf i)
         :finally (return (nreverse result))))))

;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
(defun compiled-debug-fun-lambda-list-var (args i vars)
  (declare (type (simple-array * (*)) args)
           (simple-vector vars))
  (let ((ele (aref args i)))
    (cond ((typep ele 'index) (svref vars ele))
          ((eq ele sb!c::debug-info-var-deleted) :deleted)
          (t (error "malformed arguments description")))))

(defun compiled-debug-fun-debug-info (debug-fun)
  (%code-debug-info (compiled-debug-fun-component debug-fun)))
\f
;;;; unpacking variable and basic block data

;;; The argument is a debug internals structure. This returns the
;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
;;; return the blocks.
(defun debug-fun-debug-blocks (debug-fun)
  (let ((blocks (debug-fun-blocks debug-fun)))
    (cond ((eq blocks :unparsed)
           (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)))))

;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
;;; was no basic block information.
(defun parse-debug-blocks (debug-fun)
  (etypecase debug-fun
    (compiled-debug-fun
     (parse-compiled-debug-blocks debug-fun))
    (bogus-debug-fun
     (debug-signal 'no-debug-blocks :debug-fun debug-fun))))

;;; This does some of the work of PARSE-DEBUG-BLOCKS.
(defun parse-compiled-debug-blocks (debug-fun)
  (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
    (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
           (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
                                debug-fun))
           (blocks (or (sb!c::compiled-debug-fun-blocks compiler-debug-fun)
                       (return-from parse-compiled-debug-blocks nil)))
           ;; 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))
           (elsewhere-pc (sb!c::compiled-debug-fun-elsewhere-pc compiler-debug-fun))
           elsewhere-p
           (len (length blocks))
           (i 0)
           (last-pc 0)
           result-blocks
           (block (make-compiled-debug-block))
           locations)
      (flet ((new-block ()
               (when locations
                 (setf (compiled-debug-block-code-locations block)
                       (coerce (nreverse (shiftf locations nil))
                               'simple-vector)
                       (compiled-debug-block-elsewhere-p block)
                       elsewhere-p)
                 (push block result-blocks)
                 (setf block (make-compiled-debug-block)))))
        (loop
         (when (>= i len)
           (new-block)
           (return))
         (let* ((flags (aref+ blocks i))
                (kind (svref sb!c::+compiled-code-location-kinds+
                             (ldb (byte 4 0) flags)))
                (pc (+ last-pc
                       (sb!c:read-var-integerf blocks i)))
                (form-number
                  (if (logtest sb!c::compiled-code-location-zero-form-number flags)
                      0
                      (sb!c:read-var-integerf blocks i)))
                (live-set
                  (if (logtest sb!c::compiled-code-location-live flags)
                      (sb!c:read-packed-bit-vector live-set-len blocks i)
                      (make-array (* live-set-len 8) :element-type 'bit)))
                (step-info
                  (if (logtest sb!c::compiled-code-location-stepping flags)
                      (sb!c:read-var-string blocks i)
                      ""))
                (context
                  (and (logtest sb!c::compiled-code-location-context flags)
                       (svref (sb!c::compiled-debug-info-contexts
                               (%code-debug-info (compiled-debug-fun-component debug-fun)))
                              (sb!c:read-var-integerf blocks i)))))
           (when (or (memq kind '(:block-start :non-local-entry))
                     (and (not elsewhere-p)
                          (> pc elsewhere-pc)
                          (setf elsewhere-p t)))
             (new-block))
           (push (make-known-code-location
                  pc debug-fun block
                  form-number live-set kind
                  step-info context)
                 locations)
           (setf last-pc pc))))
      (coerce (nreverse result-blocks) 'simple-vector))))

;;; The argument is a debug internals structure. This returns NIL if
;;; there is no variable information. It returns an empty
;;; simple-vector if there were no locals in the function. Otherwise
;;; it returns a SIMPLE-VECTOR of DEBUG-VARs.
(defun debug-fun-debug-vars (debug-fun)
  (let ((vars (debug-fun-%debug-vars debug-fun)))
    (if (eq vars :unparsed)
        (setf (debug-fun-%debug-vars debug-fun)
              (etypecase debug-fun
                (compiled-debug-fun
                 (parse-compiled-debug-vars debug-fun))
                (bogus-debug-fun nil)))
        vars)))

;;; VARS is the parsed variables for a minimal debug function. We need
;;; to assign names of the form ARG-NNN. We must pad with leading
;;; zeros, since the arguments must be in alphabetical order.
(defun assign-minimal-var-names (vars)
  (declare (simple-vector vars))
  (let* ((len (length vars))
         (width (length (format nil "~W" (1- len)))))
    (dotimes (i len)
      (without-package-locks
        (setf (compiled-debug-var-symbol (svref vars i))
              (intern (format nil "ARG-~V,'0D" width i)
                      ;; The cross-compiler won't dump literal package
                      ;; references because the target package objects
                      ;; aren't created until partway through
                      ;; cold-init. In lieu of adding smarts to the
                      ;; build framework to handle this, we use an
                      ;; explicit load-time-value form.
                      (load-time-value (find-package "SB!DEBUG"))))))))

;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
;;; of DEBUG-VARs, or NIL if there was no information to parse.
(defun parse-compiled-debug-vars (debug-fun)
  (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
                      debug-fun))
         (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun))
         (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
                           :minimal)))
    (when packed-vars
      (do ((i 0)
           (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))
                 (more-context-p (logtest sb!c::compiled-debug-var-more-context-p flags))
                 (more-count-p (logtest sb!c::compiled-debug-var-more-count-p flags))
                 (indirect-p (logtest sb!c::compiled-debug-var-indirect-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 (or more-count-p
                                 more-context-p
                                 minimal)
                             nil (geti)))
                 (id (if (logtest sb!c::compiled-debug-var-id-p flags)
                         (geti)
                         0))
                 (sc-offset (if deleted 0
                                #!-64-bit (geti)
                                #!+64-bit (ldb (byte 27 8) flags)))
                 (save-sc-offset (and save
                                      #!-64-bit (geti)
                                      #!+64-bit (ldb (byte 27 35) flags)))
                 (indirect-sc-offset (and indirect-p
                                          (geti))))
            (aver (not (and args-minimal (not minimal))))
            (vector-push-extend (make-compiled-debug-var symbol
                                                         id
                                                         live
                                                         sc-offset
                                                         save-sc-offset
                                                         indirect-sc-offset
                                                         (cond (more-context-p :more-context)
                                                               (more-count-p :more-count)))
                                buffer)))))))
\f
;;;; CODE-LOCATIONs

;;; If we're sure of whether code-location is known, return T or NIL.
;;; If we're :UNSURE, then try to fill in the code-location's slots.
;;; This determines whether there is any debug-block information, and
;;; if code-location is known.
;;;
;;; ??? IF this conses closures every time it's called, then break off the
;;; :UNSURE part to get the HANDLER-CASE into another function.
(defun code-location-unknown-p (basic-code-location)
  (ecase (code-location-%unknown-p basic-code-location)
    ((t) t)
    ((nil) nil)
    (:unsure
     (setf (code-location-%unknown-p basic-code-location)
           (handler-case (not (fill-in-code-location basic-code-location))
             (no-debug-blocks () t))))))

;;; Return the DEBUG-BLOCK containing code-location if it is available.
;;; Some debug policies inhibit debug-block information, and if none
;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
(defun code-location-debug-block (basic-code-location)
  (let ((block (code-location-%debug-block basic-code-location)))
    (if (eq block :unparsed)
        (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)))

;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
;;; the correct one using the code-location's pc. We use
;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
;;; their first code-location's pc, in ascending order. Therefore, as
;;; soon as we find a block that starts with a pc greater than
;;; basic-code-location's pc, we know the previous block contains the
;;; pc. If we get to the last block, then the code-location is either
;;; in the second to last block or the last block, and we have to be
;;; careful in determining this since the last block could be code at
;;; the end of the function. We have to check for the last block being
;;; code first in order to see how to compare the code-location's pc.
(defun compute-compiled-code-location-debug-block (basic-code-location)
  (let* ((pc (compiled-code-location-pc basic-code-location))
         (debug-fun (code-location-debug-fun
                          basic-code-location))
         (blocks (debug-fun-debug-blocks debug-fun))
         (len (length blocks)))
    (declare (simple-vector blocks))
    (setf (code-location-%debug-block basic-code-location)
          (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)))))))))

;;; Return the CODE-LOCATION's DEBUG-SOURCE.
(defun code-location-debug-source (code-location)
  (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)))))

;;; Returns the number of top level forms before the one containing
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
;;; compilation unit is not necessarily a single file, see the section
;;; on debug-sources.)
(defun code-location-toplevel-form-offset (code-location)
  (let ((di (compiled-debug-fun-debug-info
             (code-location-debug-fun code-location))))
    (sb!c::compiled-debug-info-tlf-number di)))

;;; Return the number of the form corresponding to CODE-LOCATION. The
;;; form number is derived by a walking the subforms of a top level
;;; form in depth-first order.
(defun code-location-form-number (code-location)
  (when (code-location-unknown-p code-location)
    (error 'unknown-code-location :code-location code-location))
  (let ((form-num (code-location-%form-number code-location)))
    (cond ((eq form-num :unparsed)
           (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,
;;;  :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
;;;  :NON-LOCAL-ENTRY
(defun code-location-kind (code-location)
  (when (code-location-unknown-p code-location)
    (error 'unknown-code-location :code-location code-location))
  (etypecase code-location
    (compiled-code-location
     (let ((kind (compiled-code-location-kind code-location)))
       (cond ((not (eq kind :unparsed)) kind)
             ((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)))))
    ;; (There used to be more cases back before sbcl-0.7.0,,
    ;; when we did special tricks to debug the IR1
    ;; interpreter.)
    ))

;;; This returns CODE-LOCATION's live-set if it is available. If
;;; there is no debug-block information, this returns NIL.
(defun compiled-code-location-live-set (code-location)
  (if (code-location-unknown-p code-location)
      nil
      (let ((live-set (compiled-code-location-%live-set code-location)))
        (fill-in-code-location 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)))))

(defun code-location-context (code-location)
  (unless (code-location-unknown-p code-location)
    (let ((context (compiled-code-location-context code-location)))
      (cond ((eq context :unparsed)
             (etypecase code-location
               (compiled-code-location
                (unless (fill-in-code-location code-location)
                  (bug "unknown code location"))
                (compiled-code-location-context code-location))))
            (t context)))))

(defun error-context ()
  (let ((frame sb!debug:*stack-top-hint*))
    (when frame
      (code-location-context (frame-code-location frame)))))

(defun decode-arithmetic-error-operands (context)
  (let* ((alien-context (sb!alien:sap-alien context (* os-context-t)))
         (fp (int-sap (context-register alien-context
                                        sb!vm::cfp-offset)))
         (sb!debug:*stack-top-hint* (find-interrupted-frame))
         (error-context (error-context)))
    (and error-context
         (values (car error-context)
                 (loop for x in (cdr error-context)
                       collect (if (integerp x)
                                   (sub-access-debug-var-slot
                                    fp x alien-context)
                                   x))))))

;;; true if OBJ1 and OBJ2 are the same place in the code
(defun code-location= (obj1 obj2)
  (etypecase obj1
    (compiled-code-location
     (etypecase obj2
       (compiled-code-location
        (and (eq (code-location-debug-fun obj1)
                 (code-location-debug-fun obj2))
             (sub-compiled-code-location= obj1 obj2)))
       ;; (There used to be more cases back before sbcl-0.7.0,,
       ;; when we did special tricks to debug the IR1
       ;; interpreter.)
       ))
    ;; (There used to be more cases back before sbcl-0.7.0,,
    ;; when we did special tricks to debug IR1-interpreted code.)
    ))
(defun sub-compiled-code-location= (obj1 obj2)
  (= (compiled-code-location-pc obj1)
     (compiled-code-location-pc obj2)))

;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL
;;; depending on whether the code-location was known in its
;;; DEBUG-FUN's debug-block information. This may signal a
;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUN-DEBUG-BLOCKS, and
;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
(defun fill-in-code-location (code-location)
  (declare (type compiled-code-location code-location))
  (let* ((debug-fun (code-location-debug-fun code-location))
         (blocks (debug-fun-debug-blocks debug-fun))
         (found))
    (declare (simple-vector blocks))
    (dotimes (i (length blocks) nil)
      (let* ((block (svref blocks i))
             (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)
              (unless found
                (setf found loc))
              ;; There may be multiple locations in multiple blocks at a given PC, prefer
              ;; the :internal-error ones.
              (when (eq (compiled-code-location-kind loc) :internal-error)
                (setf found loc)
                (return)))))))
    (when found
      (setf (code-location-%debug-block code-location)
            (code-location-%debug-block found))
      (setf (code-location-%form-number code-location)
            (code-location-%form-number found))
      (setf (compiled-code-location-%live-set code-location)
            (compiled-code-location-%live-set found))
      (setf (compiled-code-location-kind code-location)
            (compiled-code-location-kind found))
      (setf (compiled-code-location-step-info code-location)
            (compiled-code-location-step-info found))
      (setf (compiled-code-location-context code-location)
            (compiled-code-location-context found))
      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)
                                    &body body)
  (let ((code-locations (gensym))
        (i (gensym)))
    `(let ((,code-locations (debug-block-code-locations ,debug-block)))
       (declare (simple-vector ,code-locations))
       (dotimes (,i (length ,code-locations) ,result)
         (let ((,code-var (svref ,code-locations ,i)))
           ,@body)))))

;;; Return the name of the function represented by DEBUG-FUN.
;;; This may be a string or a cons; do not assume it is a symbol.
(defun debug-block-fun-name (debug-block)
  (etypecase debug-block
    (compiled-debug-block
     (let ((code-locs (compiled-debug-block-code-locations debug-block)))
       (declare (simple-vector code-locs))
       (if (zerop (length code-locs))
           "??? Can't get name of debug-block's function."
           (debug-fun-name
            (code-location-debug-fun (svref code-locs 0))))))
    ;; (There used to be more cases back before sbcl-0.7.0, when we
    ;; did special tricks to debug the IR1 interpreter.)
    ))

(defun debug-block-code-locations (debug-block)
  (etypecase debug-block
    (compiled-debug-block
     (compiled-debug-block-code-locations debug-block))
    ;; (There used to be more cases back before sbcl-0.7.0, when we
    ;; did special tricks to debug the IR1 interpreter.)
    ))
\f
;;;; operations on debug variables

(defun debug-var-symbol-name (debug-var)
  (symbol-name (debug-var-symbol debug-var)))

;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
;;; be acceptable to have NIL returned, or that it's only called on
;;; DEBUG-VARs whose symbols have non-NIL packages.
(defun debug-var-package-name (debug-var)
  (package-name (symbol-package (debug-var-symbol debug-var))))

;;; Return the value stored for DEBUG-VAR in frame, or if the value is
;;; not :VALID, then signal an INVALID-VALUE error.
(defun debug-var-valid-value (debug-var frame)
  (unless (eq (debug-var-validity debug-var (frame-code-location frame))
              :valid)
    (error 'invalid-value :debug-var debug-var :frame frame))
  (debug-var-value debug-var frame))

;;; Returns the value stored for DEBUG-VAR in frame. The value may be
;;; invalid. This is SETFable.
(defun debug-var-value (debug-var frame)
  (aver (typep frame 'compiled-frame))
  (let ((res (access-compiled-debug-var-slot debug-var frame)))
    (if (indirect-value-cell-p res)
        (value-cell-ref res)
        res)))

;;; This returns what is stored for the variable represented by
;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
;;; cell if the variable is both closed over and set.
(defun access-compiled-debug-var-slot (debug-var frame)
  (let ((escaped (compiled-frame-escaped frame)))
    (cond ((compiled-debug-var-indirect-sc-offset debug-var)
           (sub-access-debug-var-slot
            ;; Indirect are accessed through a frame pointer of the parent.
            (descriptor-sap
             (sub-access-debug-var-slot
              (frame-pointer frame)
              (if escaped
                  (compiled-debug-var-sc-offset debug-var)
                  (or
                   (compiled-debug-var-save-sc-offset debug-var)
                   (compiled-debug-var-sc-offset debug-var)))
              escaped))
            (compiled-debug-var-indirect-sc-offset debug-var)
            escaped))
          (escaped
           (sub-access-debug-var-slot
            (frame-pointer frame)
            (compiled-debug-var-sc-offset debug-var)
            escaped))
          (t
           (sub-access-debug-var-slot
            (frame-pointer frame)
            (or (compiled-debug-var-save-sc-offset debug-var)
                (compiled-debug-var-sc-offset debug-var)))))))

;;; a helper function for working with possibly-invalid values:
;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
;;;
;;; (Such values can arise in registers on machines with conservative
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
;;;
;;; NOTE: this function is not GC-safe in the slightest when creating
;;; a pointer to an object in dynamic space.  If a GC occurs between
;;; the start of the call to VALID-LISP-POINTER-P and the end of
;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
;;; is constructed.  This can happen on CHENEYGC if an asynchronous
;;; interrupt occurs within the window.  This can happen on GENCGC
;;; under the same circumstances, but is more likely due to all GENCGC
;;; platforms supporting threaded operation.  This is somewhat
;;; mitigated on x86oids due to the conservative stack and interrupt
;;; context "scavenging" on such platforms, but there still may be a
;;; vulnerable window.
(defun make-lisp-obj (val &optional (errorp t))
  (macrolet ((maybe-tag-tramp (x)
               #!-(or sparc arm)
               `(+ (- ,x
                      (* sb!vm:n-word-bytes sb!vm:simple-fun-code-offset))
                   sb!vm:fun-pointer-lowtag)
               #!+(or sparc arm)
               x))
    (if (or
         ;; fixnum
         (zerop (logand val sb!vm:fixnum-tag-mask))
         ;; immediate single float, 64-bit only
         #!+64-bit
         (= (logand val #xff) sb!vm:single-float-widetag)
         ;; character
         (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
              (= (logand val #xff) sb!vm:character-widetag)) ; char tag
         ;; unbound marker
         (= val sb!vm:unbound-marker-widetag)
         ;; pointer
         (not (zerop (valid-lisp-pointer-p (int-sap val)))))
        (values (%make-lisp-obj val) t)
        (if errorp
            (error "~S is not a valid argument to ~S"
                   val 'make-lisp-obj)
            (values (make-unprintable-object (format nil "invalid object #x~X" val))
                    nil)))))

(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
                                 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))
             (with-nfp ((var) &body body)
               ;; x86oids have no separate number stack, so dummy it
               ;; up for them.
               #!+c-stack-is-control-stack
               `(let ((,var fp))
                  ,@body)
               #!-c-stack-is-control-stack
               `(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))
             (number-stack-offset (&optional (offset 0))
               #!+(or x86 x86-64)
               `(+ (sb!vm::frame-byte-offset (sb!c:sc-offset-offset sc-offset))
                   ,offset)
               #!-(or x86 x86-64)
               `(+ (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)
                   ,offset)))
    (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)
          (values (make-lisp-obj (mask-field (byte #.sb!vm:n-word-bits 0) 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))
      #!-(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
       (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-float-value complex-single-float))
      (#.sb!vm:complex-double-reg-sc-number
       (escaped-float-value complex-double-float))
      #!+long-float
      (#.sb!vm:complex-long-reg-sc-number
       (escaped-float-value sb!kernel::complex-long-float))
      (#.sb!vm:single-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-single nfp (number-stack-offset))))
      (#.sb!vm:double-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-double nfp (number-stack-offset))))
      #!+long-float
      (#.sb!vm:long-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-long nfp (number-stack-offset))))
      (#.sb!vm:complex-single-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-single nfp (number-stack-offset))
          (sap-ref-single nfp (number-stack-offset 4)))))
      (#.sb!vm:complex-double-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-double nfp (number-stack-offset))
          (sap-ref-double nfp (number-stack-offset 8)))))
      #!+long-float
      (#.sb!vm:complex-long-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-long nfp (number-stack-offset))
          (sap-ref-long nfp
                        (number-stack-offset #!+sparc 4
                                             #!+(or x86 x86-64) 3)))))
      (#.sb!vm:control-stack-sc-number
       (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
      (#.sb!vm:character-stack-sc-number
       (with-nfp (nfp)
         (code-char (sap-ref-word nfp (number-stack-offset)))))
      (#.sb!vm:unsigned-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-word nfp (number-stack-offset))))
      (#.sb!vm:signed-stack-sc-number
       (with-nfp (nfp)
         (signed-sap-ref-word nfp (number-stack-offset))))
      (#.sb!vm:sap-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-sap nfp (number-stack-offset))))
      (#.constant-sc-number
       (if escaped
           (code-header-ref
            (component-from-component-ptr
             (component-ptr-from-pc
              (sb!vm:context-pc escaped)))
            (sb!c:sc-offset-offset sc-offset))
           :invalid-value-for-unescaped-register-storage)))))

;;; This stores value as the value of DEBUG-VAR in FRAME. In the
;;; COMPILED-DEBUG-VAR case, access the current value to determine if
;;; it is an indirect value cell. This occurs when the variable is
;;; both closed over and set.
(defun %set-debug-var-value (debug-var frame new-value)
  (aver (typep frame 'compiled-frame))
  (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
    (if (indirect-value-cell-p old-value)
        (value-cell-set old-value new-value)
        (set-compiled-debug-var-slot debug-var frame new-value)))
  new-value)

;;; This stores VALUE for the variable represented by debug-var
;;; relative to the frame. This assumes the location directly contains
;;; the variable's value; that is, there is no indirect value cell
;;; currently there in case the variable is both closed over and set.
(defun set-compiled-debug-var-slot (debug-var frame value)
  (let ((escaped (compiled-frame-escaped frame)))
    (if escaped
        (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))))

(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
                           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)
               ;; 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
                                                         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))
             (number-stack-offset (&optional (offset 0))
               #!+(or x86 x86-64)
               `(+ (sb!vm::frame-byte-offset (sb!c:sc-offset-offset sc-offset))
                   ,offset)
               #!-(or x86 x86-64)
               `(+ (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes)
                   ,offset)))
    (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))
      #!-(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
       (set-escaped-float-value double-float value))
      #!+long-float
      (#.sb!vm:long-reg-sc-number
       (set-escaped-float-value long-float value))
      (#.sb!vm:complex-single-reg-sc-number
       (set-escaped-float-value complex-single-float value))
      (#.sb!vm:complex-double-reg-sc-number
       (set-escaped-float-value complex-double-float value))
      #!+long-float
      (#.sb!vm:complex-long-reg-sc-number
       (set-escaped-float-value complex-long-float))
      (#.sb!vm:single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (number-stack-offset))
               (the single-float value))))
      (#.sb!vm:double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double nfp (number-stack-offset))
               (the double-float value))))
      #!+long-float
      (#.sb!vm:long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long nfp (number-stack-offset))
               (the long-float value))))
      (#.sb!vm:complex-single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (number-stack-offset))
               #!+(or x86 x86-64)
               (realpart (the (complex single-float) value))
               #!-(or x86 x86-64)
               (the single-float (realpart value)))
         (setf (sap-ref-single nfp (number-stack-offset 4))
               #!+(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 (number-stack-offset))
               #!+(or x86 x86-64)
               (realpart (the (complex double-float) value))
               #!-(or x86 x86-64)
               (the double-float (realpart value)))
         (setf (sap-ref-double nfp (number-stack-offset 8))
               #!+(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 (number-stack-offset))
               #!+(or x86 x86-64)
               (realpart (the (complex long-float) value))
               #!-(or x86 x86-64)
               (the long-float (realpart value)))
         (setf (sap-ref-long
                nfp (number-stack-offset #!+sparc 4
                                        #!+(or x86 x86-64) 3))
               #!+(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-word nfp (number-stack-offset 0))
               (char-code (the character value)))))
      (#.sb!vm:unsigned-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-word nfp (number-stack-offset 0)) (the word value))))
      (#.sb!vm:signed-stack-sc-number
       (with-nfp (nfp)
         (setf (signed-sap-ref-word nfp (number-stack-offset))
               (the signed-word value))))
      (#.sb!vm:sap-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-sap nfp (number-stack-offset))
               (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.
(defun indirect-value-cell-p (x)
  (and (%other-pointer-p x)
       (eql (%other-pointer-widetag x) sb!vm:value-cell-widetag)))

;;; Return three values reflecting the validity of DEBUG-VAR's value
;;; at BASIC-CODE-LOCATION:
;;;   :VALID    The value is known to be available.
;;;   :INVALID  The value is known to be unavailable.
;;;   :UNKNOWN  The value's availability is unknown.
;;;
;;; If the variable is always alive, then it is valid. If the
;;; code-location is unknown, then the variable's validity is
;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
;;; live-set information has been cached in the code-location.
(defun debug-var-validity (debug-var basic-code-location)
  (compiled-debug-var-validity debug-var basic-code-location))

(defun debug-var-info (debug-var)
  (compiled-debug-var-info debug-var))

;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
;;; For safety, make sure basic-code-location is what we think.
(defun compiled-debug-var-validity (debug-var basic-code-location)
  (declare (type compiled-code-location basic-code-location))
  (cond ((debug-var-alive-p debug-var)
         (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)))))
\f
;;;; sources

;;; This code produces and uses what we call source-paths. A
;;; source-path is a list whose first element is a form number as
;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
;;; top level form number as returned by
;;; CODE-LOCATION-TOPLEVEL-FORM-NUMBER. The elements from the last to
;;; the first, exclusively, are the numbered subforms into which to
;;; descend. For example:
;;;    (defun foo (x)
;;;      (let ((a (aref x 3)))
;;;     (cons a 3)))
;;; The call to AREF in this example is form number 5. Assuming this
;;; DEFUN is the 11'th top level form, the source-path for the AREF
;;; call is as follows:
;;;    (5 1 0 1 3 11)
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.

;;; 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.
;;;
;;; The vector elements are in the same format as the compiler's
;;; NODE-SOURCE-PATH; that is, the first element is the form number and
;;; the last is the TOPLEVEL-FORM number.
;;;
;;; This should be synchronized with SB-C::SUB-FIND-SOURCE-PATHS
(defun form-number-translations (form tlf-number)
  (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 (sb!int:comma-p fm)
                                      (setf fm (sb!int:comma-expr fm)))
                                    (cond ((consp fm)
                                           (translate1 fm (cons pos path)))
                                          ((eq 'quote fm)
                                           ;; Don't look into quoted constants.
                                           (return)))
                                    (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
;;; number of enclosing forms to return instead of directly returning
;;; the source-path form. When context is non-zero, the form returned
;;; contains a marker, #:****HERE****, immediately before the form
;;; indicated by path.
(defun source-path-context (form path context)
  (declare (type unsigned-byte context))
  ;; Get to the form indicated by path or the enclosing form indicated
  ;; by context and path.
  (let ((path (reverse (butlast (cdr path)))))
    (dotimes (i (- (length path) context))
      (let ((index (first path)))
        (unless (and (listp form) (< index (length form)))
          (error "Source path no longer exists."))
        (setq form (elt form index))
        (setq path (rest path))))
    ;; Recursively rebuild the source form resulting from the above
    ;; descent, copying the beginning of each subform up to the next
    ;; subform we descend into according to path. At the bottom of the
    ;; recursion, we return the form indicated by path preceded by our
    ;; marker, and this gets spliced into the resulting list structure
    ;; on the way back up.
    (labels ((frob (form path level)
               (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))))))))
      (frob form path context))))

;;; Given a code location, return the associated form-number
;;; translations and the actual top level form.
(defun get-toplevel-form (location)
  (let ((d-source (code-location-debug-source location)))
    (let* ((offset (code-location-toplevel-form-offset location))
           (res
             (cond ((debug-source-form d-source)
                    (debug-source-form d-source))
                   ((debug-source-namestring d-source)
                    (get-file-toplevel-form location))
                   (t (bug "Don't know how to use a DEBUG-SOURCE without ~
                               a namestring or a form.")))))
      (values (form-number-translations res offset) res))))

;;; To suppress the read-time evaluation #. macro during source read,
;;; *READTABLE* is modified.
;;;
;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which
;;; this code can use for side- effect free #. calls?
;;;
;;; FIXME: This also knows nothing of custom readtables. The assumption
;;; is that the current readtable is a decent approximation for what
;;; we want, but that's lossy.
(defun safe-readtable ()
  (let ((rt (copy-readtable)))
    (set-dispatch-macro-character
     #\# #\. (lambda (stream sub-char &rest rest)
               (declare (ignore rest sub-char))
               (let ((token (read stream t nil t)))
                 (format nil "#.~S" token)))
     rt)
    rt))

;;; Locate the source file (if it still exists) and grab the top level
;;; form. If the file is modified, we use the top level form offset
;;; instead of the recorded character offset.
(defun get-file-toplevel-form (location)
  (let* ((d-source (code-location-debug-source location))
         (di (compiled-debug-fun-debug-info
              (code-location-debug-fun location)))
         (tlf-offset (sb!c::compiled-debug-info-tlf-number di))
         (char-offset (sb!c::compiled-debug-info-char-offset di))
         (namestring (debug-source-namestring d-source)))
    ;; FIXME: External format?
    (with-open-file (f namestring :if-does-not-exist nil)
      (when f
        (let ((*readtable* (safe-readtable)))
          (cond ((eql (debug-source-created d-source) (file-write-date f))
                 (file-position f char-offset))
                (t
                 (format *debug-io*
                         "~%; File has been modified since compilation:~%;   ~A~@
                          ; Using form offset instead of character position.~%"
                         namestring)
                 (let ((*read-suppress* t))
                   (loop repeat tlf-offset
                         do (read f)))))
          (read f))))))
\f
;;;; PREPROCESS-FOR-EVAL

;;; Return a function of one argument that evaluates form in the
;;; lexical context of the BASIC-CODE-LOCATION LOC, or signal a
;;; NO-DEBUG-VARS condition when the LOC's DEBUG-FUN has no
;;; DEBUG-VAR information available.
;;;
;;; The returned function takes the frame to get values from as its
;;; argument, and it returns the values of FORM. The returned function
;;; can signal the following conditions: INVALID-VALUE,
;;; AMBIGUOUS-VAR-NAME, and FRAME-FUN-MISMATCH.
(defun preprocess-for-eval (form loc)
  (declare (type code-location loc))
  (let ((n-frame (gensym))
        (fun (code-location-debug-fun loc))
        (more-context nil)
        (more-count nil))
    (unless (debug-var-info-available fun)
      (debug-signal 'no-debug-vars :debug-fun fun))
    (sb!int:collect ((binds)
                     (specs))
      (do-debug-fun-vars (var fun)
        (let ((validity (debug-var-validity var loc)))
          (unless (eq validity :invalid)
            (case (debug-var-info var)
              (:more-context
               (setf more-context var))
              (:more-count
               (setf more-count var))
              (t
               (let* ((sym (debug-var-symbol var))
                      (found (assoc sym (binds))))
                 (cond ((not sym))
                       (found
                        (setf (second found) :ambiguous))
                       (t
                        (binds (list sym validity var))))))))))
      (when (and more-context more-count)
        (let ((more (assoc 'sb!debug::more (binds))))
          (if more
              (setf (second more) :ambiguous)
              (binds (list 'sb!debug::more :more more-context more-count)))))
      (dolist (bind (binds))
        (let ((name (first bind))
              (var (third bind)))
          (unless (eq (info :variable :kind name) :special)
            (ecase (second bind)
              (:valid
               (specs `(,name (debug-var-value ',var ,n-frame))))
              (:more
               (let ((count-var (fourth bind)))
                 (specs `(,name (multiple-value-list
                                 (sb!c:%more-arg-values (debug-var-value ',var ,n-frame)
                                                        0
                                                        (debug-var-value ',count-var ,n-frame)))))))
              (:unknown
               (specs `(,name (debug-signal 'invalid-value
                                            :debug-var ',var
                                            :frame ,n-frame))))
              (:ambiguous
               (specs `(,name (debug-signal 'ambiguous-var-name
                                            :name ',name
                                            :frame ,n-frame))))))))
      ;; Process the symbol macros outside of the function to avoid
      ;; all those symbol-macrolets from showing in the sources if
      ;; there is a problem evaluating this form
      (let ((res (let ((sb!c:*lexenv* (make-null-lexenv)))
                   (sb!c::funcall-in-symbol-macrolet-lexenv
                    (specs)
                    (lambda (&optional vars)
                      (declare (ignore vars))
                      (eval-in-lexenv `(lambda (,n-frame)
                                         (declare (ignorable ,n-frame))
                                         (progn ,form))
                                      sb!c:*lexenv*))
                    :eval))))
        (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))))))

;;; EVAL-IN-FRAME

(defun eval-in-frame (frame form)
  (declare (type frame frame))
  "Evaluate FORM in the lexical context of FRAME's current code location,
   returning the results of the evaluation."
  (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
\f
;;;; breakpoints

;;;; user-visible interface

;;; Create and return a breakpoint. When program execution encounters
;;; the breakpoint, the system calls HOOK-FUN. HOOK-FUN takes the
;;; current frame for the function in which the program is running and
;;; the breakpoint object.
;;;
;;; WHAT and KIND determine where in a function the system invokes
;;; HOOK-FUN. WHAT is either a code-location or a DEBUG-FUN. KIND is
;;; one of :CODE-LOCATION, :FUN-START, or :FUN-END. Since the starts
;;; and ends of functions may not have code-locations representing
;;; them, designate these places by supplying WHAT as a DEBUG-FUN and
;;; KIND indicating the :FUN-START or :FUN-END. When WHAT is a
;;; DEBUG-FUN and kind is :FUN-END, then HOOK-FUN must take two
;;; additional arguments, a list of values returned by the function
;;; and a FUN-END-COOKIE.
;;;
;;; INFO is information supplied by and used by the user.
;;;
;;; FUN-END-COOKIE is a function. To implement :FUN-END
;;; breakpoints, the system uses starter breakpoints to establish the
;;; :FUN-END breakpoint for each invocation of the function. Upon
;;; each entry, the system creates a unique cookie to identify the
;;; invocation, and when the user supplies a function for this
;;; argument, the system invokes it on the frame and the cookie. The
;;; system later invokes the :FUN-END breakpoint hook on the same
;;; cookie. The user may save the cookie for comparison in the hook
;;; function.
;;;
;;; Signal an error if WHAT is an unknown code-location.
(defun make-breakpoint (hook-fun what
                        &key (kind :code-location) info fun-end-cookie)
  (etypecase what
    (code-location
     (when (code-location-unknown-p what)
       (error "cannot make a breakpoint at an unknown code location: ~S"
              what))
     (aver (eq kind :code-location))
     (let ((bpt (%make-breakpoint hook-fun what kind info)))
       (etypecase what
         (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.)
         )
       bpt))
    (compiled-debug-fun
     (ecase kind
       (:fun-start
        (%make-breakpoint hook-fun what kind info))
       (:fun-end
        (unless (eq (sb!c::compiled-debug-fun-returns
                     (compiled-debug-fun-compiler-debug-fun what))
                    :standard)
          (error ":FUN-END breakpoints are currently unsupported ~
                  for the known return convention."))

        (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))))))

;;; These are unique objects created upon entry into a function by a
;;; :FUN-END breakpoint's starter hook. These are only created
;;; when users supply :FUN-END-COOKIE to MAKE-BREAKPOINT. Also,
;;; the :FUN-END breakpoint's hook is called on the same cookie
;;; when it is created.
(defstruct (fun-end-cookie
            (:print-object (lambda (obj str)
                             (print-unreadable-object (obj str :type t))))
            (:constructor make-fun-end-cookie (bogus-lra debug-fun))
            (:copier nil))
  ;; a pointer to the bogus-lra created for :FUN-END breakpoints
  (bogus-lra nil :read-only t)
  ;; the DEBUG-FUN associated with this cookie
  (debug-fun nil :read-only t))

;;; 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 :synchronized t))

;;; This returns a hook function for the start helper breakpoint
;;; associated with a :FUN-END breakpoint. The returned function
;;; makes a fake LRA that all returns go through, and this piece of
;;; fake code actually breaks. Upon return from the break, the code
;;; provides the returnee with any values. Since the returned function
;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
;;; function, we must establish breakpoint-data about FUN-END-BPT.
(defun fun-end-starter-hook (starter-bpt debug-fun)
  (declare (type breakpoint starter-bpt)
           (type compiled-debug-fun debug-fun))
  (lambda (frame breakpoint)
    (declare (ignore breakpoint)
             (type frame frame))
    (let ((lra-sc-offset
            #!-fp-and-pc-standard-save
            (sb!c::compiled-debug-fun-return-pc
             (compiled-debug-fun-compiler-debug-fun debug-fun))
            #!+fp-and-pc-standard-save
            sb!c:return-pc-passing-offset))
      (multiple-value-bind (lra component offset)
          (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))))))))))

;;; This takes a FUN-END-COOKIE and a frame, and it returns
;;; whether the cookie is still valid. A cookie becomes invalid when
;;; the frame that established the cookie has exited. Sometimes cookie
;;; holders are unaware of cookie invalidation because their
;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
;;;
;;; This takes a frame as an efficiency hack since the user probably
;;; has a frame object in hand when using this routine, and it saves
;;; repeated parsing of the stack and consing when asking whether a
;;; series of cookies is valid.
(defun fun-end-cookie-valid-p (frame cookie)
  (let ((lra (fun-end-cookie-bogus-lra cookie))
        (lra-sc-offset
          #!-fp-and-pc-standard-save
          (sb!c::compiled-debug-fun-return-pc
           (compiled-debug-fun-compiler-debug-fun
            (fun-end-cookie-debug-fun cookie)))
          #!+fp-and-pc-standard-save
          sb!c:return-pc-passing-offset))
    (do ((frame frame (frame-down frame)))
        ((not frame) nil)
      (when (and (compiled-frame-p frame)
                 (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap=
                  lra
                  (get-context-value frame lra-save-offset lra-sc-offset)))
        (return t)))))
\f
;;;; ACTIVATE-BREAKPOINT

;;; Cause the system to invoke the breakpoint's hook function until
;;; the next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The
;;; system invokes breakpoint hook functions in the opposite order
;;; that you activate them.
(defun activate-breakpoint (breakpoint)
  (when (eq (breakpoint-status breakpoint) :deleted)
    (error "cannot activate a deleted breakpoint: ~S" breakpoint))
  (unless (eq (breakpoint-status breakpoint) :active)
    (ecase (breakpoint-kind breakpoint)
      (:code-location
       (let ((loc (breakpoint-what breakpoint)))
         (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.)
           )))
      (:fun-start
       (etypecase (breakpoint-what breakpoint)
         (compiled-debug-fun
          (activate-compiled-fun-start-breakpoint breakpoint))
         ;; (There used to be more cases back before sbcl-0.7.0, when
         ;; we did special tricks to debug the IR1 interpreter.)
         ))
      (:fun-end
       (etypecase (breakpoint-what breakpoint)
         (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.)
         ))))
  breakpoint)

(defun activate-compiled-code-location-breakpoint (breakpoint)
  (declare (type breakpoint breakpoint))
  (let ((loc (breakpoint-what breakpoint)))
    (declare (type compiled-code-location loc))
    (sub-activate-breakpoint
     breakpoint
     (breakpoint-data (compiled-debug-fun-component
                       (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))))))

(defun activate-compiled-fun-start-breakpoint (breakpoint)
  (declare (type breakpoint breakpoint))
  (let ((debug-fun (breakpoint-what breakpoint)))
    (sub-activate-breakpoint
     breakpoint
     (breakpoint-data (compiled-debug-fun-component debug-fun)
                      (sb!c::compiled-debug-fun-start-pc
                       (compiled-debug-fun-compiler-debug-fun
                        debug-fun))))))

(defun sub-activate-breakpoint (breakpoint data)
  (declare (type breakpoint breakpoint)
           (type breakpoint-data data))
  (setf (breakpoint-status breakpoint) :active)
  (without-interrupts
   (unless (breakpoint-data-breakpoints data)
     (setf (breakpoint-data-instruction data)
           (without-gcing
            (breakpoint-install (get-lisp-obj-address
                                 (breakpoint-data-component data))
                                (breakpoint-data-offset data)))))
   (setf (breakpoint-data-breakpoints data)
         (append (breakpoint-data-breakpoints data) (list breakpoint)))
   (setf (breakpoint-internal-data breakpoint) data)))
\f
;;;; DEACTIVATE-BREAKPOINT

;;; Stop the system from invoking the breakpoint's hook function.
(defun deactivate-breakpoint (breakpoint)
  (when (eq (breakpoint-status breakpoint) :active)
    (without-interrupts
     (let ((loc (breakpoint-what breakpoint)))
       (etypecase loc
         ((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.)
         ))))
  breakpoint)

(defun deactivate-compiled-breakpoint (breakpoint)
  (if (eq (breakpoint-kind breakpoint) :fun-end)
      (let ((starter (breakpoint-start-helper breakpoint)))
        (unless (find-if (lambda (bpt)
                           (and (not (eq bpt breakpoint))
                                (eq (breakpoint-status bpt) :active)))
                         (breakpoint-%info starter))
          (deactivate-compiled-breakpoint starter)))
      (let* ((data (breakpoint-internal-data breakpoint))
             (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))))
  (setf (breakpoint-status breakpoint) :inactive)
  breakpoint)
\f
;;;; BREAKPOINT-INFO

;;; Return the user-maintained info associated with breakpoint. This
;;; is SETF'able.
(defun breakpoint-info (breakpoint)
  (breakpoint-%info breakpoint))
(defun %set-breakpoint-info (breakpoint value)
  (setf (breakpoint-%info breakpoint) value)
  (let ((other (breakpoint-unknown-return-partner breakpoint)))
    (when other
      (setf (breakpoint-%info other) value))))
\f
;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT

(defun breakpoint-active-p (breakpoint)
  (ecase (breakpoint-status breakpoint)
    (:active t)
    ((:inactive :deleted) nil)))

;;; Free system storage and remove computational overhead associated
;;; with breakpoint. After calling this, breakpoint is completely
;;; impotent and can never become active again.
(defun delete-breakpoint (breakpoint)
  (let ((status (breakpoint-status breakpoint)))
    (unless (eq status :deleted)
      (when (eq status :active)
        (deactivate-breakpoint breakpoint))
      (setf (breakpoint-status breakpoint) :deleted)
      (let ((other (breakpoint-unknown-return-partner breakpoint)))
        (when other
          (setf (breakpoint-status other) :deleted)))
      (when (eq (breakpoint-kind breakpoint) :fun-end)
        (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))))))
  breakpoint)
\f
;;;; C call out stubs

;;; This actually installs the break instruction in the component. It
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int
  (code-obj sb!alien:unsigned)
  (pc-offset sb!alien:int))

;;; This removes the break instruction and replaces the original
;;; instruction. You must call this in a context in which GC is disabled
;;; so Lisp doesn't move objects around that C is pointing to.
(sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
  (code-obj sb!alien:unsigned)
  (pc-offset sb!alien:int)
  (old-inst sb!alien:unsigned-int))

(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
  (scp (* os-context-t))
  (orig-inst sb!alien:unsigned-int))

;;;; 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 :synchronized t))

;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
  (flet ((install-breakpoint-data ()
           (when create
             (let ((data (make-breakpoint-data component offset)))
               (push (cons offset data)
                     (gethash component *component-breakpoint-offsets*))
               data))))
    (let ((offsets (gethash component *component-breakpoint-offsets*)))
      (if offsets
          (let ((data (assoc offset offsets)))
            (if data
                (cdr data)
                (install-breakpoint-data)))
          (install-breakpoint-data)))))

;;; 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*)
                          :key #'car)))
    (if offsets
        (setf (gethash component *component-breakpoint-offsets*) offsets)
        (remhash component *component-breakpoint-offsets*)))
  (values))

;;; The C handler for interrupts calls this when it has a
;;; debugging-tool break instruction. This does *not* handle all
;;; breaks; for example, it does not handle breaks for internal
;;; errors.
(defun handle-breakpoint (offset component signal-context)
  (let ((data (breakpoint-data component offset nil)))
    (unless data
      (error "unknown breakpoint in ~S at offset ~S"
              (debug-fun-name (debug-fun-from-pc component offset))
              offset))
    (let ((breakpoints (breakpoint-data-breakpoints data)))
      (if (or (null breakpoints)
              (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)))))

;;; This holds breakpoint-datas while invoking the breakpoint hooks
;;; associated with that particular component and location. While they
;;; are executing, if we hit the location again, we ignore the
;;; breakpoint to avoid infinite recursion. fun-end breakpoints
;;; must work differently since the breakpoint-data is unique for each
;;; invocation.
(defvar *executing-breakpoint-hooks* nil)

;;; This handles code-location and DEBUG-FUN :FUN-START
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
  (unless breakpoints
    (bug "breakpoint that nobody wants"))
  (unless (member data *executing-breakpoint-hooks*)
    (let ((*executing-breakpoint-hooks* (cons data
                                              *executing-breakpoint-hooks*)))
      (invoke-breakpoint-hooks breakpoints signal-context)))
  ;; At this point breakpoints may not hold the same list as
  ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
  ;; a breakpoint deactivation. In fact, if all breakpoints were
  ;; deactivated then data is invalid since it was deleted and so the
  ;; correct one must be looked up if it is to be used. If there are
  ;; no more breakpoints active at this location, then the normal
  ;; instruction has been put back, and we do not need to
  ;; DO-DISPLACED-INST.
  (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)))
    (dolist (bpt breakpoints)
      (funcall (breakpoint-hook-fun 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
                           ;; KLUDGE: This argument is ignored on
                           ;; x86oids in this scenario, but is
                           ;; declared to be a SAP.
                           #!+(or x86 x86-64) (sb!vm:context-pc scp)
                           #!-(or x86 x86-64) nil
                           nil)))

(defun handle-fun-end-breakpoint (offset component context)
  (let ((data (breakpoint-data component offset nil)))
    (unless data
      (error "unknown breakpoint in ~S at offset ~S"
              (debug-fun-name (debug-fun-from-pc component offset))
              offset))
    (let ((breakpoints (breakpoint-data-breakpoints data)))
      (when breakpoints
        (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
        (handle-fun-end-breakpoint-aux breakpoints data context)))))

;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
;;; [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
            (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*)))
    (remhash component *fun-end-cookies*)
    (dolist (bpt breakpoints)
      (funcall (breakpoint-hook-fun bpt)
               frame bpt
               (get-fun-end-breakpoint-values scp)
               cookie))))

(defun get-fun-end-breakpoint-values (scp)
  (let ((ocfp (int-sap (sb!vm:context-register
                        scp
                        #!-(or x86 x86-64) sb!vm::ocfp-offset
                        #!+(or x86 x86-64) sb!vm::ebx-offset)))
        (nargs (make-lisp-obj
                (sb!vm:context-register scp sb!vm::nargs-offset)))
        (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
        (results nil))
    (without-gcing
      (dotimes (arg-num nargs)
        (push (if reg-arg-offsets
                  (make-lisp-obj
                   (sb!vm:context-register scp (pop reg-arg-offsets)))
                  (stack-ref ocfp (+ arg-num
                                     #!+(or x86 x86-64) sb!vm::sp->fp-offset)))
              results)))
    (nreverse results)))
\f
;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)

(defconstant bogus-lra-constants
  #!-(or x86-64 x86) 1
  #!+x86-64 2
  ;; One more for a fixup vector
  #!+x86 3)

;;; Make a bogus LRA object that signals a breakpoint trap when
;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
;;; returned to. Three values are returned: the bogus LRA object, the
;;; code component it is part of, and the PC offset for the trap
;;; instruction.
(defun make-bogus-lra (real-lra)
  (without-gcing
    ;; These are really code labels, not variables: but this way we get
    ;; their addresses.
    (let* ((src-start (static-foreign-symbol-sap "fun_end_breakpoint_guts"))
           (src-end (static-foreign-symbol-sap "fun_end_breakpoint_end"))
           (trap-loc (static-foreign-symbol-sap "fun_end_breakpoint_trap"))
           (length (sap- src-end src-start))
           (code-object
             (sb!c:allocate-code-object #!+immobile-code nil
                                        bogus-lra-constants length))
           (dst-start (code-instructions code-object)))
      (declare (type system-area-pointer
                     src-start src-end dst-start trap-loc)
               (type index length))
      (setf (%code-debug-info code-object) :bogus-lra)
      #!-(or x86 x86-64)
      (setf (code-header-ref code-object real-lra-slot) real-lra
            ;; Set up the widetag and header of LRA
            ;; The header contains the same thing as the code object header,
            ;; the number of boxed words, which include slots and
            ;; constants and it has to be double word aligned.
            ;;
            ;; It used to be a part of the fun_end_breakpoint_guts
            ;; but its position and value depend on the offsets
            ;; and alignment of code object slots.
            (sap-ref-word dst-start (- sb!vm:n-word-bits))
            (+ sb!vm:return-pc-widetag
               (logandc2 (+ code-constants-offset
                            bogus-lra-constants
                            2)
                         3)))
      #!+(or x86 x86-64)
      (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
        (setf (code-header-ref code-object real-lra-slot) code)
        (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
      (system-area-ub8-copy src-start 0 dst-start 0 length)
      #!-(or x86 x86-64)
      (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)
                                       sb!vm:other-pointer-lowtag))))
        ;; We used to set the header value of the LRA here to the
        ;; offset from the enclosing component to the LRA header, but
        ;; MAKE-LISP-OBJ actually checks the value before we get a
        ;; chance to set it, so it's now done in arch-assem.S.
        (values new-lra code-object (sap- trap-loc src-start))))))
\f
;;;; miscellaneous

;;; This appears here because it cannot go with the DEBUG-FUN
;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
;;; the DEBUG-FUN routines.

;;; Return a code-location before the body of a function and after all
;;; the arguments are in place; or if that location can't be
;;; determined due to a lack of debug information, return NIL.
(defun debug-fun-start-location (debug-fun)
  (etypecase debug-fun
    (compiled-debug-fun
     (code-location-from-pc debug-fun
                            (sb!c::compiled-debug-fun-start-pc
                             (compiled-debug-fun-compiler-debug-fun
                              debug-fun))
                            nil))
    ;; (There used to be more cases back before sbcl-0.7.0, when
    ;; we did special tricks to debug the IR1 interpreter.)
    ))

\f
;;;; Single-stepping

;;; The single-stepper works by inserting conditional trap instructions
;;; into the generated code (see src/compiler/*/call.lisp), currently:
;;;
;;;   1) Before the code generated for a function call that was
;;;      translated to a VOP
;;;   2) Just before the call instruction for a full call
;;;
;;; In both cases, the trap will only be executed if stepping has been
;;; enabled, in which case it'll ultimately be handled by
;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition,
;;; or replace the function that's about to be called with a wrapper
;;; which will signal the condition.

(defun handle-single-step-trap (kind callee-register-offset)
  (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*))))
    ;; The following calls must get tail-call eliminated for
    ;; *STEP-FRAME* to get set correctly on non-x86.
    (if (= kind single-step-before-trap)
        (handle-single-step-before-trap context)
        (handle-single-step-around-trap context callee-register-offset))))

(defvar *step-frame* nil)

(defun handle-single-step-before-trap (context)
  (let ((step-info (single-step-info-from-context context)))
    ;; If there was not enough debug information available, there's no
    ;; sense in signaling the condition.
    (when step-info
      (let ((*step-frame*
             #!+(or x86 x86-64)
             (signal-context-frame (sb!alien::alien-sap context))
             #!-(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
             ;; SIGNAL-CONTEXT-FRAME doesn't seem seem to work at all
             ;; on non-x86.
             (loop with frame = (frame-down (top-frame))
                   while frame
                   for dfun = (frame-debug-fun frame)
                   do (when (typep dfun 'compiled-debug-fun)
                        (return frame))
                   do (setf frame (frame-down frame)))))
        (sb!impl::step-form step-info
                            ;; We could theoretically store information in
                            ;; the debug-info about to determine the
                            ;; arguments here, but for now let's just pass
                            ;; on it.
                            :unknown)))))

;;; This function will replace the fdefn / function that was in the
;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
;;; ensure that the full call will use the wrapper instead of the
;;; original, conditional trap must be emitted before the fdefn /
;;; function is converted into a raw address.
(defun handle-single-step-around-trap (context callee-register-offset)
  ;; Fetch the function / fdefn we're about to call from the
  ;; appropriate register.
  (let* ((callee
          (cond #!+immobile-space
                ((eql (sap-ref-8 (context-pc context) 0) #xB8) ; MOV EAX,imm
                 ;; FIXME: this ought to go in {target}-vm.lisp as
                 ;; something like GET-FDEFN-FOR-SINGLE-STEP
                 (let ((jmp-target (sap-ref-32 (context-pc context) 1)))
                   (make-lisp-obj
                    (+ jmp-target (- (ash word-shift fdefn-raw-addr-slot))
                       other-pointer-lowtag))))
                (t (make-lisp-obj
                    (context-register context callee-register-offset)))))
         (step-info (single-step-info-from-context context)))
    ;; If there was not enough debug information available, there's no
    ;; sense in signaling the condition.
    (unless step-info
      (return-from handle-single-step-around-trap))
    (let* ((fun (lambda (&rest args)
                  (flet ((call ()
                           (apply (typecase callee
                                    (fdefn (fdefn-fun callee))
                                    (function callee))
                                  args)))
                    ;; Signal a step condition
                    (let* ((step-in
                             (let ((*step-frame* (frame-down (top-frame))))
                               (sb!impl::step-form step-info args))))
                      ;; And proceed based on its return value.
                      (if step-in
                          ;; STEP-INTO was selected. Use *STEP-OUT* to
                          ;; let the stepper know that selecting the
                          ;; STEP-OUT restart is valid inside this
                          (let ((sb!impl::*step-out* :maybe))
                            ;; Pass the return values of the call to
                            ;; STEP-VALUES, which will signal a
                            ;; condition with them in the VALUES slot.
                            (unwind-protect
                                 (multiple-value-call #'sb!impl::step-values
                                   step-info
                                   (call))
                              ;; If the user selected the STEP-OUT
                              ;; restart during the call, resume
                              ;; stepping
                              (when (eq sb!impl::*step-out* t)
                                (sb!impl::enable-stepping))))
                          ;; STEP-NEXT / CONTINUE / OUT selected:
                          ;; Disable the stepper for the duration of
                          ;; the call.
                          (sb!impl::with-stepping-disabled
                            (call)))))))
           (new-callee (etypecase callee
                         (fdefn
                          (let ((fdefn (make-fdefn (gensym))))
                            (setf (fdefn-fun fdefn) fun)
                            fdefn))
                         (function fun))))
      ;; And then store the wrapper in the same place.
      (with-pinned-objects (new-callee)
        ;; %SET-CONTEXT-REGISTER is a function, so the address of
        ;; NEW-CALLEE gets converted to a fixnum before passing, which
        ;; won't keep NEW-CALLEE pinned down. Once it's inside
        ;; CONTEXT, which is registered in thread->interrupt_contexts,
        ;; it will properly point to NEW-CALLEE.
        (cond
         #!+immobile-code
         ((fdefn-p callee) ; as above, should be in {target}-vm.lisp
          ;; Don't store the FDEFN in RAX, but the address of the raw_addr slot.
          (setf (context-register context callee-register-offset)
                (+ (get-lisp-obj-address new-callee)
                   (- other-pointer-lowtag)
                   (ash word-shift fdefn-raw-addr-slot)))
          ;; And skip over the MOV EAX, imm instruction.
          (sb!vm::incf-context-pc context 5))
         (t
          (setf (context-register context callee-register-offset)
                (get-lisp-obj-address new-callee))))))))

;;; Given a signal context, fetch the step-info that's been stored in
;;; the debug info at the trap point.
(defun single-step-info-from-context (context)
  (multiple-value-bind (pc-offset code)
      (compute-lra-data-from-pc (context-pc context))
    (let* ((debug-fun (debug-fun-from-pc code pc-offset))
           (location (code-location-from-pc debug-fun
                                            pc-offset
                                            nil)))
      (handler-case
          (progn
            (fill-in-code-location location)
            (code-location-debug-source location)
            (compiled-code-location-step-info location))
        (debug-condition ()
          nil)))))

;;; Return the frame that triggered a single-step condition. Used to
;;; provide a *STACK-TOP-HINT*.
(defun find-stepped-frame ()
  (or *step-frame*
      (top-frame)))

;;;; fetching errorful function name

;;; This flag is used to prevent infinite recursive lossage when
;;; we can't find the caller for some reason.
(defvar *finding-frame* nil)

(defun find-caller-frame ()
  (unless *finding-frame*
    (handler-case
        (let* ((*finding-frame* t)
               (frame (frame-down (frame-down (top-frame)))))
          (flush-frames-above frame)
          frame)
      ((or error debug-condition) ()))))

(defun find-interrupted-frame ()
  (when (plusp *free-interrupt-context-index*)
    (handler-case
        (signal-context-frame
         (sb!alien:alien-sap
          (nth-interrupt-context (1- *free-interrupt-context-index*))))
      ((or error debug-condition) ()))))

(defun find-caller-of-named-frame (name)
  (unless *finding-frame*
    (handler-case
        (let ((*finding-frame* t))
          (do ((frame (top-frame) (frame-down frame)))
              ((null frame))
            (when (and (compiled-frame-p frame)
                       (eq name (debug-fun-name
                                 (frame-debug-fun frame))))
              (let ((caller (frame-down frame)))
                (flush-frames-above caller)
                (return caller)))))
      ((or error debug-condition) ()))))