0.8.13.10: I don't think we're in lisp-land anymore...

[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)
  ()
  #!+sb-doc
  (: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-info (debug-condition)
  ((code-component :reader no-debug-info-code-component
                   :initarg :code-component))
  #!+sb-doc
  (:documentation "There is no usable debugging information available.")
  (:report (lambda (condition stream)
             (fresh-line stream)
             (format stream
                     "no debug information available for ~S~%"
                     (no-debug-info-code-component condition)))))

(define-condition no-debug-fun-returns (debug-condition)
  ((debug-fun :reader no-debug-fun-returns-debug-fun
              :initarg :debug-fun))
  #!+sb-doc
  (: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))
  #!+sb-doc
  (: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))
  #!+sb-doc
  (: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))
  #!+sb-doc
  (: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) ()
  #!+sb-doc
  (: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)
  ;; Does the variable always have a valid value?
  (alive-p nil :type boolean))
(def!method 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))))

#!+sb-doc
(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))
            (:copier nil))
  ;; storage class and offset (unexported)
  (sc-offset nil :type sb!c:sc-offset)
  ;; storage class and offset when saved somewhere
  (save-sc-offset nil :type (or sb!c:sc-offset null)))

;;;; 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)
  ;; 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)
  ;; an a-list of catch-tags to code-locations
  (%catches :unparsed :type (or list (member :unparsed)))
  ;; pointer to frame on control stack (unexported)
  pointer
  ;; 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)
(def!method 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
;;;; 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))))
(def!method print-object ((obj debug-fun) stream)
  (print-unreadable-object (obj stream :type t)
    (prin1 (debug-fun-name obj) stream)))

(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)
  ;; code object (unexported).
  component
  ;; the :FUN-START breakpoint (if any) used to facilitate
  ;; function end breakpoints
  (end-starter nil :type (or null breakpoint)))

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

;;; 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*.
(defun make-compiled-debug-fun (compiler-debug-fun component)
  (or (gethash compiler-debug-fun *compiled-debug-funs*)
      (setf (gethash compiler-debug-fun *compiled-debug-funs*)
            (%make-compiled-debug-fun compiler-debug-fun component))))

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

(defvar *ir1-lambda-debug-fun* (make-hash-table :test 'eq))
\f
;;;; DEBUG-BLOCKs

;;; These exist for caching data stored in packed binary form in compiler
;;; DEBUG-BLOCKs.
(defstruct (debug-block (:constructor nil)
                        (:copier nil))
  ;; Code-locations where execution continues after this block.
  (successors nil :type list)
  ;; 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))
(def!method print-object ((obj debug-block) str)
  (print-unreadable-object (obj str :type t)
    (prin1 (debug-block-fun-name obj) str)))

#!+sb-doc
(setf (fdocumentation 'debug-block-successors 'function)
  "Return the list of possible code-locations where execution may continue
   when the basic-block represented by debug-block completes its execution.")

#!+sb-doc
(setf (fdocumentation 'debug-block-elsewhere-p 'function)
  "Return whether debug-block represents elsewhere code.")

(defstruct (compiled-debug-block (:include debug-block)
                                 (:constructor
                                  make-compiled-debug-block
                                  (code-locations successors elsewhere-p))
                                 (:copier nil))
  ;; code-location information for the block
  (code-locations nil :type simple-vector))

(defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
\f
;;;; breakpoints

;;; This 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
  ;; This is the byte offset into the component.
  (offset nil :type index)
  ;; The original instruction replaced by the breakpoint.
  (instruction nil :type (or null (unsigned-byte 32)))
  ;; A list of user breakpoints at this location.
  (breakpoints nil :type list))
(def!method 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))
  ;; :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))
  ;; 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)
(def!method 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)))))))
\f
;;;; CODE-LOCATIONs

(defstruct (code-location (:constructor nil)
                          (:copier nil))
  ;; the DEBUG-FUN containing this CODE-LOCATION
  (debug-fun nil :type debug-fun)
  ;; 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 number of forms processed by the compiler or loader
  ;; before the top level form containing this code-location.
  (%tlf-offset :unparsed :type (or index (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))))
(def!method 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 %tlf-offset %form-number
                              %live-set kind &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)
  ;; 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:TYPE-EXPAND 'SB!C::LOCATION-KIND).
  (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)))
\f
;;;; DEBUG-SOURCEs

;;; Return the number of top level forms processed by the compiler
;;; before compiling this source. If this source is uncompiled, this
;;; is zero. This may be zero even if the source is compiled since the
;;; first form in the first file compiled in one compilation, for
;;; example, must have a root number of zero -- the compiler saw no
;;; other top level forms before it.
(defun debug-source-root-number (debug-source)
  (sb!c::debug-source-source-root debug-source))
\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 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)
  (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)
         (zerop (logand (sap-int x) #b11)))
    #!+stack-grows-downward-not-upward
    (and (sap>= x (current-sp))
         (sap> control-stack-end x)
         (zerop (logand (sap-int x) #b11)))))

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

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

;;;; X86 support

#!+x86
(progn

(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 (* (get-header-data code) sb!vm:n-word-bytes))
              (pc-offset (- (sap-int pc)
                            (- (get-lisp-obj-address code)
                               sb!vm:other-pointer-lowtag)
                            code-header-len)))
;        (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
         (values pc-offset code)))))

(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.
(defun x86-call-context (fp &key (depth 0))
  (declare (type system-area-pointer fp)
           (fixnum depth))
  ;;(format t "*CC ~S ~S~%" fp depth)
  (cond
   ((not (control-stack-pointer-valid-p fp))
    #+nil (format t "debug invalid fp ~S~%" fp)
    nil)
   (t
    ;; Check the two possible frame pointers.
    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) 4))))
          (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset)
                                         4))))
          (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes)))
          (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes))))
      (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
                  (ra-pointer-valid-p lisp-ra)
                  (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
                  (ra-pointer-valid-p c-ra))
             #+nil (format t
                           "*C Both valid ~S ~S ~S ~S~%"
                           lisp-ocfp lisp-ra c-ocfp c-ra)
             ;; Look forward another step to check their validity.
             (let ((lisp-path-fp (x86-call-context lisp-ocfp
                                                   :depth (1+ depth)))
                   (c-path-fp (x86-call-context c-ocfp :depth (1+ depth))))
               (cond ((and lisp-path-fp c-path-fp)
                       ;; Both still seem valid - choose the lisp frame.
                       #+nil (when (zerop depth)
                               (format t
                                       "debug: both still valid ~S ~S ~S ~S~%"
                                       lisp-ocfp lisp-ra c-ocfp c-ra))
                      #!+freebsd
                      (if (sap> lisp-ocfp c-ocfp)
                        (values lisp-ra lisp-ocfp)
                        (values c-ra c-ocfp))
                       #!-freebsd
                       (values lisp-ra lisp-ocfp))
                     (lisp-path-fp
                      ;; The lisp convention is looking good.
                      #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
                      (values lisp-ra lisp-ocfp))
                     (c-path-fp
                      ;; The C convention is looking good.
                      #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
                      (values c-ra c-ocfp))
                     (t
                      ;; Neither seems right?
                      #+nil (format t "debug: no valid2 fp found ~S ~S~%"
                                    lisp-ocfp c-ocfp)
                      nil))))
            ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp)
                  (ra-pointer-valid-p lisp-ra))
             ;; The lisp convention is looking good.
             #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
             (values lisp-ra lisp-ocfp))
            ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp)
                  #!-linux (ra-pointer-valid-p c-ra))
             ;; The C convention is looking good.
             #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
             (values c-ra c-ocfp))
            (t
             #+nil (format t "debug: no valid fp found ~S ~S~%"
                           lisp-ocfp c-ocfp)
             nil))))))

) ; #+x86 PROGN
\f
;;; Convert the descriptor into a SAP. The bits all stay the same, we just
;;; change our notion of what we think they are.
#!-sb-fluid (declaim (inline descriptor-sap))
(defun descriptor-sap (x)
  (int-sap (get-lisp-obj-address x)))

;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
  (/noshow0 "entering TOP-FRAME")
  (multiple-value-bind (fp pc) (%caller-frame-and-pc)
    (compute-calling-frame (descriptor-sap fp) pc nil)))

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

;;; 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 ((c-d-f (compiled-debug-fun-compiler-debug-fun
                                 debug-fun)))
                     (compute-calling-frame
                      (descriptor-sap
                       (get-context-value
                        frame ocfp-save-offset
                        (sb!c::compiled-debug-fun-old-fp c-d-f)))
                      (get-context-value
                       frame lra-save-offset
                       (sb!c::compiled-debug-fun-return-pc c-d-f))
                      frame)))
                  (bogus-debug-fun
                   (let ((fp (frame-pointer frame)))
                     (when (control-stack-pointer-valid-p fp)
                       #!+x86
                        (multiple-value-bind (ra ofp) (x86-call-context fp)
                         (and ra (compute-calling-frame ofp ra frame)))
                        #!-x86
                       (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.
#!-x86
(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)
        (stack-ref pointer stack-slot))))
#!+x86
(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)
        (ecase stack-slot
          (#.ocfp-save-offset
           (stack-ref pointer stack-slot))
          (#.lra-save-offset
           (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))

#!-x86
(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)
        (setf (stack-ref pointer stack-slot) value))))

#!+x86
(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)
        (ecase stack-slot
          (#.ocfp-save-offset
           (setf (stack-ref pointer stack-slot) value))
          (#.lra-save-offset
           (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))

(defun foreign-function-debug-name (sap)
  (multiple-value-bind (name file base offset) (foreign-symbol-in-address sap)
    (if name
        (format nil "foreign function: ~A [~A: #x~X + #x~X]" name file base offset)
        (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.
#!-x86
(defun compute-calling-frame (caller lra up-frame)
  (declare (type system-area-pointer caller))
  (when (control-stack-pointer-valid-p caller)
    (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 (get-header-data 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-debug-name (int-sap (get-lisp-obj-address lra)))))
                         ((nil)
                          (make-bogus-debug-fun
                           "bogus stack frame"))
                         (t
                          (debug-fun-from-pc code pc-offset)))))
            (make-compiled-frame caller up-frame d-fun
                                 (code-location-from-pc d-fun pc-offset
                                                        escaped)
                                 (if up-frame (1+ (frame-number up-frame)) 0)
                                 escaped))))))
#!+x86
(defun compute-calling-frame (caller ra up-frame)
  (declare (type system-area-pointer caller ra))
  (/noshow0 "entering COMPUTE-CALLING-FRAME")
  (when (control-stack-pointer-valid-p caller)
    (/noshow0 "in WHEN")
    ;; First check for an escaped frame.
    (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
      (/noshow0 "at COND")
      (cond (code
             (/noshow0 "in CODE clause")
             ;; 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)))
            (t
             (/noshow0 "in T clause")
             ;; not escaped
             (multiple-value-setq (pc-offset code)
               (compute-lra-data-from-pc ra))
             (unless code
               (setf code :foreign-function
                     pc-offset 0
                     escaped nil))))

      (let ((d-fun (case code
                     (:undefined-function
                      (make-bogus-debug-fun
                       "undefined function"))
                     (:foreign-function
                      (make-bogus-debug-fun (foreign-function-debug-name ra)))
                     ((nil)
                      (make-bogus-debug-fun
                       "bogus stack frame"))
                     (t
                      (debug-fun-from-pc code pc-offset)))))
        (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
        (make-compiled-frame caller up-frame d-fun
                             (code-location-from-pc d-fun pc-offset
                                                    escaped)
                             (if up-frame (1+ (frame-number up-frame)) 0)
                             escaped)))))

(defun nth-interrupt-context (n)
  (declare (type (unsigned-byte 32) n)
           (optimize (speed 3) (safety 0)))
  (sb!alien:sap-alien (sb!vm::current-thread-offset-sap 
                       (+ sb!vm::thread-interrupt-contexts-offset n))
                      (* os-context-t)))

#!+x86
(defun find-escaped-frame (frame-pointer)
  (declare (type system-area-pointer frame-pointer))
  (/noshow0 "entering FIND-ESCAPED-FRAME")
  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
      (/noshow0 "at head of WITH-ALIEN")
    (let ((context (nth-interrupt-context index)))
        (/noshow0 "got CONTEXT")
        (when (= (sap-int frame-pointer)
                 (sb!vm:context-register context sb!vm::cfp-offset))
          (without-gcing
           (/noshow0 "in WITHOUT-GCING")
           (let* ((component-ptr (component-ptr-from-pc
                                  (sb!vm:context-pc context)))
                  (code (unless (sap= component-ptr (int-sap #x0))
                          (component-from-component-ptr component-ptr))))
             (/noshow0 "got CODE")
             (when (null code)
               (return (values code 0 context)))
             (let* ((code-header-len (* (get-header-data code)
                                        sb!vm:n-word-bytes))
                    (pc-offset
                     (- (sap-int (sb!vm:context-pc context))
                        (- (get-lisp-obj-address code)
                           sb!vm:other-pointer-lowtag)
                        code-header-len)))
               (/noshow "got PC-OFFSET")
               (unless (<= 0 pc-offset
                           (* (code-header-ref code sb!vm:code-code-size-slot)
                              sb!vm:n-word-bytes))
                 ;; We were in an assembly routine. Therefore, use the
                 ;; LRA as the pc.
                 ;;
                 ;; FIXME: Should this be WARN or ERROR or what?
                 (format t "** pc-offset ~S not in code obj ~S?~%"
                         pc-offset code))
               (/noshow0 "returning from FIND-ESCAPED-FRAME")
               (return
               (values code pc-offset context)))))))))

#!-x86
(defun find-escaped-frame (frame-pointer)
  (declare (type system-area-pointer frame-pointer))
  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
    (let ((scp (nth-interrupt-context index)))
      (when (= (sap-int frame-pointer)
               (sb!vm:context-register scp sb!vm::cfp-offset))
        (without-gcing
         (let ((code (code-object-from-bits
                      (sb!vm:context-register scp sb!vm::code-offset))))
           (when (symbolp code)
             (return (values code 0 scp)))
           (let* ((code-header-len (* (get-header-data code)
                                      sb!vm:n-word-bytes))
                  (pc-offset
                   (- (sap-int (sb!vm:context-pc scp))
                      (- (get-lisp-obj-address code)
                         sb!vm:other-pointer-lowtag)
                      code-header-len)))
             ;; Check to see whether we were executing in a branch
             ;; delay slot.
             #!+(or pmax sgi)          ; pmax only (and broken anyway)
             (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
               (incf pc-offset sb!vm:n-word-bytes))
             (let ((code-size (* (code-header-ref code 
                                                  sb!vm:code-code-size-slot)
                                 sb!vm:n-word-bytes)))
               (unless (<= 0 pc-offset code-size)
                 ;; We were in an assembly routine.
                 (multiple-value-bind (new-pc-offset computed-return)
                     (find-pc-from-assembly-fun code scp)
                   (setf pc-offset new-pc-offset)
                   (unless (<= 0 pc-offset code-size)
                     (cerror
                      "Set PC-OFFSET to zero and continue backtrace."
                      'bug
                      :format-control
                      "~@<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-points code)
                            (sb!vm:context-register scp sb!vm::lra-offset)
                            computed-return))
                     ;; We failed to pinpoint where PC is, but set
                     ;; pc-offset to 0 to keep the backtrace from
                     ;; exploding.
                     (setf pc-offset 0)))))
             (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))))))))))

#!-x86
(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
         ;; This conditional logic should probably go into
         ;; architecture specific files somehow.
         #!+ppc (sap-int (sb!vm::context-lr scp))
         #!+sparc (+ (sb!vm:context-register scp sb!vm::lip-offset) 8)
         #!-(or ppc sparc) (- (sb!vm:context-register scp sb!vm::lra-offset)
                              sb!vm:other-pointer-lowtag))
        (code-header-len (* (get-header-data 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.
(defun code-object-from-bits (bits)
  (declare (type (unsigned-byte 32) bits))
  (let ((object (make-lisp-obj bits)))
    (if (functionp object)
        (or (fun-code-header object)
            :undefined-function)
        (let ((lowtag (lowtag-of object)))
          (if (= lowtag sb!vm:other-pointer-lowtag)
              (let ((widetag (widetag-of object)))
                (cond ((= widetag sb!vm:code-header-widetag)
                       object)
                      ((= widetag sb!vm:return-pc-header-widetag)
                       (lra-code-header object))
                      (t
                       nil))))))))
\f
;;;; frame utilities

;;; 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)
  (let ((info (%code-debug-info component)))
    (cond
     ((not info)
      (debug-signal 'no-debug-info :code-component component))
     ((eq info :bogus-lra)
      (make-bogus-debug-fun "function end breakpoint"))
     (t
      (let* ((fun-map (sb!c::compiled-debug-info-fun-map info))
             (len (length fun-map)))
        (declare (type simple-vector fun-map))
        (if (= len 1)
            (make-compiled-debug-fun (svref fun-map 0) component)
            (let ((i 1)
                  (elsewhere-p
                   (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
                           (svref fun-map 0)))))
              (declare (type sb!int:index i))
              (loop
                (when (or (= i len)
                          (< pc (if elsewhere-p
                                    (sb!c::compiled-debug-fun-elsewhere-pc
                                     (svref fun-map (1+ i)))
                                    (svref fun-map i))))
                  (return (make-compiled-debug-fun
                           (svref fun-map (1- i))
                           component)))
                (incf i 2)))))))))

;;; 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-current-cont-slot
                                      sb!vm:n-word-bytes))
                      #!+alpha
                      (int-sap
                       (sap-ref-32 catch
                                   (* sb!vm:catch-block-current-cont-slot
                                      sb!vm:n-word-bytes))))
            (let* (#!-x86
                   (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
                   #!+x86
                   (ra (sap-ref-sap
                        catch (* sb!vm:catch-block-entry-pc-slot
                                 sb!vm:n-word-bytes)))
                   #!-x86
                   (component
                    (stack-ref catch sb!vm:catch-block-current-code-slot))
                   #!+x86
                   (component (component-from-component-ptr
                               (component-ptr-from-pc ra)))
                   (offset
                    #!-x86
                    (* (- (1+ (get-header-data lra))
                          (get-header-data component))
                       sb!vm:n-word-bytes)
                    #!+x86
                    (- (sap-int ra)
                       (- (get-lisp-obj-address component)
                          sb!vm:other-pointer-lowtag)
                       (* (get-header-data component) sb!vm:n-word-bytes))))
              (push (cons #!-x86
                          (stack-ref catch sb!vm:catch-block-tag-slot)
                          #!+x86
                          (make-lisp-obj
                           (sap-ref-32 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)))))))
\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))))

;;; 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 ((component
                        (compiled-debug-fun-component debug-fun))
                       (start-pc
                        (sb!c::compiled-debug-fun-start-pc
                         (compiled-debug-fun-compiler-debug-fun debug-fun))))
                   (do ((entry (%code-entry-points component)
                               (%simple-fun-next entry)))
                       ((null entry) nil)
                     (when (= start-pc
                              (sb!c::compiled-debug-fun-start-pc
                               (compiled-debug-fun-compiler-debug-fun
                                (fun-debug-fun entry))))
                       (return entry)))))
                (bogus-debug-fun nil)))
        cached-value)))

;;; 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)
  (declare (type debug-fun debug-fun))
  (etypecase debug-fun
    (compiled-debug-fun
     (sb!c::compiled-debug-fun-name
      (compiled-debug-fun-compiler-debug-fun debug-fun)))
    (bogus-debug-fun
     (bogus-debug-fun-%name debug-fun))))

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

;;; Return the kind of the function, which is one of :OPTIONAL,
;;; :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
      (let ((vars (debug-fun-debug-vars debug-fun))
            (i 0)
            (len (length args))
            (res nil)
            (optionalp nil))
        (declare (type (or null simple-vector) vars))
        (loop
          (when (>= i len) (return))
          (let ((ele (aref args i)))
            (cond
             ((symbolp ele)
              (case ele
                (sb!c::deleted
                 ;; Deleted required arg at beginning of args array.
                 (push :deleted res))
                (sb!c::optional-args
                 (setf optionalp t))
                (sb!c::supplied-p
                 ;; SUPPLIED-P var immediately following keyword or
                 ;; optional. Stick the extra var in the result
                 ;; element representing the keyword or optional,
                 ;; which is the previous one.
                 (nconc (car res)
                        (list (compiled-debug-fun-lambda-list-var
                               args (incf i) vars))))
                (sb!c::rest-arg
                 (push (list :rest
                             (compiled-debug-fun-lambda-list-var
                              args (incf i) vars))
                       res))
                (sb!c::more-arg
                 ;; Just ignore the fact that the next two args are
                 ;; the &MORE arg context and count, and act like they
                 ;; are regular arguments.
                 nil)
                (t
                 ;; &KEY arg
                 (push (list :keyword
                             ele
                             (compiled-debug-fun-lambda-list-var
                              args (incf i) vars))
                       res))))
             (optionalp
              ;; We saw an optional marker, so the following
              ;; non-symbols are indexes indicating optional
              ;; variables.
              (push (list :optional (svref vars ele)) res))
             (t
              ;; Required arg at beginning of args array.
              (push (svref vars ele) res))))
          (incf i))
        (values (nreverse res) t))))))

;;; 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 ((not (symbolp ele)) (svref vars ele))
          ((eq ele 'sb!c::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

(defvar *parsing-buffer*
  (make-array 20 :adjustable t :fill-pointer t))
(defvar *other-parsing-buffer*
  (make-array 20 :adjustable t :fill-pointer t))
;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS
;;; use this to unpack binary encoded information. It returns the
;;; values returned by the last form in body.
;;;
;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
;;; element zero, and makes sure if we unwind, we nil out any set
;;; elements for GC purposes.
;;;
;;; This also binds other-var to *other-parsing-buffer* when it is
;;; supplied, making sure it starts at element zero and that we nil
;;; out any elements if we unwind.
;;;
;;; This defines the local macro RESULT that takes a buffer, copies
;;; its elements to a resulting simple-vector, nil's out elements, and
;;; restarts the buffer at element zero. RESULT returns the
;;; simple-vector.
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
                                     &body body)
  (let ((len (gensym))
        (res (gensym)))
    `(unwind-protect
         (let ((,buffer-var *parsing-buffer*)
               ,@(if other-var `((,other-var *other-parsing-buffer*))))
           (setf (fill-pointer ,buffer-var) 0)
           ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
           (macrolet ((result (buf)
                        `(let* ((,',len (length ,buf))
                                (,',res (make-array ,',len)))
                           (replace ,',res ,buf :end1 ,',len :end2 ,',len)
                           (fill ,buf nil :end ,',len)
                           (setf (fill-pointer ,buf) 0)
                           ,',res)))
             ,@body))
     (fill *parsing-buffer* nil)
     ,@(if other-var `((fill *other-parsing-buffer* nil))))))
) ; EVAL-WHEN

;;; 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)
  (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
         (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
                              debug-fun))
         (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
         ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
         ;; element size of the packed binary representation of the
         ;; blocks data.
         (live-set-len (ceiling var-count 8))
         (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
    (unless blocks
      (return-from parse-compiled-debug-blocks nil))
    (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
      (with-parsing-buffer (blocks-buffer locations-buffer)
        (let ((i 0)
              (len (length blocks))
              (last-pc 0))
          (loop
            (when (>= i len) (return))
            (let ((succ-and-flags (aref+ blocks i))
                  (successors nil))
              (declare (type (unsigned-byte 8) succ-and-flags)
                       (list successors))
              (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
                               succ-and-flags))
                (push (sb!c:read-var-integer blocks i) successors))
              (let* ((locations
                      (dotimes (k (sb!c:read-var-integer blocks i)
                                  (result locations-buffer))
                        (let ((kind (svref sb!c::*compiled-code-location-kinds*
                                           (aref+ blocks i)))
                              (pc (+ last-pc
                                     (sb!c:read-var-integer blocks i)))
                              (tlf-offset (or tlf-number
                                              (sb!c:read-var-integer blocks i)))
                              (form-number (sb!c:read-var-integer blocks i))
                              (live-set (sb!c:read-packed-bit-vector
                                         live-set-len blocks i)))
                          (vector-push-extend (make-known-code-location
                                               pc debug-fun tlf-offset
                                               form-number live-set kind)
                                              locations-buffer)
                          (setf last-pc pc))))
                     (block (make-compiled-debug-block
                             locations successors
                             (not (zerop (logand
                                          sb!c::compiled-debug-block-elsewhere-p
                                          succ-and-flags))))))
                (vector-push-extend block blocks-buffer)
                (dotimes (k (length locations))
                  (setf (code-location-%debug-block (svref locations k))
                        block))))))
        (let ((res (result blocks-buffer)))
          (declare (simple-vector res))
          (dotimes (i (length res))
            (let* ((block (svref res i))
                   (succs nil))
              (dolist (ele (debug-block-successors block))
                (push (svref res ele) succs))
              (setf (debug-block-successors block) succs)))
          res)))))

;;; 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)
                      ;; KLUDGE: It's somewhat nasty to have a bare
                      ;; package name string here. It would be
                      ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
                      ;; instead, since then at least it would transform
                      ;; correctly under package renaming and stuff.
                      ;; However, genesis can't handle dumped packages..
                      ;; -- WHN 20000129
                      ;;
                      ;; FIXME: Maybe this could be fixed by moving the
                      ;; whole debug-int.lisp file to warm init? (after
                      ;; which dumping a #.(FIND-PACKAGE ..) expression
                      ;; would work fine) If this is possible, it would
                      ;; probably be a good thing, since minimizing the
                      ;; amount of stuff in cold init is basically good.
                      (or (find-package "SB-DEBUG")
                          (find-package "SB!DEBUG"))))))))

;;; 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))
                 (live (logtest sb!c::compiled-debug-var-environment-live
                                flags))
                 (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
                 (symbol (if minimal nil (geti)))
                 (id (if (logtest sb!c::compiled-debug-var-id-p flags)
                         (geti)
                         0))
                 (sc-offset (if deleted 0 (geti)))
                 (save-sc-offset (if save (geti) nil)))
            (aver (not (and args-minimal (not minimal))))
            (vector-push-extend (make-compiled-debug-var symbol
                                                         id
                                                         live
                                                         sc-offset
                                                         save-sc-offset)
                                buffer)))))))
\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)
  (etypecase code-location
    (compiled-code-location
     (let* ((info (compiled-debug-fun-debug-info
                   (code-location-debug-fun code-location)))
            (sources (sb!c::compiled-debug-info-source info))
            (len (length sources)))
       (declare (list sources))
       (when (zerop len)
         (debug-signal 'no-debug-blocks :debug-fun
                       (code-location-debug-fun code-location)))
       (if (= len 1)
           (car sources)
           (do ((prev sources src)
                (src (cdr sources) (cdr src))
                (offset (code-location-toplevel-form-offset code-location)))
               ((null src) (car prev))
             (when (< offset (sb!c::debug-source-source-root (car src)))
               (return (car prev)))))))
    ;; (There used to be more cases back before sbcl-0.7.0, when we
    ;; did special tricks to debug the IR1 interpreter.)
    ))

;;; 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)
  (when (code-location-unknown-p code-location)
    (error 'unknown-code-location :code-location code-location))
  (let ((tlf-offset (code-location-%tlf-offset code-location)))
    (cond ((eq tlf-offset :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-%tlf-offset code-location))
             ;; (There used to be more cases back before sbcl-0.7.0,,
             ;; when we did special tricks to debug the IR1
             ;; interpreter.)
             ))
          (t tlf-offset))))

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

;;; 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)))
    (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)
              (setf (code-location-%debug-block code-location) block)
              (setf (code-location-%tlf-offset code-location)
                    (code-location-%tlf-offset loc))
              (setf (code-location-%form-number code-location)
                    (code-location-%form-number loc))
              (setf (compiled-code-location-%live-set code-location)
                    (compiled-code-location-%live-set loc))
              (setf (compiled-code-location-kind code-location)
                    (compiled-code-location-kind loc))
              (return-from fill-in-code-location t))))))))
\f
;;;; operations on DEBUG-BLOCKs

;;; Execute FORMS in a context with CODE-VAR bound to each
;;; CODE-LOCATION in DEBUG-BLOCK, and return the value of RESULT.
(defmacro do-debug-block-locations ((code-var debug-block &optional result)
                                    &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)
  (declare (optimize (speed 1)))
  (let ((escaped (compiled-frame-escaped frame)))
    (if escaped
        (sub-access-debug-var-slot
         (frame-pointer frame)
         (compiled-debug-var-sc-offset debug-var)
         escaped)
      (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.)
(defun make-valid-lisp-obj (val)
  (if (or
       ;; fixnum
       (zerop (logand val 3))
       ;; character
       (and (zerop (logand val #xffff0000)) ; Top bits zero
            (= (logand val #xff) sb!vm:base-char-widetag)) ; char tag
       ;; unbound marker
       (= val sb!vm:unbound-marker-widetag)
       ;; pointer
       (and (logand val 1)
            ;; Check that the pointer is valid. XXX Could do a better
            ;; job. FIXME: e.g. by calling out to an is_valid_pointer
            ;; routine in the C runtime support code
            (or (< sb!vm:read-only-space-start val
                   (* sb!vm:*read-only-space-free-pointer*
                      sb!vm:n-word-bytes))
                (< sb!vm:static-space-start val
                   (* sb!vm:*static-space-free-pointer*
                      sb!vm:n-word-bytes))
                (< sb!vm:dynamic-space-start val
                   (sap-int (dynamic-space-free-pointer))))))
      (make-lisp-obj val)
      :invalid-object))

#!-x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
  (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)
               `(let ((,var (if escaped
                                (sb!sys:int-sap
                                 (sb!vm:context-register escaped
                                                         sb!vm::nfp-offset))
                                #!-alpha
                                (sb!sys:sap-ref-sap fp (* nfp-save-offset
                                                          sb!vm:n-word-bytes))
                                #!+alpha
                                (sb!vm::make-number-stack-pointer
                                 (sb!sys:sap-ref-32 fp (* nfp-save-offset
                                                          sb!vm:n-word-bytes))))))
                  ,@body)))
    (ecase (sb!c:sc-offset-scn sc-offset)
      ((#.sb!vm:any-reg-sc-number
        #.sb!vm:descriptor-reg-sc-number
        #!+rt #.sb!vm:word-pointer-reg-sc-number)
       (sb!sys:without-gcing
        (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
                            
      (#.sb!vm:base-char-reg-sc-number
       (with-escaped-value (val)
         (code-char val)))
      (#.sb!vm:sap-reg-sc-number
       (with-escaped-value (val)
         (sb!sys:int-sap val)))
      (#.sb!vm:signed-reg-sc-number
       (with-escaped-value (val)
         (if (logbitp (1- sb!vm:n-word-bits) val)
             (logior val (ash -1 sb!vm:n-word-bits))
             val)))
      (#.sb!vm:unsigned-reg-sc-number
       (with-escaped-value (val)
         val))
      (#.sb!vm:non-descriptor-reg-sc-number
       (error "Local non-descriptor register access?"))
      (#.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
       (if escaped
           (complex
            (sb!vm:context-float-register
             escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
            (sb!vm:context-float-register
             escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
           :invalid-value-for-unescaped-register-storage))
      (#.sb!vm:complex-double-reg-sc-number
       (if escaped
           (complex
            (sb!vm:context-float-register
             escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
            (sb!vm:context-float-register
             escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
             'double-float))
           :invalid-value-for-unescaped-register-storage))
      #!+long-float
      (#.sb!vm:complex-long-reg-sc-number
       (if escaped
           (complex
            (sb!vm:context-float-register
             escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
            (sb!vm:context-float-register
             escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
             'long-float))
           :invalid-value-for-unescaped-register-storage))
      (#.sb!vm:single-stack-sc-number
       (with-nfp (nfp)
         (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
                                       sb!vm:n-word-bytes))))
      (#.sb!vm:double-stack-sc-number
       (with-nfp (nfp)
         (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
                                       sb!vm:n-word-bytes))))
      #!+long-float
      (#.sb!vm:long-stack-sc-number
       (with-nfp (nfp)
         (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
                                     sb!vm:n-word-bytes))))
      (#.sb!vm:complex-single-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
                                        sb!vm:n-word-bytes))
          (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
                                        sb!vm:n-word-bytes)))))
      (#.sb!vm:complex-double-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
                                        sb!vm:n-word-bytes))
          (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                        sb!vm:n-word-bytes)))))
      #!+long-float
      (#.sb!vm:complex-long-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
                                      sb!vm:n-word-bytes))
          (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
                                         #!+sparc 4)
                                      sb!vm:n-word-bytes)))))
      (#.sb!vm:control-stack-sc-number
       (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
      (#.sb!vm:base-char-stack-sc-number
       (with-nfp (nfp)
         (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
                                              sb!vm:n-word-bytes)))))
      (#.sb!vm:unsigned-stack-sc-number
       (with-nfp (nfp)
         (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
                                   sb!vm:n-word-bytes))))
      (#.sb!vm:signed-stack-sc-number
       (with-nfp (nfp)
         (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
                                          sb!vm:n-word-bytes))))
      (#.sb!vm:sap-stack-sc-number
       (with-nfp (nfp)
         (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
                                    sb!vm:n-word-bytes)))))))

#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
  (declare (type system-area-pointer fp))
  (macrolet ((with-escaped-value ((var) &body forms)
               `(if escaped
                    (let ((,var (sb!vm:context-register
                                 escaped
                                 (sb!c:sc-offset-offset sc-offset))))
                      ,@forms)
                    :invalid-value-for-unescaped-register-storage))
             (escaped-float-value (format)
               `(if escaped
                    (sb!vm:context-float-register
                     escaped (sb!c:sc-offset-offset sc-offset) ',format)
                    :invalid-value-for-unescaped-register-storage))
             (escaped-complex-float-value (format)
               `(if escaped
                    (complex
                     (sb!vm:context-float-register
                      escaped (sb!c:sc-offset-offset sc-offset) ',format)
                     (sb!vm:context-float-register
                      escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
                    :invalid-value-for-unescaped-register-storage)))
    (ecase (sb!c:sc-offset-scn sc-offset)
      ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
       (without-gcing
        (with-escaped-value (val)
          (make-valid-lisp-obj val))))
      (#.sb!vm:base-char-reg-sc-number
       (with-escaped-value (val)
         (code-char val)))
      (#.sb!vm:sap-reg-sc-number
       (with-escaped-value (val)
         (int-sap val)))
      (#.sb!vm:signed-reg-sc-number
       (with-escaped-value (val)
         (if (logbitp (1- sb!vm:n-word-bits) val)
             (logior val (ash -1 sb!vm:n-word-bits))
             val)))
      (#.sb!vm:unsigned-reg-sc-number
       (with-escaped-value (val)
         val))
      (#.sb!vm:single-reg-sc-number
       (escaped-float-value single-float))
      (#.sb!vm:double-reg-sc-number
       (escaped-float-value double-float))
      #!+long-float
      (#.sb!vm:long-reg-sc-number
       (escaped-float-value long-float))
      (#.sb!vm:complex-single-reg-sc-number
       (escaped-complex-float-value single-float))
      (#.sb!vm:complex-double-reg-sc-number
       (escaped-complex-float-value double-float))
      #!+long-float
      (#.sb!vm:complex-long-reg-sc-number
       (escaped-complex-float-value long-float))
      (#.sb!vm:single-stack-sc-number
       (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                sb!vm:n-word-bytes))))
      (#.sb!vm:double-stack-sc-number
       (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                sb!vm:n-word-bytes))))
      #!+long-float
      (#.sb!vm:long-stack-sc-number
       (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                              sb!vm:n-word-bytes))))
      (#.sb!vm:complex-single-stack-sc-number
       (complex
        (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                 sb!vm:n-word-bytes)))
        (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                 sb!vm:n-word-bytes)))))
      (#.sb!vm:complex-double-stack-sc-number
       (complex
        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                                 sb!vm:n-word-bytes)))
        (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
                                 sb!vm:n-word-bytes)))))
      #!+long-float
      (#.sb!vm:complex-long-stack-sc-number
       (complex
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                               sb!vm:n-word-bytes)))
        (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
                               sb!vm:n-word-bytes)))))
      (#.sb!vm:control-stack-sc-number
       (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
      (#.sb!vm:base-char-stack-sc-number
       (code-char
        (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                             sb!vm:n-word-bytes)))))
      (#.sb!vm:unsigned-stack-sc-number
       (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                            sb!vm:n-word-bytes))))
      (#.sb!vm:signed-stack-sc-number
       (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                   sb!vm:n-word-bytes))))
      (#.sb!vm:sap-stack-sc-number
       (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                             sb!vm:n-word-bytes)))))))

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

#!-x86
(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
  (macrolet ((set-escaped-value (val)
               `(if escaped
                    (setf (sb!vm:context-register
                           escaped
                           (sb!c:sc-offset-offset sc-offset))
                          ,val)
                    value))
             (set-escaped-float-value (format val)
               `(if escaped
                    (setf (sb!vm:context-float-register
                           escaped
                           (sb!c:sc-offset-offset sc-offset)
                           ',format)
                          ,val)
                    value))
             (with-nfp ((var) &body body)
               `(let ((,var (if escaped
                                (int-sap
                                 (sb!vm:context-register escaped
                                                         sb!vm::nfp-offset))
                                #!-alpha
                                (sap-ref-sap fp
                                             (* nfp-save-offset
                                                sb!vm:n-word-bytes))
                                #!+alpha
                                (sb!vm::make-number-stack-pointer
                                 (sap-ref-32 fp
                                             (* nfp-save-offset
                                                sb!vm:n-word-bytes))))))
                  ,@body)))
    (ecase (sb!c:sc-offset-scn sc-offset)
      ((#.sb!vm:any-reg-sc-number
        #.sb!vm:descriptor-reg-sc-number
        #!+rt #.sb!vm:word-pointer-reg-sc-number)
       (without-gcing
        (set-escaped-value
          (get-lisp-obj-address value))))
      (#.sb!vm:base-char-reg-sc-number
       (set-escaped-value (char-code value)))
      (#.sb!vm:sap-reg-sc-number
       (set-escaped-value (sap-int value)))
      (#.sb!vm:signed-reg-sc-number
       (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
      (#.sb!vm:unsigned-reg-sc-number
       (set-escaped-value value))
      (#.sb!vm:non-descriptor-reg-sc-number
       (error "Local non-descriptor register access?"))
      (#.sb!vm:interior-reg-sc-number
       (error "Local interior register access?"))
      (#.sb!vm:single-reg-sc-number
       (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
       (when escaped
         (setf (sb!vm:context-float-register escaped
                                             (sb!c:sc-offset-offset sc-offset)
                                             'single-float)
               (realpart value))
         (setf (sb!vm:context-float-register
                escaped (1+ (sb!c:sc-offset-offset sc-offset))
                'single-float)
               (imagpart value)))
       value)
      (#.sb!vm:complex-double-reg-sc-number
       (when escaped
         (setf (sb!vm:context-float-register
                escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
               (realpart value))
         (setf (sb!vm:context-float-register
                escaped
                (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
                'double-float)
               (imagpart value)))
       value)
      #!+long-float
      (#.sb!vm:complex-long-reg-sc-number
       (when escaped
         (setf (sb!vm:context-float-register
                escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
               (realpart value))
         (setf (sb!vm:context-float-register
                escaped
                (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
                'long-float)
               (imagpart value)))
       value)
      (#.sb!vm:single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
                                      sb!vm:n-word-bytes))
               (the single-float value))))
      (#.sb!vm:double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
                                      sb!vm:n-word-bytes))
               (the double-float value))))
      #!+long-float
      (#.sb!vm:long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
                                    sb!vm:n-word-bytes))
               (the long-float value))))
      (#.sb!vm:complex-single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single
                nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
               (the single-float (realpart value)))
         (setf (sap-ref-single
                nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
                       sb!vm:n-word-bytes))
               (the single-float (realpart value)))))
      (#.sb!vm:complex-double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double
                nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
               (the double-float (realpart value)))
         (setf (sap-ref-double
                nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                       sb!vm:n-word-bytes))
               (the double-float (realpart value)))))
      #!+long-float
      (#.sb!vm:complex-long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long
                nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:n-word-bytes))
               (the long-float (realpart value)))
         (setf (sap-ref-long
                nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
                       sb!vm:n-word-bytes))
               (the long-float (realpart value)))))
      (#.sb!vm:control-stack-sc-number
       (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
      (#.sb!vm:base-char-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
                                         sb!vm:n-word-bytes))
               (char-code (the character value)))))
      (#.sb!vm:unsigned-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
                                  sb!vm:n-word-bytes))
               (the (unsigned-byte 32) value))))
      (#.sb!vm:signed-stack-sc-number
       (with-nfp (nfp)
         (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
                                         sb!vm:n-word-bytes))
               (the (signed-byte 32) value))))
      (#.sb!vm:sap-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
                                   sb!vm:n-word-bytes))
               (the system-area-pointer value)))))))

#!+x86
(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
  (macrolet ((set-escaped-value (val)
               `(if escaped
                    (setf (sb!vm:context-register
                           escaped
                           (sb!c:sc-offset-offset sc-offset))
                          ,val)
                    value)))
    (ecase (sb!c:sc-offset-scn sc-offset)
      ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
       (without-gcing
        (set-escaped-value
          (get-lisp-obj-address value))))
      (#.sb!vm:base-char-reg-sc-number
       (set-escaped-value (char-code value)))
      (#.sb!vm:sap-reg-sc-number
       (set-escaped-value (sap-int value)))
      (#.sb!vm:signed-reg-sc-number
       (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))
      (#.sb!vm:unsigned-reg-sc-number
       (set-escaped-value value))
      (#.sb!vm:single-reg-sc-number
        #+nil ;; don't have escaped floats.
       (set-escaped-float-value single-float value))
      (#.sb!vm:double-reg-sc-number
        #+nil ;;  don't have escaped floats -- still in npx?
       (set-escaped-float-value double-float value))
      #!+long-float
      (#.sb!vm:long-reg-sc-number
        #+nil ;;  don't have escaped floats -- still in npx?
       (set-escaped-float-value long-float value))
      (#.sb!vm:single-stack-sc-number
       (setf (sap-ref-single
              fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                       sb!vm:n-word-bytes)))
             (the single-float value)))
      (#.sb!vm:double-stack-sc-number
       (setf (sap-ref-double
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                       sb!vm:n-word-bytes)))
             (the double-float value)))
      #!+long-float
      (#.sb!vm:long-stack-sc-number
       (setf (sap-ref-long
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                       sb!vm:n-word-bytes)))
             (the long-float value)))
      (#.sb!vm:complex-single-stack-sc-number
       (setf (sap-ref-single
              fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                       sb!vm:n-word-bytes)))
             (realpart (the (complex single-float) value)))
       (setf (sap-ref-single
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                       sb!vm:n-word-bytes)))
             (imagpart (the (complex single-float) value))))
      (#.sb!vm:complex-double-stack-sc-number
       (setf (sap-ref-double
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
                       sb!vm:n-word-bytes)))
             (realpart (the (complex double-float) value)))
       (setf (sap-ref-double
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
                       sb!vm:n-word-bytes)))
             (imagpart (the (complex double-float) value))))
      #!+long-float
      (#.sb!vm:complex-long-stack-sc-number
       (setf (sap-ref-long
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
                       sb!vm:n-word-bytes)))
             (realpart (the (complex long-float) value)))
       (setf (sap-ref-long
              fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
                       sb!vm:n-word-bytes)))
             (imagpart (the (complex long-float) value))))
      (#.sb!vm:control-stack-sc-number
       (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
      (#.sb!vm:base-char-stack-sc-number
       (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                         sb!vm:n-word-bytes)))
             (char-code (the character value))))
      (#.sb!vm:unsigned-stack-sc-number
       (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                         sb!vm:n-word-bytes)))
             (the (unsigned-byte 32) value)))
      (#.sb!vm:signed-stack-sc-number
       (setf (signed-sap-ref-32
              fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                       sb!vm:n-word-bytes)))
             (the (signed-byte 32) value)))
      (#.sb!vm:sap-stack-sc-number
       (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
                                          sb!vm:n-word-bytes)))
             (the system-area-pointer value))))))

;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
  (and (= (lowtag-of x) sb!vm:other-pointer-lowtag)
       (= (widetag-of x) sb!vm:value-cell-header-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)
  (etypecase debug-var
    (compiled-debug-var
     (compiled-debug-var-validity debug-var basic-code-location))
    ;; (There used to be more cases back before sbcl-0.7.0, when
    ;; we did special tricks to debug the IR1 interpreter.)
    ))

;;; 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.

;;; temporary buffer used to build form-number => source-path translation in
;;; FORM-NUMBER-TRANSLATIONS
(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))

;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
(defvar *form-number-circularity-table* (make-hash-table :test 'eq))

;;; This returns a table mapping form numbers to source-paths. A
;;; source-path indicates a descent into the TOPLEVEL-FORM form,
;;; going directly to the subform corressponding to the form number.
;;;
;;; 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.
(defun form-number-translations (form tlf-number)
  (clrhash *form-number-circularity-table*)
  (setf (fill-pointer *form-number-temp*) 0)
  (sub-translate-form-numbers form (list tlf-number))
  (coerce *form-number-temp* 'simple-vector))
(defun sub-translate-form-numbers (form path)
  (unless (gethash form *form-number-circularity-table*)
    (setf (gethash form *form-number-circularity-table*) t)
    (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
                        *form-number-temp*)
    (let ((pos 0)
          (subform form)
          (trail form))
      (declare (fixnum pos))
      (macrolet ((frob ()
                   '(progn
                      (when (atom subform) (return))
                      (let ((fm (car subform)))
                        (when (consp fm)
                          (sub-translate-form-numbers fm (cons pos path)))
                        (incf pos))
                      (setq subform (cdr subform))
                      (when (eq subform trail) (return)))))
        (loop
          (frob)
          (frob)
          (setq trail (cdr trail)))))))

;;; 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))))
\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)))
    (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)
            (let* ((sym (debug-var-symbol var))
                   (found (assoc sym (binds))))
              (if found
                  (setf (second found) :ambiguous)
                  (binds (list sym validity var)))))))
      (dolist (bind (binds))
        (let ((name (first bind))
              (var (third bind)))
          (ecase (second bind)
            (:valid
             (specs `(,name (debug-var-value ',var ,n-frame))))
            (:unknown
             (specs `(,name (debug-signal 'invalid-value
                                          :debug-var ',var
                                          :frame ,n-frame))))
            (:ambiguous
             (specs `(,name (debug-signal 'ambiguous-var-name
                                          :name ',name
                                          :frame ,n-frame)))))))
      (let ((res (coerce `(lambda (,n-frame)
                            (declare (ignorable ,n-frame))
                            (symbol-macrolet ,(specs) ,form))
                         'function)))
        (lambda (frame)
          ;; This prevents these functions from being used in any
          ;; location other than a function return location, so maybe
          ;; this should only check whether FRAME's DEBUG-FUN is the
          ;; same as LOC's.
          (unless (code-location= (frame-code-location frame) loc)
            (debug-signal 'frame-fun-mismatch
                          :code-location loc :form form :frame frame))
          (funcall res frame))))))
\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
  ;; the DEBUG-FUN associated with this cookie
  debug-fun)

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

;;; 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
           (sb!c::compiled-debug-fun-return-pc
            (compiled-debug-fun-compiler-debug-fun debug-fun))))
      (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 (sb!c::compiled-debug-fun-return-pc
                        (compiled-debug-fun-compiler-debug-fun
                         (fun-end-cookie-debug-fun cookie)))))
    (do ((frame frame (frame-down frame)))
        ((not frame) nil)
      (when (and (compiled-frame-p frame)
                 (#!-x86 eq #!+x86 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-long
  (code-obj sb!alien:unsigned-long)
  (pc-offset sb!alien:int))

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

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

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

;;; 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)
  (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 component offset)))
  ;; 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.
  (let ((data (breakpoint-data component offset nil)))
    (when (and data (breakpoint-data-breakpoints data))
      ;; The breakpoint is still active, so we need to execute the
      ;; displaced instruction and leave the breakpoint instruction
      ;; behind. The best way to do this is different on each machine,
      ;; so we just leave it up to the C code.
      (breakpoint-do-displaced-inst signal-context
                                    (breakpoint-data-instruction data))
      ;; Some platforms have no usable sigreturn() call.  If your
      ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
      ;; it's polite to warn here
      #!+(and sparc solaris)
      (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))

(defun invoke-breakpoint-hooks (breakpoints component offset)
  (let* ((debug-fun (debug-fun-from-pc component offset))
         (frame (do ((f (top-frame) (frame-down f)))
                    ((eq debug-fun (frame-debug-fun f)) f))))
    (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 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)
  (delete-breakpoint-data data)
  (let* ((scp
          (locally
            (declare (optimize (inhibit-warnings 3)))
            (sb!alien:sap-alien signal-context (* os-context-t))))
         (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
                     (f (top-frame) (frame-down f)))
                    ((= cfp (sap-int (frame-pointer f))) f)
                  (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp))))
         (component (breakpoint-data-component data))
         (cookie (gethash component *fun-end-cookies*)))
    (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
                        #!-x86 sb!vm::ocfp-offset
                        #!+x86 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))
             results)))
    (nreverse results)))
\f
;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)

(defconstant bogus-lra-constants
  #!-x86 2 #!+x86 3)
(defconstant known-return-p-slot
  (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))

;;; 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 &optional known-return-p)
  (without-gcing
   (let* ((src-start (foreign-symbol-address "fun_end_breakpoint_guts"))
          (src-end (foreign-symbol-address "fun_end_breakpoint_end"))
          (trap-loc (foreign-symbol-address "fun_end_breakpoint_trap"))
          (length (sap- src-end src-start))
          (code-object
           (%primitive sb!c:allocate-code-object (1+ bogus-lra-constants)
                       length))
          (dst-start (code-instructions code-object)))
     (declare (type system-area-pointer
                    src-start src-end dst-start trap-loc)
              (type index length))
     (setf (%code-debug-info code-object) :bogus-lra)
     (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
           length)
     #!-x86
     (setf (code-header-ref code-object real-lra-slot) real-lra)
     #!+x86
     (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))
     (setf (code-header-ref code-object known-return-p-slot)
           known-return-p)
     (system-area-copy src-start 0 dst-start 0 (* length sb!vm:n-byte-bits))
     (sb!vm:sanctify-for-execution code-object)
     #!+x86
     (values dst-start code-object (sap- trap-loc src-start))
     #!-x86
     (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
                                      sb!vm:other-pointer-lowtag))))
       (set-header-data
        new-lra
        (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
                  1))
       (sb!vm:sanctify-for-execution code-object)
       (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.)
    ))