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

(defstruct (sb-c::core-debug-source (:pure t)
                                    (:copier nil)
                                    (:include debug-source))
  ;; Compilation to memory stores each toplevel form given to %COMPILE.
  ;; That form can generate multiple functions, and those functions can
  ;; be in one or more code components. They all point at the same form.
  form
  (function nil :read-only t))

;;; 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?

;;;; conditions

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

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

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

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

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

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

(define-condition invalid-value (debug-condition)
  ((debug-var :reader invalid-value-debug-var :initarg :debug-var)
   (frame :reader invalid-value-frame :initarg :frame))
  (:report (lambda (condition stream)
             (format stream "~&~S has :invalid or :unknown value in ~S."
                     (invalid-value-debug-var condition)
                     (invalid-value-frame condition)))))

(define-condition ambiguous-var-name (debug-condition)
  ((name :reader ambiguous-var-name-name :initarg :name)
   (frame :reader ambiguous-var-name-frame :initarg :frame))
  (:report (lambda (condition stream)
             (format stream "~&~S names more than one valid variable in ~S."
                     (ambiguous-var-name-name condition)
                     (ambiguous-var-name-frame condition)))))

;;;; errors and DEBUG-SIGNAL

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

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

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

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

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

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

(define-condition frame-fun-mismatch (debug-error)
  ((code-location :reader frame-fun-mismatch-code-location
                  :initarg :code-location)
   (frame :reader frame-fun-mismatch-frame :initarg :frame)
   (form :reader frame-fun-mismatch-form :initarg :form))
  (:report (lambda (condition stream)
             (format
              stream
              "~&Form was preprocessed for ~S,~% but called on ~S:~%  ~S"
              (frame-fun-mismatch-code-location condition)
              (frame-fun-mismatch-frame condition)
              (frame-fun-mismatch-form condition)))))

;;; This signals debug-conditions. If they go unhandled, then signal
;;; an UNHANDLED-DEBUG-CONDITION error.
;;;
;;; ??? Get SIGNAL in the right package!
(defmacro debug-signal (datum &rest arguments)
  `(let ((condition (make-condition ,datum ,@arguments)))
     (signal condition)
     (error 'unhandled-debug-condition :condition condition)))

;;;; 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))
  ;; string name of the variable.
  (name (missing-arg) :type simple-string)
  ;; package containing the variable. NIL when the variable's name is
  ;; uninterned.
  (package nil :type (or null package))
  ;; a unique integer identification relative to other variables with the same
  ;; symbol
  (id 0 :type index :read-only t)
  ;; Does the variable always have a valid value?
  (alive-p nil :type boolean :read-only t))
(defmethod print-object ((debug-var debug-var) stream)
  (print-unreadable-object (debug-var stream :type t :identity t)
    (format stream
            "~A:~A ~W"
            (sb-xc:package-name (debug-var-package debug-var))
            (debug-var-name debug-var)
            (debug-var-id debug-var))))

(setf (documentation '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
                (name package id alive-p
                 sc+offset save-sc+offset indirect-sc+offset))
            (:copier nil))
  ;; storage class and offset (unexported)
  (sc+offset nil :type sb-c:sc+offset :read-only t)
  ;; storage class and offset when saved somewhere
  (save-sc+offset nil :type (or sb-c:sc+offset null) :read-only t)
  ;; For indirect closures the fp of the parent frame is stored in the
  ;; normal SC+OFFSETs above, and this has the offset into the frame
  (indirect-sc+offset nil :type (or sb-c:sc+offset null) :read-only t))

;;;; DEBUG-FUNs

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

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

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

;;;; DEBUG-BLOCKs

;;; These exist for caching data stored in packed binary form in compiler
;;; DEBUG-BLOCKs.
(defstruct (debug-block (:constructor nil)
                        (:copier nil))
  ;; 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))
(defmethod print-object ((obj debug-block) str)
  (print-unreadable-object (obj str :type t)
    (prin1 (debug-block-fun-name obj) str)))

(setf (documentation 'debug-block-successors 'function)
  "Returns the list of possible code-locations where execution may continue
   when the basic-block represented by debug-block completes its execution.")

(setf (documentation '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 #() :type simple-vector))

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

;;;; frames

;;; These represent call frames on the stack.
(defstruct (frame (:constructor nil)
                  (:copier nil))
  ;; the next frame up, or NIL when top frame
  ;; KLUDGE - (OR NULL FRAME), and not (OR FRAME NULL), because PARSE-1-DSD
  ;; warns; we're so bad at understanding recursive structure.
  (up nil :type (or null frame))
  ;; 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 (member nil :unparsed) frame))
  ;; the DEBUG-FUN for the function whose call this frame represents
  (debug-fun nil :type debug-fun :read-only t)
  ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
  ;; running when program execution returns to this frame. If someone
  ;; interrupted this frame, the result could be an unknown
  ;; CODE-LOCATION.
  (code-location nil :type code-location :read-only t)
  ;; an a-list of catch-tags to code-locations
  (%catches :unparsed :type (or list (member :unparsed)))
  ;; pointer to frame on control stack (unexported)
  (pointer nil :read-only t)
  ;; This is the frame's number for prompt printing. Top is zero.
  (number 0 :type index))

(defstruct (compiled-frame
            (:include frame)
            (:constructor make-compiled-frame
                          (pointer up debug-fun code-location number
                                   &optional escaped))
            (:copier nil))
  ;; This indicates whether someone interrupted the frame.
  ;; (unexported). If escaped, this is a pointer to the state that was
  ;; saved when we were interrupted, an os_context_t, i.e. the third
  ;; argument to an SA_SIGACTION-style signal handler.
  (escaped nil :read-only t))
(defmethod print-object ((obj compiled-frame) str)
  (print-unreadable-object (obj str :type t)
    (format str
            "~S~:[~;, interrupted~]"
            (debug-fun-name (frame-debug-fun obj))
            (compiled-frame-escaped obj))))


;;;; breakpoints

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

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

(defmacro with-weak-cache ((temp global) &body body)
  `(let ((,temp (or ,global
                    (let ((new
                           (sb-vm:without-arena
                               (make-hash-table :test 'eq
                                                :weakness :key
                                                :synchronized t))))
                      ;; double-checked idiom has to ensure that no other CPU
                      ;; can see a just-made hash-table until all the slots of
                      ;; the instance are definitely published before the
                      ;; global var points to it.
                      (sb-thread:barrier (:write))
                      (or (cas ,global nil new) new)))))
     ,@body))

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

;;; This maps SB-C::COMPILED-DEBUG-FUNs to SB-DI::COMPILED-DEBUG-FUNs, so we
;;; can get at cached stuff and not duplicate COMPILED-DEBUG-FUN
;;; structures.
(define-load-time-global *compiled-debug-funs* nil)

;;; Make a SB-DI::COMPILED-DEBUG-FUN for a SB-C::COMPILED-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)
  (with-weak-cache (ht *compiled-debug-funs*)
    (or (gethash compiler-debug-fun ht)
        (setf (gethash compiler-debug-fun ht)
              (%make-compiled-debug-fun compiler-debug-fun component)))))


;;;; CODE-LOCATIONs

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

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

;;; This is used in FIND-ESCAPED-FRAME and with the "breakpoint return" objects
;;; and LRAs used for :FUN-END breakpoints. When a code object's
;;; debug-info slot is :BPT-LRA, then the REAL-LRA-SLOT contains the
;;; real location to continue executing, as opposed to the intermediary object
;;; which appeared in some frame's LRA location.
;;; NB: If you change change REAL-LRA-SLOT, then you must also change
;;; "#define REAL_LRA_SLOT" in breakpoint.c. These have unfortunately
;;; different values, because this slot is relative to the object base
;;; address, whereas the one in C is an index into code->constants.
(defconstant bpt-lra-boxed-nwords
  ;; * For backends with LRA: one boxed constant holds the true LRA,
  ;;   one holds KNOWN-RETURN-P.
  ;; * For backends without LRA: one boxed constant holds the code
  ;;   object to which to return, one holds the displacement into that
  ;;   object.
  ;; All backends have an additional slot to hold the cookie.
  (+ code-constants-offset 3))
(defconstant real-lra-slot code-constants-offset)
(defconstant cookie-slot (+ code-constants-offset 2))

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

(declaim (inline valid-tagged-pointer-p))
(sb-alien:define-alien-routine ("lisp_valid_tagged_pointer_p" valid-tagged-pointer-p)
    sb-alien:int
  (pointer system-area-pointer))

;;; There are many opportunities for things to go wrong when searching
;;; the heap for a code component. One possible problem occurs when
;;; component_ptr_from_pc() searches for a code component on a page which
;;; gets partially evacuated on x86[-64]. Suppose it contains pinned code
;;; preceded by some objects that got forwarded. The scan performed by
;;; gc_search_space could be interrupted in the middle, and resume execution
;;; looking at a forwarding pointer, which gets the fatal "no size function".
;;; Morover, excess delay between finding an object and creating a Lisp
;;; descriptor introduces additional potential for error.
;;; So we do two things to mitigate that problem:
;;; (1) use unsafe %MAKE-LISP-OBJ, since we've already determined
;;;     where the code object starts with certainty, and we don't need
;;;     yet another search to test validity of the address.
;;; (2) wrap the calls in WITH-CODE-PAGES-PINNED.
;;;
;;; Here's a concrete example, assuming the following objects exists:
;;;       0x8000: vector header     |
;;;       0x8008: vector length     | object 1
;;;       0x8010: vector contents   |
;;;             : ...               v
;;;       0x8100: code object       | object 2
;;;             : ...
;;; thread A is backtracing, and currently in component_ptr_to_pc(),
;;; looking at 0x8000. Suppose the code is pinned, and that a garbage collection
;;; will partially evacuate the page, and that partial evacuation zero-fills
;;; the unused ranges (which it no longer does). Consider these schedules:
;;;
;;;  Thread A                      Thread B
;;;  --------                      --------
;;;  read header @ 0x8000
;;;                                 GC happens. zero-fill from 0x8000:0x8100
;;;  read length @ 0x8008 => 0
;;;   (skip to next object)
;;;  read header @ 0x8010 => junk
;;;
;;; In this schedule, thread A reads a word which is not a valid object header.
;;;
;;; But partial evacution no longer zeros the freed subranges - instead it writes
;;; an unboxed array header so that only two words are touched per unused subrange.
;;; This causes a different problem: The array may appear to contain forwarding
;;; pointers to live objects that were moved off the page, and those pointers
;;; appear to be embedded in the unboxed array.
;;;
;;; Use of WITHOUT-GCING is unfortunate - it's always preferable to
;;; try to pin individual objects - but to do better we would have to
;;; implement page-wide hazard pointers informing GC not to do anything
;;; to any object on a specified page.
;;;
;;; On top of the considerations about dynamic space, there is a further issue
;;; with allocation of immobile code. The allocator creates transient inconsistent
;;; states when it reuses holes. Even if the header could be written atomically,
;;; there can be junk in the remaining bytes of the hole that gets rewritten as
;;; a smaller hole. It's evident that acquiring the allocator mutex works around
;;; that glitch, as without such precaution, 'compiler.pure.lisp' would routinely
;;; crash when run in multiple threads. A better fix would be to preseve invariants
;;; at all times when allocating, both for the new hole that results from the hole
;;; that gets cut down to size, and for the new object per se. Example:
;;;    | hole ............................ |  1 Kb
;;;      ^ new-object here  ^ smaller hole starts here
;;;        (512 bytes)
;;;
;;; We first need to atomically write the header of the smaller hole
;;; (which can't even be seen until the new object header is written).
;;; This establishes that there won't be an inconsistent state.
;;; Then we need to atomically write the new object header.
;;; I suspect that both atomic writes should use double-wide CAS,
;;; because if the object header is written using lispword-sized writes,
;;; then the object can be sized wrong, and in this case it does cause problems
;;; because the remaining bytes are not zero-filled. The allocator is similar
;;; to malloc() in that regard.

(defun code-header-from-pc (pc)
  (with-code-pages-pinned (:dynamic)
    (let ((base-ptr
            ;; FIXME: It's accessing *dynspace-codeblob-tree*, which
            ;; isn't gc-safe when done from C (especially on the
            ;; precise gc backends).
            (without-gcing
              (sb-alien:alien-funcall
               (sb-alien:extern-alien "lisp_component_ptr_from_pc"
                                      (function sb-alien:unsigned system-area-pointer))
               (etypecase pc
                 (system-area-pointer pc)
                 (word (int-sap pc)))))))
      (unless (= base-ptr 0) (%make-lisp-obj (logior base-ptr other-pointer-lowtag))))))

(defun compute-lra-data-from-pc (pc)
  (declare (type system-area-pointer pc))
  ;; While theoretically we should inhibit GC any time we search the heap,
  ;; in practice this function can only be called for code that is somewhere
  ;; on the stack, and therefore conservatively pinned.
  (let ((code (code-header-from-pc pc)))
    (values (if code (sap- pc (code-instructions code)) nil)
            code)))

#+(or x86 x86-64)
(progn

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

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

) ; #+x86 PROGN

;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
  (/noshow0 "entering TOP-FRAME")
  (compute-calling-frame (descriptor-sap (%caller-frame))
                         #+c-stack-is-control-stack
                         ;; Not a descriptor because PC is not fixnum-aligned on x86,
                         ;; but it can directly specify sap-stack, because it has only one stack.
                         ;; Everywhere else SAPs are saved on the number stack.
                         (%caller-pc)
                         #-c-stack-is-control-stack
                         (descriptor-sap (%caller-pc))
                         nil))

;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
(defun flush-frames-above (frame)
  (setf (frame-up frame) nil)
  (do ((number 0 (1+ number))
       (frame frame (frame-%down frame)))
      ((not (frame-p frame)))
    (setf (frame-number frame) number)))

#+(or x86 x86-64)
(defun find-saved-frame-down (fp up-frame)
  (multiple-value-bind (saved-fp saved-pc)
      (find-saved-fp-and-pc fp)
    (when saved-fp
      (compute-calling-frame saved-fp saved-pc up-frame t))))

#+c-stack-is-control-stack
(progn
(defun walk-binding-stack (symbol function)
  (let* (#+sb-thread
         (tls-index (symbol-tls-index symbol))
         (current-value
           #+sb-thread
           (sap-ref-lispobj (sb-thread::current-thread-sap) tls-index)
           #-sb-thread
           (symbol-value symbol)))
    ;; This is slightly dangerous - the right thing would be
    ;; to access using SAP-REF-WORD and compare like a few lines below.
    ;; Why does #-sb-thread even check for this at all?
    (unless (eql (get-lisp-obj-address current-value) no-tls-value-marker)
      (funcall function current-value)
      (loop for start = (descriptor-sap *binding-stack-start*)
            for pointer = (descriptor-sap sb-vm::*binding-stack-pointer*)
            then (sap+ pointer (* n-word-bytes -2))
            while (sap> pointer start)
            when
            #+sb-thread (eq (sap-ref-word pointer (* n-word-bytes -1)) tls-index)
            #-sb-thread (eq (sap-ref-lispobj pointer (* n-word-bytes -1)) symbol)
            do (unless (or #+sb-thread
                           (= (sap-ref-word pointer (* n-word-bytes -2)) no-tls-value-marker))
                 (funcall function
                          (sap-ref-lispobj pointer
                                           (* n-word-bytes -2))))))))

(defun find-saved-fp-and-pc (fp)
  (block nil
    (walk-binding-stack
     'sb-alien-internals:*saved-fp*
     (lambda (x)
       (when x
         (let* ((saved-fp (descriptor-sap x))
                (caller-fp (sap-ref-sap saved-fp
                                        (sb-vm::frame-byte-offset
                                         ocfp-save-offset))))
           (when (#+stack-grows-downward-not-upward
                  sap>
                  #-stack-grows-downward-not-upward
                  sap<
                  caller-fp fp)
             (return (values caller-fp
                             (sap-ref-sap saved-fp
                                          (sb-vm::frame-byte-offset
                                           return-pc-save-offset)))))))))))
) ; end PROGN

(defun return-pc-offset-for-location (debug-fun frame)
  (declare (ignorable debug-fun frame))
  #+fp-and-pc-standard-save
  sb-c:return-pc-passing-offset
  #-fp-and-pc-standard-save
  (let ((location (frame-code-location frame)))
    (etypecase debug-fun
      (compiled-debug-fun
       (let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))
             (pc-offset (compiled-code-location-pc location)))
         (if (and (>= pc-offset (sb-c::compiled-debug-fun-lra-saved-pc c-d-f))
                  ;; it's not saved yet, and the code is in elsewhere
                  (not (and (eq (debug-fun-kind debug-fun) :external)
                            (eq (interrupted-frame-error frame) 'invalid-arg-count-error))))
             (sb-c::compiled-debug-fun-return-pc c-d-f)
             (sb-c::compiled-debug-fun-return-pc-pass c-d-f))))
      (bogus-debug-fun
       ;; No handy backend (or compiler) defined constant for this one,
       ;; so construct it here and now.
       (sb-c:make-sc+offset control-stack-sc-number
                            #-(or riscv loongarch64) lra-save-offset
                            #+(or riscv loongarch64) sb-vm::ra-save-offset)))))

(defun old-fp-offset-for-location (debug-fun frame)
  (declare (ignorable debug-fun frame))
  #+fp-and-pc-standard-save
  sb-c:old-fp-passing-offset
  #-fp-and-pc-standard-save
  (let ((location (frame-code-location frame)))
    (etypecase debug-fun
      (compiled-debug-fun
       (let ((c-d-f (compiled-debug-fun-compiler-debug-fun debug-fun))
             (pc-offset (compiled-code-location-pc location)))
         (if (and (>= pc-offset (sb-c::compiled-debug-fun-cfp-saved-pc c-d-f))
                  ;; it's not saved yet, and the code is in elsewhere
                  (not (and (eq (debug-fun-kind debug-fun) :external)
                            (eq (interrupted-frame-error frame) 'invalid-arg-count-error))))
             (sb-c::compiled-debug-fun-old-fp c-d-f)
             sb-c:old-fp-passing-offset)))
      (bogus-debug-fun
       ;; No handy backend (or compiler) defined constant for this one,
       ;; so construct it here and now.
       (sb-c:make-sc+offset control-stack-sc-number ocfp-save-offset)))))

(defun frame-saved-cfp (frame debug-fun)
  (sub-access-debug-var-slot
   (frame-pointer frame)
   (old-fp-offset-for-location debug-fun frame)
   (compiled-frame-escaped frame)))

(defun frame-saved-lra (frame debug-fun)
  (let ((lra
          (sub-access-debug-var-slot
           (frame-pointer frame)
           (return-pc-offset-for-location debug-fun frame)
           (compiled-frame-escaped frame))))
    #+c-stack-is-control-stack lra
    #-c-stack-is-control-stack (descriptor-sap lra)))

(defun (setf frame-saved-lra) (new-lra frame debug-fun)
  (sub-set-debug-var-slot
   (frame-pointer frame)
   (return-pc-offset-for-location debug-fun (frame-code-location frame))
   #+c-stack-is-control-stack new-lra
   #-c-stack-is-control-stack (%make-lisp-obj (sap-int new-lra))
   (compiled-frame-escaped frame))
  new-lra)

;;; 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
                  ((or compiled-debug-fun
                       #-(or x86 x86-64) bogus-debug-fun)
                   (compute-calling-frame
                    (descriptor-sap (frame-saved-cfp frame debug-fun))
                    (frame-saved-lra frame debug-fun)
                    frame))
                  #+(or x86 x86-64)
                  (bogus-debug-fun
                   (let ((fp (frame-pointer frame)))
                     (when (control-stack-pointer-valid-p fp)
                       (multiple-value-bind (ok ra ofp) (x86-call-context fp)
                         (if ok
                             (compute-calling-frame ofp ra frame)
                             (find-saved-frame-down fp frame)))))))))
        down)))

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

;;; This returns a frame for the one existing in time immediately
;;; prior to the frame referenced by current-fp. This is current-fp's
;;; caller or the next frame down the control stack. If there is no
;;; down frame, this returns NIL for the bottom of the stack. UP-FRAME
;;; is the up link for the resulting frame object, and it is null when
;;; we call this to get the top of the stack.
;;;
;;; The current frame contains the pointer to the temporally previous
;;; frame we want, and the current frame contains the pc at which we
;;; will continue executing upon returning to that previous frame.

(defun compute-calling-frame (caller ra up-frame &optional savedp)
  (declare (type system-area-pointer caller ra))
  (when (control-stack-pointer-valid-p caller)
    ;; First check for an escaped frame.
    (multiple-value-bind (code pc-offset escaped off-stack assembly-routine-p)
        (find-escaped-frame caller)
      (cond (code
             ;; If it's escaped it may be a function end breakpoint trap.
             (when (and (code-component-p code)
                        (eq (%code-debug-info code) :bpt-lra))
               ;; If :bpt-lra grab the real lra.
               (setq pc-offset (code-header-ref code (1+ real-lra-slot)))
               (setq code (code-header-ref code real-lra-slot))
               (aver code)))
            ((not escaped)
             (multiple-value-setq (pc-offset code)
               (compute-lra-data-from-pc ra))
             (unless code
               (setf code :foreign-function
                     pc-offset 0))))
      (let ((d-fun (case code
                     (:undefined-function
                      (make-bogus-debug-fun
                       "undefined function"))
                     (:foreign-function
                      (make-bogus-debug-fun
                       (foreign-function-backtrace-name ra)))
                     ((nil)
                      (make-bogus-debug-fun
                       "bogus stack frame"))
                     (t
                      (debug-fun-from-pc code pc-offset
                                         ;; Assembly routines share the frame
                                         ;; but still use call/return,
                                         ;; and debug-fun-from-pc will
                                         ;; match the correct location
                                         ;; if it's at the end of a
                                         ;; debug-fun
                                         (unless assembly-routine-p
                                           escaped))))))
        (make-compiled-frame caller up-frame d-fun
                             (code-location-from-pc d-fun pc-offset
                                                    escaped)
                             (if up-frame (1+ (frame-number up-frame)) 0)
                             ;; If we have an interrupt-context that's not on
                             ;; our stack at all, and we're computing the
                             ;; from from a saved FP, we're probably looking
                             ;; at an interrupted syscall.
                             (or escaped (and savedp off-stack)))))))

(defun nth-interrupt-context (n)
  (declare (muffle-conditions compiler-note))
  (declare (type (mod #.max-interrupts) n)
           (optimize (speed 3) (safety 0)))
  (let ((tls-words (ash (sb-alien:extern-alien "dynamic_values_bytes"
                                               (sb-alien:unsigned 32))
                        (- word-shift))))
    (sb-alien:sap-alien (sb-vm::current-thread-offset-sap (+ tls-words n))
                        (* os-context-t))))

;;; The special var and descriptor-sap costs a few more instructions, which isn't a big deal
;;; because nothing that uses these is performance-critical. However, x86-64 wants these
;;; pointers accessed via the thread structure for +/- sb-thread to simplify the vops.
#+(or x86-64 (and (or riscv arm64 loongarch64) sb-thread))
(progn
  (defmacro current-uwp-block-sap ()
    '(sb-vm::current-thread-offset-sap sb-vm::thread-current-unwind-protect-block-slot))
  (defmacro current-catch-block-sap ()
    '(sb-vm::current-thread-offset-sap sb-vm::thread-current-catch-block-slot)))
#-(or x86-64 (and (or riscv arm64 loongarch64) sb-thread))
(progn
  (declaim (special sb-vm::*current-unwind-protect-block* *current-catch-block*))
  (defmacro current-uwp-block-sap () '(descriptor-sap sb-vm::*current-unwind-protect-block*))
  (defmacro current-catch-block-sap () '(descriptor-sap *current-catch-block*)))

(defun catch-runaway-unwind (block)
  (declare (ignorable block))
  #-(and win32 x86) ;; uses SEH
  (let ((target (sap-ref-sap (descriptor-sap block)
                             (* unwind-block-uwp-slot n-word-bytes))))
    (loop for uwp = (current-uwp-block-sap)
          then (sap-ref-sap uwp (* unwind-block-uwp-slot n-word-bytes))
          until (zerop (sap-int uwp))
          thereis (sap= target uwp)
          finally
          (let* ((pc (sap-ref-sap (descriptor-sap block)
                                  (* unwind-block-entry-pc-slot n-word-bytes)))
                 (code (code-header-from-pc pc))
                 (fun-name
                   (and code
                        (or
                         (multiple-value-bind (offset valid) (code-pc-offset pc code)
                           (and valid
                                (let ((debug-fun (debug-fun-from-pc code offset nil)))
                                  (and (compiled-debug-fun-p debug-fun)
                                       (debug-fun-name debug-fun)))))
                         code))))
            (error 'simple-control-error
                   :format-control
                   "Attempt to RETURN-FROM a block or GO to a tag that no longer exists~@[ in ~s~]"
                   :format-arguments (list fun-name))))))

(defun code-pc-offset (pc code)
  (declare (type code-component code))
  ;; We wrap WITH-PINNED-OBJECTS around CODE, but in truth this can go wrong if the
  ;; code was transported after taking a PC and before getting here. i.e. there is
  ;; nothing to be gained by arranging that while we calculate CODE-INSTRUCTIONS
  ;; the code can't move if it already moved.
  ;; The precisely GCed backends would be a lot more correct with respect to
  ;; debug-related stuff if we just never move code that is on-stack.
  (let ((pc-offset (with-pinned-objects (code)
                     (sap- pc (code-instructions code))))
        (code-size (%code-text-size code)))
    (values pc-offset (<= 0 pc-offset code-size) code-size)))

(defun context-code-pc-offset (context code)
  (code-pc-offset (context-pc context) code))

(defun find-escaped-frame (frame-pointer)
  (declare (type system-area-pointer frame-pointer))
  (/noshow0 "entering FIND-ESCAPED-FRAME")
  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
    (let* ((context (nth-interrupt-context index))
           (cfp (int-sap (context-register context sb-vm::cfp-offset))))
      (/noshow0 "got CONTEXT")
      #+(or x86 x86-64)
      (unless (control-stack-pointer-valid-p cfp)
        (return (values nil nil nil t)))
      (when (sap= frame-pointer cfp)
        (with-code-pages-pinned (:dynamic)
          (return (escaped-frame-from-context context)))))))

(defun escaped-frame-from-context (context)
  (declare (type (sb-alien:alien (* os-context-t)) context))
  (block nil
    (let ((pc (context-pc context))
          (code (code-object-from-context context))
          assembly-routine-p)
      (/noshow0 "got CODE")
      (when (eq code sb-fasl:*assembler-routines*)
        (unless (memq (assembly-routine-name-from-pc code (code-pc-offset pc code))
                      '(sb-vm::undefined-tramp sb-vm::undefined-alien-tramp
                        sb-vm::return-values-list sb-vm::call-symbol
                        sb-vm::unwind))
          (setf assembly-routine-p t
                pc (int-sap (sb-vm::return-machine-address context))
                code (code-header-from-pc pc))))
      (when (null code)
        ;; KLUDGE: Detect undefined functions by a range-check
        ;; against the trampoline address and the following
        ;; function in the runtime.
        (return (values code 0 context nil nil)))
      (multiple-value-bind (pc-offset valid-p) (code-pc-offset pc code)
        (unless valid-p
          ;; 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 nil assembly-routine-p))))))

;;; 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-context (context)
  (declare (type (sb-alien:alien (* os-context-t)) context))
  (code-header-from-pc (context-pc context)))

;;;; frame utilities

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

;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
;;; SB-C::DEBUG-INFO and run down its FUN-MAP to get a
;;; SB-C::COMPILED-DEBUG-FUN from the PC. The result only needs to
;;; reference the COMPONENT, for function constants, and the
;;; SB-C::COMPILED-DEBUG-FUN.
(defun debug-fun-from-pc (component pc &optional (escaped t))
  (let ((info (%code-debug-info component)))
    (etypecase info
      (sb-c::compiled-debug-info
       (make-compiled-debug-fun (compiled-debug-fun-from-pc info pc escaped) component))
      ((or hash-table (cons hash-table)) ; interrupted in an assembler routine
       (let ((routine (dohash ((name pc-range) (if (listp info) (car info) info))
                        (when (<= (car pc-range) pc (cadr pc-range))
                          (return name)))))
         (make-bogus-debug-fun (cond ((not routine)
                                      "no debug information for frame")
                                     ((memq routine '(sb-vm::undefined-tramp
                                                      sb-vm::undefined-alien-tramp))
                                      "undefined function")
                                     (routine)))))
      #+ppc64 (function (make-bogus-debug-fun "trampoline"))
      ((eql :bpt-lra)
       (make-bogus-debug-fun "function end breakpoint")))))

(defun assembly-routine-name-from-pc (component pc)
  (let ((info (%code-debug-info component)))
    (typecase info
      ((or hash-table (cons hash-table))
       (dohash ((name pc-range) (if (listp info) (car info) info))
         (when (<= (car pc-range) pc (cadr pc-range))
           (return name)))))))

;;; 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 (current-catch-block-sap))
        (reversed-result nil)
        (fp (frame-pointer frame)))
    (labels ((catch-ref (slot)
               (sap-ref-lispobj catch (* slot n-word-bytes)))
             (catch-entry-offset ()
               (let* ((ra (sap-ref-sap
                           catch (* catch-block-entry-pc-slot
                                    n-word-bytes)))
                      (component #-(or x86 x86-64 arm arm64)
                                 (catch-ref catch-block-code-slot)
                                 #+(or x86 x86-64 arm arm64)
                                 (code-header-from-pc ra))
                      #+ppc64
                      (component (%make-lisp-obj (logior (ash component n-fixnum-tag-bits)
                                                         other-pointer-lowtag))))
                 (- (sap-int ra)
                    (- (get-lisp-obj-address component)
                       other-pointer-lowtag)
                    (* (code-header-words component)
                       n-word-bytes)))))
      (declare (inline catch-ref catch-entry-offset))
      (loop
         until (zerop (sap-int catch))
         finally (return (nreverse reversed-result))
         do (when (sap= fp
                        (descriptor-sap
                         (catch-ref catch-block-cfp-slot)))
              (push (cons (catch-ref catch-block-tag-slot)
                          (make-compiled-code-location
                           (catch-entry-offset) (frame-debug-fun frame)))
                    reversed-result))
           (setf catch
                 (descriptor-sap
                  (catch-ref catch-block-previous-catch-slot)))))))

;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
(defun replace-frame-catch-tag (frame old-tag new-tag)
  (let ((catch (current-catch-block-sap))
        (fp (frame-pointer frame)))
    (labels ((catch-ref (slot)
               (sap-ref-lispobj catch (* slot n-word-bytes)))
             ((setf catch-ref) (value slot)
               (setf (sap-ref-lispobj catch (* slot n-word-bytes))
                     value)))
      (declare (inline catch-ref (setf catch-ref)))
      (loop
         until (zerop (sap-int catch))
         do (when (sap= fp
                        (descriptor-sap
                         (catch-ref catch-block-cfp-slot)))
              (let ((current-tag (catch-ref catch-block-tag-slot)))
                (when (eq current-tag old-tag)
                  (setf (catch-ref catch-block-tag-slot) new-tag))))
         do (setf catch
                  (descriptor-sap
                   (catch-ref catch-block-previous-catch-slot)))))))



;;;; 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 (aref ,vars ,i)))
               ,@body))
           ,result))))

;;; Compute byte offset of FUNCTION into CODE-INSTRUCTIONS of its code,
;;; which is the byte offset from the base of its code
;;; minus the number of bytes in the boxed portion of its code header.
(defun function-start-pc-offset (function)
  (let* ((fun (%fun-fun function))
         (code (fun-code-header fun)))
    (- (%fun-code-offset fun)
       (* (code-header-words code) n-word-bytes))))

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

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

(sb-impl:define-thread-local *current-internal-error* nil)
(defun interrupted-frame-error (frame &aux (err *current-internal-error*))
  (when (and err
             (compiled-frame-p frame)
             (compiled-frame-escaped frame)
             (array-in-bounds-p sb-c:+backend-internal-errors+ err))
    (cadr (svref sb-c:+backend-internal-errors+ err))))

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

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

;;; Return a DEBUG-FUN that represents debug information for FUN.
(defun fun-debug-fun (fun &key local-name)
  (declare (type function fun))
  (let ((simple-fun (%fun-fun fun)))
    (let* ((name (or local-name (%simple-fun-name simple-fun)))
           (component (fun-code-header simple-fun))
           (res (find-if
                 (lambda (x)
                   (and (sb-c::compiled-debug-fun-p x)
                        (equal (sb-c::compiled-debug-fun-name x) name)
                        (eq (sb-c::compiled-debug-fun-kind x) nil)))
                 (get-debug-info-fun-map
                  (%code-debug-info component)))))
      (cond (res
             (make-compiled-debug-fun res component))
            ((null local-name)
             ;; 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
                                (function-start-pc-offset simple-fun)))))))

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

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

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

;;; Return the MORE-CONTEXT and MORE-COUNT vars of a DEBUG-FUN.
(defun debug-fun-more-args (debug-fun)
  (dolist (spec (debug-fun-lambda-list debug-fun) nil)
    (when (and (listp spec)
               (eq (first spec) :more))
      (return (values (second spec) (third spec))))))

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

;;; A compact "vector" is either the element itself or a vector
(defun compact-vector-ref (vector index)
  (declare (index index))
  (typecase vector
    (simple-vector
     (svref vector index))
    (string
     (aver (zerop index))
     vector)
    (vector
     (aref vector index))
    (t
     (aver (zerop index))
     vector)))

(defun compact-vector-length (vector)
  (typecase vector
    (string
     1)
    (vector
     (length vector))
    (t
     1)))

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

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

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

;;; The argument is a debug internals structure. This returns the
;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
;;; return the blocks.
(defun debug-fun-debug-blocks (debug-fun)
  (let ((blocks (debug-fun-blocks debug-fun)))
    (when (eq blocks :unparsed)
      (let* ((new (parse-debug-blocks debug-fun))
             (old (cas (debug-fun-blocks debug-fun) :unparsed new)))
        (setq blocks (if (eq old :unparsed) new old))))
    (or blocks
        (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
     (let ((parsed (parse-compiled-debug-blocks debug-fun)))
       (if (equalp parsed #())
           (debug-signal 'no-debug-blocks :debug-fun debug-fun)
           parsed)))
    (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
           (let ((blocks (sb-c::compiled-debug-fun-blocks compiler-debug-fun)))
             (if (null blocks)
                 (return-from parse-compiled-debug-blocks nil)
                 blocks)))
         ;; 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))
         (result-blocks))
    (unless blocks
      (return-from parse-compiled-debug-blocks nil))
    (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
      (let ((i 0)
            (len (length blocks))
            (last-pc 0)
            prev-form-number
            prev-live)
        (loop
         (when (>= i len) (return))
         (let ((succ-and-flags (sb-c::read-var-integerf blocks i))
               (successors nil)
               locations)
           (declare (list successors))
           (dotimes (k (ash succ-and-flags
                            (- sb-c::compiled-debug-block-nsucc-shift)))
             (push (sb-c::read-var-integerf blocks i) successors))
           (dotimes (k (sb-c:read-var-integerf blocks i))
             (let* ((flags (aref+ blocks i))
                    (kind (svref sb-c::+compiled-code-location-kinds+
                                 (ldb sb-c::compiled-code-location-kind-byte
                                      flags)))
                    (pc (+ last-pc
                           (sb-c:read-var-integerf blocks i)))
                    (tlf-offset (or tlf-number
                                    (sb-c:read-var-integerf blocks i)))
                    (equal-live (logtest sb-c::compiled-code-location-equal-live flags))
                    (form-number
                      (cond ((logtest sb-c::compiled-code-location-zero-form-number flags)
                             0)
                            ((and equal-live
                                  (logtest sb-c::compiled-code-location-live flags))
                             prev-form-number)
                            (t
                             (setf prev-form-number
                                   (sb-c:read-var-integerf blocks i)))))
                    (live-set
                      (cond (equal-live
                             prev-live)
                            ((logtest sb-c::compiled-code-location-live flags)
                             (setf prev-live
                                   (sb-c:read-packed-bit-vector live-set-len blocks i)))
                            (t
                             (make-array (* live-set-len 8) :element-type 'bit))))
                    (step-info
                      (if (logtest sb-c::compiled-code-location-stepping flags)
                          (sb-c:read-var-string blocks i)
                          ""))
                    (context
                      (and (logtest sb-c::compiled-code-location-context flags)
                           (compact-vector-ref (sb-c::compiled-debug-info-contexts
                                                (%code-debug-info (compiled-debug-fun-component debug-fun)))
                                               (sb-c:read-var-integerf blocks i)))))
               (push (make-known-code-location
                      pc debug-fun tlf-offset
                      form-number live-set kind
                      step-info context)
                     locations)
               (setf last-pc pc)))
           (let* ((locations (coerce (nreverse locations) 'simple-vector))
                  (block (make-compiled-debug-block
                          locations successors
                          (not (zerop (logand
                                       sb-c::compiled-debug-block-elsewhere-p
                                       succ-and-flags))))))
             (push block result-blocks)
             (dotimes (k (length locations))
               (setf (code-location-%debug-block (svref locations k))
                     block))))))
      (let ((res (coerce (nreverse result-blocks) 'simple-vector)))
        (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))))

;;; 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 "~D" (1- len))))) ; use base 10 in both places!
    (dotimes (i len)
      (setf (compiled-debug-var-name (svref vars i))
            (possibly-base-stringize-to-heap (format nil "ARG-~V,'0D" width i))))))

;;; 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))
         (default-package (sb-c::compiled-debug-info-package
                           (compiled-debug-fun-debug-info debug-fun)))
         (args-minimal (eq (sb-c::compiled-debug-fun-arguments cdebug-fun)
                           :minimal)))
    (unless packed-vars
      (return-from parse-compiled-debug-vars nil))
    (when (zerop (compact-vector-length packed-vars))
      ;; Return a simple-vector not whatever packed-vars may be.
      (return-from parse-compiled-debug-vars '#()))
    (let ((i 0)
          (id 0)
          (len (length packed-vars))
          (buffer (make-array 0 :fill-pointer 0 :adjustable t))
          prev-name)
      (loop
        ;; The routines in the "SB-C" package are macros that advance the
        ;; index.
        (let* ((flags (prog1 (aref packed-vars i) (incf i)))
               (minimal (logtest sb-c::compiled-debug-var-minimal-p flags))
               (deleted (logtest sb-c::compiled-debug-var-deleted-p flags))
               (name (cond (minimal "")
                           ((logtest sb-c::compiled-debug-var-same-name-p flags)
                            prev-name)
                           (t (sb-c::read-var-string packed-vars i))))
               (package (cond
                          (minimal default-package)
                          ((logtest sb-c::compiled-debug-var-packaged
                                    flags)
                           (find-package (sb-c::read-var-string packed-vars i)))
                          ((logtest sb-c::compiled-debug-var-uninterned
                                    flags)
                           nil)
                          (t
                           default-package)))
               (sc+offset
                 (if deleted 0 (sb-c::read-var-integerf packed-vars i)))
               (save-sc+offset
                 (if (logtest sb-c::compiled-debug-var-save-loc-p flags)
                     (sb-c::read-var-integerf packed-vars i)
                     nil))
               (indirect-sc+offset
                 (if (logtest sb-c::compiled-debug-var-indirect-p flags)
                     (sb-c::read-var-integerf packed-vars i)
                     nil)))
          (aver (not (and args-minimal (not minimal))))
          (cond ((and prev-name (string= prev-name name))
                 (incf id))
                (t
                 (setf id 0
                       prev-name name)))
          (vector-push-extend
           (make-compiled-debug-var
            name package id
            (logtest sb-c::compiled-debug-var-environment-live flags)
            sc+offset save-sc+offset
            indirect-sc+offset)
           buffer))
        (when (>= i len) (return)))
      (let ((result (coerce buffer 'simple-vector)))
        (when args-minimal
          (assign-minimal-var-names result))
        result))))

;;; 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)
        (let* ((new (etypecase debug-fun
                      (compiled-debug-fun
                       (parse-compiled-debug-vars debug-fun))
                      (bogus-debug-fun nil)))
               (old (cas (debug-fun-%debug-vars debug-fun) :unparsed new)))
          (if (eq old :unparsed) new old))
        vars)))

;;; 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)
  ;; This file could not be slammed if COERCE is inlined because it thinks :UNPARSED
  ;; (i.e. not a sequence) can be returned as the DEBUG-VARS. But it can't, and a running
  ;; image was able to recompile the function with no decl and no warning. What's up with that?
  (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 (ensure-heap-list (coerce (debug-fun-debug-vars debug-fun) 'list))
               t))
      (t
       (values (parse-compiled-debug-fun-lambda-list/args-available
                (debug-fun-debug-vars debug-fun) args)
               t)))))

;;;; unpacking packed debug functions

;;; sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUN-MAP
(defmacro make-uncompacted-debug-fun ()
  '(sb-c::make-compiled-debug-fun
    :name (if (logtest flags sb-c::packed-debug-fun-previous-name)
              name
              (setf name
                    (compact-vector-ref
                     (sb-c::compiled-debug-info-contexts info)
                     (sb-c::read-var-integerf map i))))
    :kind (svref sb-c::packed-debug-fun-kinds
                 (ldb sb-c::packed-debug-fun-kind-byte options))
    :vars
    (when vars-p
      (let ((len (sb-c::read-var-integerf map i)))
        (prog1 (subseq map i (+ i len))
          (incf i len))))
    :blocks
    (when blocks-p
      (let* ((len (sb-c::read-var-integerf map i))
             (blocks
               (prog1 (subseq map i (+ i len))
                 (incf i len))))
        blocks))
    :tlf-number
    (when (logtest sb-c::packed-debug-fun-tlf-number-bit flags)
      (sb-c::read-var-integerf map i))
    :arguments
    (when vars-p
      (if (logtest sb-c::packed-debug-fun-non-minimal-arguments-bit flags)
          (let ((len (sb-c::read-var-integerf map i))
                (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
            (dotimes (idx len)
              (let ((arg (sb-c::read-var-integerf map i)))
                (case arg
                  (#.sb-c::packed-debug-fun-arg-deleted
                   (vector-push-extend 'sb-c::deleted buffer))
                  (#.sb-c::packed-debug-fun-arg-supplied-p
                   (vector-push-extend 'sb-c::supplied-p buffer))
                  (#.sb-c::packed-debug-fun-arg-optional
                   (vector-push-extend 'sb-c::optional buffer))
                  (#.sb-c::packed-debug-fun-arg-rest
                   (vector-push-extend 'sb-c::rest buffer))
                  (#.sb-c::packed-debug-fun-arg-more
                   (vector-push-extend 'sb-c::more buffer))
                  (#.sb-c::packed-debug-fun-key-arg-keyword
                   (vector-push-extend (intern (sb-c::read-var-string map i)
                                               *keyword-package*)
                                       buffer))
                  (#.sb-c::packed-debug-fun-key-arg-packaged
                   (without-package-locks
                     (vector-push-extend (intern (sb-c::read-var-string map i)
                                                 (sb-c::read-var-string map i))
                                         buffer)))
                  (#.sb-c::packed-debug-fun-key-arg-uninterned
                   (vector-push-extend (make-symbol (sb-c::read-var-string map i))
                                       buffer))
                  (otherwise
                   (vector-push-extend (- arg sb-c::packed-debug-fun-arg-index-offset)
                                       buffer)))))
            (coerce buffer 'simple-vector))
          :minimal))
    :returns
    (ecase (ldb sb-c::packed-debug-fun-returns-byte options)
      (#.sb-c::packed-debug-fun-returns-standard
       :standard)
      (#.sb-c::packed-debug-fun-returns-fixed
       :fixed)
      (#.sb-c::packed-debug-fun-returns-specified
       (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
         (dotimes (idx (sb-c::read-var-integerf map i))
           (vector-push-extend (sb-c::read-var-integerf map i) buffer))
         (coerce buffer 'simple-vector))))
    #-fp-and-pc-standard-save :return-pc
    #-fp-and-pc-standard-save (sb-c::read-var-integerf map i)
    #-fp-and-pc-standard-save :return-pc-pass
    #-fp-and-pc-standard-save (sb-c::read-var-integerf map i)
    #-fp-and-pc-standard-save :old-fp
    #-fp-and-pc-standard-save (sb-c::read-var-integerf map i)
    #-fp-and-pc-standard-save :lra-saved-pc
    #-fp-and-pc-standard-save (sb-c::read-var-integerf map i)
    #-fp-and-pc-standard-save :cfp-saved-pc
    #-fp-and-pc-standard-save (sb-c::read-var-integerf map i)
    :closure-save
    (when (logtest flags sb-c::packed-debug-fun-closure-save-loc-bit)
      (sb-c::read-var-integerf map i))
    #+unwind-to-frame-and-call-vop :bsp-save
    #+unwind-to-frame-and-call-vop
    (when (logtest flags sb-c::packed-debug-fun-bsp-save-loc-bit)
      (sb-c::read-var-integerf map i))
    :start-pc
    (progn
      (setq code-start-pc (+ code-start-pc (sb-c::read-var-integerf map i)))
      (+ code-start-pc (sb-c::read-var-integerf map i)))
    :elsewhere-pc
    (setq elsewhere-pc (+ elsewhere-pc (sb-c::read-var-integerf map i)))))

;;; Return a normal function map derived from a packed debug info
;;; function map. This involves looping parsing PACKED-DEBUG-FUNs and
;;; then building a vector out of them.
(defun uncompact-fun-map (info)
  (declare (type sb-c::compiled-debug-info info))
  (let* ((map (sb-c::decompress (sb-c::compiled-debug-info-fun-map info)))
         (i 0)
         (len (length map))
         (code-start-pc 0)
         (elsewhere-pc 0)
         (name (sb-c::compiled-debug-info-name info)))
    (collect ((res))
      (loop
        (when (= i len) (return))
        (let* ((options (prog1 (aref map i) (incf i)))
               (flags (prog1 (aref map i) (incf i)))
               (vars-p (logtest flags
                                sb-c::packed-debug-fun-variables-bit))
               (blocks-p (logtest flags
                                  sb-c::packed-debug-fun-blocks-bit))
               (dfun (make-uncompacted-debug-fun)))
          (res code-start-pc)
          (res dfun)))

      (coerce (cdr (res)) 'simple-vector))))

;;; a map from packed DEBUG-INFO function maps to unpacked
;;; versions thereof
(define-load-time-global *uncompacted-fun-maps* nil)

;;; Return a FUN-MAP for a given COMPILED-DEBUG-INFO object. If the
;;; info is packed, and has not been parsed, then parse it.
(defun get-debug-info-fun-map (info)
  (declare (type sb-c::compiled-debug-info info))
  (with-weak-cache (ht *uncompacted-fun-maps*)
    (or (gethash info ht)
        (setf (gethash info ht) (uncompact-fun-map info)))))

;;;; CODE-LOCATIONs

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

;;; Return the DEBUG-BLOCK containing code-location if it is available.
;;; Some debug policies inhibit debug-block information, and if none
;;; is available, then this signals a NO-DEBUG-BLOCKS condition.
(defun code-location-debug-block (basic-code-location)
  (let ((block (code-location-%debug-block basic-code-location)))
    (if (eq block :unparsed)
        (etypecase basic-code-location
          (compiled-code-location
           (compute-compiled-code-location-debug-block basic-code-location))
          ;; (There used to be more cases back before sbcl-0.7.0, when
          ;; we did special tricks to debug the IR1 interpreter.)
          )
        block)))

;;; Store and return BASIC-CODE-LOCATION's debug-block. We determines
;;; the correct one using the code-location's pc. We use
;;; DEBUG-FUN-DEBUG-BLOCKS to return the cached block information
;;; or signal a NO-DEBUG-BLOCKS condition. The blocks are sorted by
;;; their first code-location's pc, in ascending order. Therefore, as
;;; soon as we find a block that starts with a pc greater than
;;; basic-code-location's pc, we know the previous block contains the
;;; pc. If we get to the last block, then the code-location is either
;;; in the second to last block or the last block, and we have to be
;;; careful in determining this since the last block could be code at
;;; the end of the function. We have to check for the last block being
;;; code first in order to see how to compare the code-location's pc.
(defun compute-compiled-code-location-debug-block (basic-code-location)
  (let* ((pc (compiled-code-location-pc basic-code-location))
         (debug-fun (code-location-debug-fun
                          basic-code-location))
         (blocks (debug-fun-debug-blocks debug-fun))
         (len (length blocks)))
    (declare (simple-vector blocks))
    (setf (code-location-%debug-block basic-code-location)
          (if (= len 1)
              (svref blocks 0)
              (do ((i 1 (1+ i))
                   (end (1- len)))
                  ((= i end)
                   (let ((last (svref blocks end)))
                     (cond
                      ((debug-block-elsewhere-p last)
                       (if (< pc
                              (sb-c::compiled-debug-fun-elsewhere-pc
                               (compiled-debug-fun-compiler-debug-fun
                                debug-fun)))
                           (svref blocks (1- end))
                           last))
                      ((< pc
                          (compiled-code-location-pc
                           (svref (compiled-debug-block-code-locations last)
                                  0)))
                       (svref blocks (1- end)))
                      (t last))))
                (declare (type index i end))
                (when (< pc
                         (compiled-code-location-pc
                          (svref (compiled-debug-block-code-locations
                                  (svref blocks i))
                                 0)))
                  (return (svref blocks (1- i)))))))))

;;; Return the CODE-LOCATION's DEBUG-SOURCE.
(defun code-location-debug-source (code-location)
  (let ((info (compiled-debug-fun-debug-info
               (code-location-debug-fun code-location))))
    (or (sb-c::debug-info-source info)
        (debug-signal 'no-debug-blocks :debug-fun
                      (code-location-debug-fun code-location)))))

;;; Returns the number of top level forms before the one containing
;;; CODE-LOCATION as seen by the compiler in some compilation unit. (A
;;; compilation unit is not necessarily a single file, see the section
;;; on debug-sources.)
(defun code-location-toplevel-form-offset (code-location)
  (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)))
        (fill-in-code-location code-location)
        (cond ((eq live-set :unparsed)
               (unless (fill-in-code-location code-location)
                 ;; This check should be unnecessary. We're missing
                 ;; debug info the compiler should have dumped.
                 ;;
                 ;; FIXME: This error and comment happen over and over again.
                 ;; Make them a shared function.
                 (bug "unknown code location"))
               (compiled-code-location-%live-set code-location))
              (t live-set)))))

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

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

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

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

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

;;; Return the symbol from interning DEBUG-VAR-NAME in the package DEBUG-VAR-PACKAGE.
(defun debug-var-symbol (debug-var)
  (let ((package (debug-var-package debug-var)))
    (if package
        (without-package-locks
          (intern (debug-var-name debug-var) package))
        (make-symbol (debug-var-name debug-var)))))

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

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

;;; a helper function for working with possibly-invalid values:
;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
;;;
;;; (Such values can arise in registers on machines with conservative
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
;;;
;;; NOTE for precisely GC'd platforms:
;;; this function is not GC-safe in the slightest when creating
;;; a pointer to an object in dynamic space.  If a GC occurs between
;;; the start of the call to VALID-TAGGED-POINTER-P and the end of
;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
;;; is constructed.  This can happen on CHENEYGC if an asynchronous
;;; interrupt occurs within the window.  This can happen on GENCGC
;;; under the same circumstances, but is more likely due to all GENCGC
;;; platforms supporting threaded operation.

;;; On x86oids we are able to eliminate the vulnerable window
;;; by conservatively pinning an object (i.e. storing a bit pattern
;;; that would be the address of an object, assuming it is an object)
;;; whether or not there is actually an object to pin.
;;; To see the GC-safeness problem without WITH-PINNED-OBJECTS, consider
;;; the following sequence of events, and suppose for the sake of argument
;;; that tagged pointer #x104003 is valid at the moment of call.
;;; Assume 1 low zero bit in a fixnum, so the register contains #x208006.
;;; 1. move-to-word: arg-passing-reg <- #x104003 ; implicit pin
;;;    /* at this point the fixnum whose representation is #x208006
;;;       was spilled to stack prior to call, *and* the descriptor bits
;;;       are also in a register. The fixnum pins nothing as it does not
;;;       have Lisp pointer nature. The passing reg pins something */
;;; 2. call C : will return true, and assume that the arg-passing-reg
;;;             gets clobbered.  The return-reg contains 1 for true.
;;; 3. -- GC triggered by other thread
;;;       transport the object that was #x104003 to somewhere new
;;; 4. now %MAKE-LISP-OBJ creates a bogus pointer.
;;; By preemptively using (WITH-PINNED-OBJECTS ((%MAKE-LISP-OBJ)))
;;; we ensure that the bit pattern #x104003 is on the stack for root scan.
;;; Unfortunately, WITH-PINNED-OBJECTS can not be used with precise GC
;;; because random trash is not allowed in a descriptor register.
;;; If we really wanted to make this safe for precise GC, we could use a
;;; new special binding, something like *PINNED-WORDS* which would be a list
;;; of INTEGERs, each of which, _if_ its bit pattern is that of an object
;;; descriptor, would pin the corresponding object. On the lisp side
;;; the cons cell in the list would hold the supplied VAL directly.
(defun make-lisp-obj (val &optional (errorp t))
  (if (or
       ;; fixnum
       (zerop (logand val fixnum-tag-mask))
       ;; immediate single float, 64-bit only
       #+64-bit
       (= (logand val #xff) single-float-widetag)
       ;; character
       (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
            (= (logand val #xff) character-widetag)) ; char tag
       ;; unbound marker
       (= val unbound-marker-widetag))
      (values (%make-lisp-obj val) t)
      ;; To mitigate the danger of GC running in between testing pointer
      ;; validity and returning the object, we must pin a potentially
      ;; non-object which is harmless on the conservative backends
      ;; but harmful on precise GC.
      (macrolet ((possibly-pin (form)
                   #+(or x86 x86-64)
                   `(with-pinned-objects ((%make-lisp-obj val)) ,form)
                   #-(or x86 x86-64) form))
        (let ((obj (if (and (typep val 'word) (is-lisp-pointer val))
                       (possibly-pin
                        (if (= (valid-tagged-pointer-p (int-sap val)) 0)
                            0
                            (%make-lisp-obj val)))
                       0)))
          (cond ((not (eql obj 0)) (values obj t))
                (errorp
                 (error "~S is not a valid argument to ~S"
                        val 'make-lisp-obj))
                (t
                 (values (make-unprintable-object
                          (format nil "invalid object #x~X" val))
                         nil)))))))

(defun sub-access-debug-var-slot (fp sc+offset &optional escaped integer-float)
  ;; NOTE: The long-float support in here is obviously decayed.  When
  ;; the x86oid and non-x86oid versions of this function were unified,
  ;; the behavior of long-floats was preserved, which only served to
  ;; highlight its brokenness.
  (macrolet ((with-escaped-value ((var) &body forms)
               `(if escaped
                    (let ((,var (context-register escaped
                                 (sb-c:sc+offset-offset sc+offset))))
                      ,@forms)
                    :invalid-value-for-unescaped-register-storage))
             (escaped-boxed-value ()
               `(if escaped
                    (boxed-context-register
                     escaped
                     (sb-c:sc+offset-offset sc+offset))
                    :invalid-value-for-unescaped-register-storage))
             (escaped-float-value (format)
               `(if escaped
                    (context-float-register escaped
                     (sb-c:sc+offset-offset sc+offset) ',format integer-float)
                    :invalid-value-for-unescaped-register-storage))
             (with-nfp ((var) &body body)
               ;; x86oids have no separate number stack, so dummy it
               ;; up for them. ARM64 Windows is similar - use control stack pointer.
               #+c-stack-is-control-stack
               `(let ((,var fp))
                  ,@body)
               #-c-stack-is-control-stack
               `(let ((,var (if escaped
                                (int-sap
                                 (context-register escaped sb-vm::nfp-offset))
                                (sap-ref-sap fp (* nfp-save-offset n-word-bytes)))))
                  ,@body))
             (number-stack-offset (&optional (offset 0))
               `(+ #+c-stack-is-control-stack
                   (sb-vm::frame-byte-offset (sb-c:sc+offset-offset sc+offset))
                   #-c-stack-is-control-stack
                   (* (sb-c:sc+offset-offset sc+offset) n-word-bytes)
                   ,offset)))
    (ecase (sb-c:sc+offset-scn sc+offset)
      ((#.any-reg-sc-number
        #.descriptor-reg-sc-number)
       (escaped-boxed-value))
      (#.character-reg-sc-number
       (with-escaped-value (val)
         (code-char val)))
      (#.sap-reg-sc-number
       (with-escaped-value (val)
         (int-sap val)))
      (#.signed-reg-sc-number
       (with-escaped-value (val)
         (if (logbitp (1- n-word-bits) val)
             (logior val (ash -1 n-word-bits))
             val)))
      ((#.unsigned-reg-sc-number #-c-stack-is-control-stack #.non-descriptor-reg-sc-number)
       (with-escaped-value (val)
         val))
      #+sb-simd-pack
      ((#.sb-vm::sse-reg-sc-number #.sb-vm::int-sse-reg-sc-number)
       (escaped-float-value simd-pack-int))
      #+sb-simd-pack
      ((#.sb-vm::single-sse-reg-sc-number)
       (escaped-float-value simd-pack-single))
      #+sb-simd-pack
      ((#.sb-vm::double-sse-reg-sc-number)
       (escaped-float-value simd-pack-double))
      #+sb-simd-pack
      ((#.sb-vm::int-sse-stack-sc-number)
       (with-nfp (nfp)
         (%make-simd-pack-ub64
          (sap-ref-64 nfp (number-stack-offset 0))
          (sap-ref-64 nfp (number-stack-offset 8)))))
      #+sb-simd-pack
      ((#.sb-vm::single-sse-stack-sc-number)
       (with-nfp (nfp)
         (%make-simd-pack-single
          (sap-ref-single nfp (number-stack-offset 0))
          (sap-ref-single nfp (number-stack-offset 4))
          (sap-ref-single nfp (number-stack-offset 8))
          (sap-ref-single nfp (number-stack-offset 12)))))
      #+sb-simd-pack
      ((#.sb-vm::double-sse-stack-sc-number)
       (with-nfp (nfp)
         (%make-simd-pack-double
          (sap-ref-double nfp (number-stack-offset 0))
          (sap-ref-double nfp (number-stack-offset 8)))))
      #+sb-simd-pack-256
      ((#.sb-vm::ymm-reg-sc-number #.sb-vm::int-avx2-reg-sc-number)
       (escaped-float-value simd-pack-256-int))
      #+sb-simd-pack-256
      ((#.sb-vm::single-avx2-reg-sc-number)
       (escaped-float-value simd-pack-256-single))
      #+sb-simd-pack-256
      ((#.sb-vm::double-avx2-reg-sc-number)
       (escaped-float-value simd-pack-256-double))
      #+sb-simd-pack-256
      ((#.sb-vm::int-avx2-stack-sc-number)
       (with-nfp (nfp)
         (%make-simd-pack-256-ub64
          (sap-ref-64 nfp (number-stack-offset 0))
          (sap-ref-64 nfp (number-stack-offset 8))
          (sap-ref-64 nfp (number-stack-offset 16))
          (sap-ref-64 nfp (number-stack-offset 24)))))
      #+sb-simd-pack-256
      ((#.sb-vm::single-avx2-stack-sc-number)
       (with-nfp (nfp)
         (%make-simd-pack-256-single
          (sap-ref-single nfp (number-stack-offset 0))
          (sap-ref-single nfp (number-stack-offset 4))
          (sap-ref-single nfp (number-stack-offset 8))
          (sap-ref-single nfp (number-stack-offset 12))
          (sap-ref-single nfp (number-stack-offset 16))
          (sap-ref-single nfp (number-stack-offset 20))
          (sap-ref-single nfp (number-stack-offset 24))
          (sap-ref-single nfp (number-stack-offset 28)))))
      #+sb-simd-pack-256
      ((#.sb-vm::double-avx2-stack-sc-number)
       (with-nfp (nfp)
         (%make-simd-pack-256-double
          (sap-ref-double nfp (number-stack-offset 0))
          (sap-ref-double nfp (number-stack-offset 8))
          (sap-ref-double nfp (number-stack-offset 16))
          (sap-ref-double nfp (number-stack-offset 24)))))
      (#.single-reg-sc-number
       (escaped-float-value single-float))
      (#.double-reg-sc-number
       (escaped-float-value double-float))
      #+long-float
      (#.long-reg-sc-number
       (escaped-float-value long-float))
      (#.complex-single-reg-sc-number
       (escaped-float-value complex-single-float))
      (#.complex-double-reg-sc-number
       (escaped-float-value complex-double-float))
      #+long-float
      (#.complex-long-reg-sc-number
       (escaped-float-value sb-kernel::complex-long-float))
      (#.single-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-single nfp (number-stack-offset))))
      (#.double-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-double nfp (number-stack-offset))))
      #+long-float
      (#.long-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-long nfp (number-stack-offset))))
      (#.complex-single-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-single nfp (number-stack-offset))
          (sap-ref-single nfp (number-stack-offset 4)))))
      (#.complex-double-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-double nfp (number-stack-offset))
          (sap-ref-double nfp (number-stack-offset 8)))))
      #+long-float
      (#.complex-long-stack-sc-number
       (with-nfp (nfp)
         (complex
          (sap-ref-long nfp (number-stack-offset))
          (sap-ref-long nfp
                        (number-stack-offset #+sparc 4
                                             #+(or x86 x86-64) 3)))))
      (#.control-stack-sc-number
       (stack-ref fp (sb-c:sc+offset-offset sc+offset)))
      (#.character-stack-sc-number
       (with-nfp (nfp)
         (code-char (sap-ref-word nfp (number-stack-offset)))))
      (#.unsigned-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-word nfp (number-stack-offset))))
      (#.signed-stack-sc-number
       (with-nfp (nfp)
         (signed-sap-ref-word nfp (number-stack-offset))))
      (#.sap-stack-sc-number
       (with-nfp (nfp)
         (sap-ref-sap nfp (number-stack-offset))))
      (#.constant-sc-number
       (if escaped
           (let ((code (code-header-from-pc (context-pc escaped))))
             (if code
                 (code-header-ref code (sb-c:sc+offset-offset sc+offset))
                 :invalid-code-object-at-pc))
           :invalid-value-for-unescaped-register-storage))
      (#.immediate-sc-number
       (sb-c:sc+offset-offset sc+offset))
      (#.sb-vm::negative-immediate-sc-number
       (- (sb-c:sc+offset-offset sc+offset))))))

;;; 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 (setf debug-var-value) (new-value debug-var frame)
  (declare (compiled-frame frame))
  (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
    (if (indirect-value-cell-p old-value)
        (value-cell-set old-value new-value)
        (set-compiled-debug-var-slot debug-var frame new-value)))
  new-value)

;;; This stores VALUE for the variable represented by debug-var
;;; relative to the frame. This assumes the location directly contains
;;; the variable's value; that is, there is no indirect value cell
;;; currently there in case the variable is both closed over and set.
(defun set-compiled-debug-var-slot (debug-var frame value)
  (let ((escaped (compiled-frame-escaped frame)))
    (if escaped
        (sub-set-debug-var-slot (frame-pointer frame)
                                (compiled-debug-var-sc+offset debug-var)
                                value escaped)
        (sub-set-debug-var-slot
         (frame-pointer frame)
         (or (compiled-debug-var-save-sc+offset debug-var)
             (compiled-debug-var-sc+offset debug-var))
         value))))

(defun sub-set-debug-var-slot (fp sc+offset value &optional escaped)
  ;; Like sub-access-debug-var-slot, this is the unification of two
  ;; divergent copy-pasted functions.  The astute reviewer will notice
  ;; that long-floats are messed up here as well, that x86oids
  ;; apparently don't support accessing float values that are in
  ;; registers, and that non-x86oids store the real part of a float
  ;; for both the real and imaginary parts of a complex on the stack
  ;; (but not in registers, oddly enough).  Some research has
  ;; indicated that the different forms of THE used for validating the
  ;; type of complex float components between x86oid and non-x86oid
  ;; systems are only significant in the case of using a non-complex
  ;; number as input (as the non-x86oid case effectively converts
  ;; non-complex numbers to complex ones and the x86oid case will
  ;; error out).  That said, the error message from entering a value
  ;; of the wrong type will be slightly easier to understand on x86oid
  ;; systems.
  (macrolet ((set-escaped-value (val)
               `(if escaped
                    (setf (context-register escaped
                           (sb-c:sc+offset-offset sc+offset))
                          ,val)
                    value))
             (set-escaped-boxed-value (val)
               `(if escaped
                    (setf (boxed-context-register
                           escaped
                           (sb-c:sc+offset-offset sc+offset))
                          ,val)
                    value))
             (set-escaped-float-value (format val)
               `(if escaped
                    (setf (context-float-register escaped
                           (sb-c:sc+offset-offset sc+offset)
                           ',format)
                          ,val)
                    value))
             (with-nfp ((var) &body body)
               ;; x86oids have no separate number stack, so dummy it
               ;; up for them.
               #+c-stack-is-control-stack
               `(let ((,var fp))
                  ,@body)
               #-c-stack-is-control-stack
               `(let ((,var (if escaped
                                (int-sap (context-register escaped sb-vm::nfp-offset))
                                (sap-ref-sap fp (* nfp-save-offset n-word-bytes)))))
                  ,@body))
             (number-stack-offset (&optional (offset 0))
               `(+ #+c-stack-is-control-stack
                   (sb-vm::frame-byte-offset (sb-c:sc+offset-offset sc+offset))
                   #-c-stack-is-control-stack
                   (* (sb-c:sc+offset-offset sc+offset) n-word-bytes)
                   ,offset)))
    (ecase (sb-c:sc+offset-scn sc+offset)
      ((#.any-reg-sc-number
        #.descriptor-reg-sc-number)
       (set-escaped-boxed-value value))
      (#.character-reg-sc-number
       (set-escaped-value (char-code value)))
      (#.sap-reg-sc-number
       (set-escaped-value (sap-int value)))
      (#.signed-reg-sc-number
       (set-escaped-value (logand value most-positive-word)))
      (#.unsigned-reg-sc-number
       (set-escaped-value value))
      #-c-stack-is-control-stack
      (#.non-descriptor-reg-sc-number
       (error "Local non-descriptor register access?"))
      #+sb-simd-pack
      ((#.sb-vm::sse-reg-sc-number #.sb-vm::int-sse-reg-sc-number)
       (set-escaped-float-value simd-pack-int value))
      #+sb-simd-pack
      ((#.sb-vm::single-sse-reg-sc-number)
       (set-escaped-float-value simd-pack-single value))
      #+sb-simd-pack
      ((#.sb-vm::double-sse-reg-sc-number)
       (set-escaped-float-value simd-pack-double value))
      #+sb-simd-pack
      ((#.sb-vm::int-sse-stack-sc-number)
       (multiple-value-bind (a b) (%simd-pack-ub64s value)
         (with-nfp (nfp)
           (setf (sap-ref-64 nfp (number-stack-offset 0)) a
                 (sap-ref-64 nfp (number-stack-offset 8)) b))))
      #+sb-simd-pack
      ((#.sb-vm::single-sse-stack-sc-number)
       (multiple-value-bind (a b c d) (%simd-pack-singles value)
         (with-nfp (nfp)
           (setf (sap-ref-single nfp (number-stack-offset 0)) a
                 (sap-ref-single nfp (number-stack-offset 4)) b
                 (sap-ref-single nfp (number-stack-offset 8)) c
                 (sap-ref-single nfp (number-stack-offset 12)) d))))
      #+sb-simd-pack
      ((#.sb-vm::double-sse-stack-sc-number)
       (multiple-value-bind (a b) (%simd-pack-doubles value)
         (with-nfp (nfp)
           (setf (sap-ref-double nfp (number-stack-offset 0)) a
                 (sap-ref-double nfp (number-stack-offset 8)) b))))
      #+sb-simd-pack-256
      ((#.sb-vm::ymm-reg-sc-number #.sb-vm::int-avx2-reg-sc-number)
       (set-escaped-float-value simd-pack-256-int value))
      #+sb-simd-pack-256
      ((#.sb-vm::single-avx2-reg-sc-number)
       (set-escaped-float-value simd-pack-256-single value))
      #+sb-simd-pack-256
      ((#.sb-vm::double-avx2-reg-sc-number)
       (set-escaped-float-value simd-pack-256-double value))
      #+sb-simd-pack-256
      ((#.sb-vm::int-avx2-stack-sc-number)
       (with-nfp (nfp)
         (multiple-value-bind (a b c d) (%simd-pack-256-ub64s value)
           (setf (sap-ref-64 nfp (number-stack-offset 0)) a
                 (sap-ref-64 nfp (number-stack-offset 8)) b
                 (sap-ref-64 nfp (number-stack-offset 16)) c
                 (sap-ref-64 nfp (number-stack-offset 24)) d))))
      #+sb-simd-pack-256
      ((#.sb-vm::single-avx2-stack-sc-number)
       (multiple-value-bind (a b c d e f g h) (%simd-pack-256-singles value)
         (with-nfp (nfp)
           (setf (sap-ref-single nfp (number-stack-offset 0)) a
                 (sap-ref-single nfp (number-stack-offset 4)) b
                 (sap-ref-single nfp (number-stack-offset 8)) c
                 (sap-ref-single nfp (number-stack-offset 12)) d
                 (sap-ref-single nfp (number-stack-offset 16)) e
                 (sap-ref-single nfp (number-stack-offset 20)) f
                 (sap-ref-single nfp (number-stack-offset 24)) g
                 (sap-ref-single nfp (number-stack-offset 28)) h))))
      #+sb-simd-pack-256
      ((#.sb-vm::double-avx2-stack-sc-number)
       (multiple-value-bind (a b c d) (%simd-pack-256-doubles value)
         (with-nfp (nfp)
           (setf (sap-ref-double nfp (number-stack-offset 0)) a
                 (sap-ref-double nfp (number-stack-offset 8)) b
                 (sap-ref-double nfp (number-stack-offset 16)) c
                 (sap-ref-double nfp (number-stack-offset 24)) d))))
      (#.single-reg-sc-number
       #-(or x86 x86-64) ;; don't have escaped floats.
       (set-escaped-float-value single-float value))
      (#.double-reg-sc-number
       (set-escaped-float-value double-float value))
      #+long-float
      (#.long-reg-sc-number
       (set-escaped-float-value long-float value))
      (#.complex-single-reg-sc-number
       (set-escaped-float-value complex-single-float value))
      (#.complex-double-reg-sc-number
       (set-escaped-float-value complex-double-float value))
      #+long-float
      (#.complex-long-reg-sc-number
       (set-escaped-float-value complex-long-float))
      (#.single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (number-stack-offset))
               (the single-float value))))
      (#.double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double nfp (number-stack-offset))
               (the double-float value))))
      #+long-float
      (#.long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long nfp (number-stack-offset))
               (the long-float value))))
      (#.complex-single-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-single nfp (number-stack-offset))
               #+(or x86 x86-64)
               (realpart (the (complex single-float) value))
               #-(or x86 x86-64)
               (the single-float (realpart value)))
         (setf (sap-ref-single nfp (number-stack-offset 4))
               #+(or x86 x86-64)
               (imagpart (the (complex single-float) value))
               #-(or x86 x86-64)
               (the single-float (realpart value)))))
      (#.complex-double-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-double nfp (number-stack-offset))
               #+(or x86 x86-64)
               (realpart (the (complex double-float) value))
               #-(or x86 x86-64)
               (the double-float (realpart value)))
         (setf (sap-ref-double nfp (number-stack-offset 8))
               #+(or x86 x86-64)
               (imagpart (the (complex double-float) value))
               #-(or x86 x86-64)
               (the double-float (realpart value)))))
      #+long-float
      (#.complex-long-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-long
                nfp (number-stack-offset))
               #+(or x86 x86-64)
               (realpart (the (complex long-float) value))
               #-(or x86 x86-64)
               (the long-float (realpart value)))
         (setf (sap-ref-long
                nfp (number-stack-offset #+sparc 4
                                        #+(or x86 x86-64) 3))
               #+(or x86 x86-64)
               (imagpart (the (complex long-float) value))
               #-(or x86 x86-64)
               (the long-float (realpart value)))))
      (#.control-stack-sc-number
       (%set-stack-ref fp (sb-c:sc+offset-offset sc+offset) value)
       value) ; I doubt that the return value matters, but who knows ...
      (#.character-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-word nfp (number-stack-offset 0))
               (char-code (the character value)))))
      (#.unsigned-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-word nfp (number-stack-offset 0)) (the word value))))
      (#.signed-stack-sc-number
       (with-nfp (nfp)
         (setf (signed-sap-ref-word nfp (number-stack-offset))
               (the signed-word value))))
      (#.sap-stack-sc-number
       (with-nfp (nfp)
         (setf (sap-ref-sap nfp (number-stack-offset))
               (the system-area-pointer value)))))))

;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
;;; this to determine if the value stored is the actual value or an
;;; indirection cell.
(defun indirect-value-cell-p (x)
  (and (%other-pointer-p x)
       (eql (%other-pointer-widetag x) value-cell-widetag)))

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

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

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

;;; This returns a table mapping form numbers to source-paths. A
;;; source-path indicates a descent into the TOPLEVEL-FORM form,
;;; going directly to the subform corresponding to the form number.
;;;
;;; The vector elements are in the same format as the compiler's
;;; NODE-SOURCE-PATH; that is, the first element is the form number and
;;; the last is the TOPLEVEL-FORM number.
;;;
;;; This should be synchronized with SB-C::SUB-FIND-SOURCE-PATHS
(defun form-number-translations (form tlf-number)
  (let ((seen nil)
        (translations (make-array 12 :fill-pointer 0 :adjustable t)))
    (labels ((translate1 (form path depth)
               (unless (member form seen)
                 (push form seen)
                 (vector-push-extend (cons (fill-pointer translations) path)
                                     translations)
                 (unless (< depth 100) ; ARB but has to be the same as in SUB-FIND-SOURCE-PATHS
                   (return-from translate1))
                 (let ((pos 0)
                       (subform form)
                       (trail form))
                   (declare (fixnum pos))
                   (macrolet ((frob ()
                                `(progn
                                   (cond
                                     ((comma-p subform)
                                      (setq subform (list 'comma (comma-expr subform))))
                                     ((atom subform) (return)))
                                   (let ((fm (car subform)))
                                     (cond
                                       ((consp fm) (translate1 fm (cons pos path) (1+ depth)))
                                       ((comma-p fm)
                                        (translate1 (list 'comma (comma-expr fm)) (list* pos path) (1+ depth)))))
                                   (setq subform (cdr subform)
                                         pos (1+ pos))
                                   (when (eq subform trail) (return)))))
                     (loop
                       (frob)
                       (frob)
                       (setq trail (cdr trail))))))))
      (translate1 form (list tlf-number) 0))
    (coerce translations 'simple-vector)))

;;; FORM is a top level form, and path is a source-path into it. This
;;; returns the form indicated by the source-path. Context is the
;;; number of enclosing forms to return instead of directly returning
;;; the source-path form. When context is non-zero, the form returned
;;; contains a marker, #:****HERE****, immediately before the form
;;; indicated by path.
(defun source-path-context (form path context)
  (declare (type unsigned-byte context))
  ;; Get to the form indicated by path or the enclosing form indicated
  ;; by context and path.
  (let ((path (reverse (butlast (cdr path)))))
    (dotimes (i (- (length path) context))
      (let ((index (first path)))
        (unless (and (listp form) (< index (length form)))
          (error "Source path no longer exists."))
        (setq form (elt form index))
        (setq path (rest path))))
    ;; Recursively rebuild the source form resulting from the above
    ;; descent, copying the beginning of each subform up to the next
    ;; subform we descend into according to path. At the bottom of the
    ;; recursion, we return the form indicated by path preceded by our
    ;; marker, and this gets spliced into the resulting list structure
    ;; on the way back up.
    (labels ((frob (form path level)
               (if (or (zerop level) (null path))
                   (if (zerop context)
                       form
                       `(#:***here*** ,form))
                   (let ((n (first path)))
                     (unless (and (listp form) (< n (length form)))
                       (error "Source path no longer exists."))
                     (let ((res (frob (elt form n) (rest path) (1- level))))
                       (nconc (subseq form 0 n)
                              (cons res (nthcdr (1+ n) form))))))))
      (frob form path context))))

;;; Given a code location, return the associated form-number
;;; translations and the actual top level form.
;;; Note that functions compiled to memory (via COMPILE or implicitly
;;; via LOAD if *EVALUATOR-MODE* = :COMPILE) do not save their source form
;;; in the DEBUG-SOURCE corresponding to their code-component. Instead the
;;; form hangs off the %SIMPLE-FUN-INFO slot, so that we can get an accurate
;;; depiction of the source form for any lambda no matter where from.
(defun get-toplevel-form (location)
  (let ((d-source (code-location-debug-source location)))
    (let* ((offset (code-location-toplevel-form-offset location))
           (res
             (cond ((and (core-debug-source-p d-source)
                         (core-debug-source-form d-source)))
                   ((debug-source-namestring d-source)
                    (get-file-toplevel-form location))
                   (t (bug "Don't know how to use a DEBUG-SOURCE without ~
                               a namestring or a form.")))))
      (values (form-number-translations res offset) res))))

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

;;; Locate the source file (if it still exists) and grab the top level
;;; form. If the file is modified, or if we are in the middle of
;;; loading the file (so that the start positions map is not available
;;; yet), we use the top level form offset instead of the recorded
;;; character offset.
(defun get-file-toplevel-form (location)
  (let* ((d-source (code-location-debug-source location))
         (tlf-offset (code-location-toplevel-form-offset location))
         (start-positions (sb-di:debug-source-start-positions d-source))
         (namestring (debug-source-namestring d-source))
         (sbcl-source-p (eql (search "SYS:" namestring) 0)))
    ;; FIXME: External format?
    (with-open-file (f namestring :if-does-not-exist nil)
      (when f
        (let ((*readtable* (safe-readtable)))
          (cond ((and (eql (debug-source-created d-source) (file-write-date f))
                      start-positions)
                 (file-position f (aref start-positions tlf-offset)))
                (t
                 (when start-positions
                   (format *debug-io*
                           "~%; File has been modified since compilation:~%;   ~A"
                           namestring))
                 (format *debug-io*
                         "~%; Using form offset instead of character position.~%")
                 (let ((*read-suppress* t)
                       (*features* (if sbcl-source-p
                                       (append *features*
                                               '(:sb-xc)
                                               sb-impl:+internal-features+)
                                       *features*)))
                   (loop repeat tlf-offset
                         do (read f)))))
          (read 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))
    (collect ((binds)
              (specs))
      (multiple-value-bind (more-context more-count)
          (debug-fun-more-args fun)
        (do-debug-fun-vars (var fun)
          (let ((validity (debug-var-validity var loc)))
            (unless (or (eq validity :invalid)
                        (eq var more-context)
                        (eq var more-count))
              (let* ((sym (debug-var-symbol var))
                     (found (assoc sym (binds))))
                (cond ((not sym))
                      (found
                       (setf (second found) :ambiguous))
                      (t
                       (binds (list sym validity var))))))))
        (when (and more-context more-count)
          (let ((more (assoc 'sb-debug::more (binds))))
            (if more
                (setf (second more) :ambiguous)
                (binds (list 'sb-debug::more :more more-context more-count))))))
      (dolist (bind (binds))
        (let ((name (first bind))
              (var (third bind)))
          (unless (eq (info :variable :kind name) :special)
            (ecase (second bind)
              (:valid
               (specs `(,name (debug-var-value ',var ,n-frame))))
              (:more
               (let ((count-var (fourth bind)))
                 (specs `(,name (multiple-value-list
                                 (sb-c:%more-arg-values (debug-var-value ',var ,n-frame)
                                                        0
                                                        (debug-var-value ',count-var ,n-frame)))))))
              (:unknown
               (specs `(,name (debug-signal 'invalid-value
                                            :debug-var ',var
                                            :frame ,n-frame))))
              (:ambiguous
               (specs `(,name (debug-signal 'ambiguous-var-name
                                            :name ',name
                                            :frame ,n-frame))))))))
      ;; Process the symbol macros outside of the function to avoid
      ;; all those symbol-macrolets from showing in the sources if
      ;; there is a problem evaluating this form
      (let ((res (let ((sb-c:*lexenv* (make-null-lexenv)))
                   (sb-c::funcall-in-symbol-macrolet-lexenv
                    (specs)
                    (lambda (&optional vars)
                      (declare (ignore vars))
                      (eval-in-lexenv `(lambda (,n-frame)
                                         (declare (ignorable ,n-frame))
                                         (progn ,form))
                                      sb-c:*lexenv*))
                    :eval))))
        (lambda (frame)
          ;; This prevents these functions from being used in any
          ;; location other than a function return location, so maybe
          ;; this should only check whether FRAME's DEBUG-FUN is the
          ;; same as LOC's.
          (unless (code-location= (frame-code-location frame) loc)
            (debug-signal 'frame-fun-mismatch
                          :code-location loc :form form :frame frame))
          (funcall res frame))))))

;;; EVAL-IN-FRAME

(defun eval-in-frame (frame form)
  (declare (type frame frame))
  "Evaluate FORM in the lexical context of FRAME's current code location,
   returning the results of the evaluation."
  (funcall (preprocess-for-eval form (frame-code-location frame)) frame))

;;;; 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
        (let* ((bpt (%make-breakpoint hook-fun what kind info))
               (starter (compiled-debug-fun-end-starter what))
               (returns (sb-c::compiled-debug-fun-returns
                         (compiled-debug-fun-compiler-debug-fun what))))
          (when (eq returns :fixed)
            (error ":FUN-END breakpoints are currently unsupported ~
                    for the known return convention on low debug."))
          (unless starter
            (setf starter (%make-breakpoint #'list what :fun-start nil))
            (setf (breakpoint-hook-fun starter)
                  (fun-end-starter-hook starter what (not (eq returns :standard))))
            (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 (bpt-lra debug-fun))
            (:copier nil))
  ;; a pointer to the bpt-lra created for :FUN-END breakpoints
  (bpt-lra nil :read-only t)
  ;; the DEBUG-FUN associated with this cookie
  (debug-fun nil :read-only t))

;;; This returns a hook function for the start helper breakpoint
;;; associated with a :FUN-END breakpoint. The returned function
;;; makes a fake LRA that all returns go through, and this piece of
;;; fake code actually breaks. Upon return from the break, the code
;;; provides the returnee with any values. Since the returned function
;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
;;; function, we must establish breakpoint-data about FUN-END-BPT.
(defun fun-end-starter-hook (starter-bpt debug-fun &optional known-return-p)
  (declare (type breakpoint starter-bpt)
           (type compiled-debug-fun debug-fun))
  (lambda (frame breakpoint)
    (declare (ignore breakpoint)
             (type frame frame))
    (multiple-value-bind (lra bpt-codeblob offset)
        (make-bpt-lra (frame-saved-lra frame debug-fun)
                      known-return-p)
      (setf (frame-saved-lra frame debug-fun) lra)
      (let ((end-bpts (breakpoint-%info starter-bpt)))
        (let ((data (breakpoint-data bpt-codeblob 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 (code-header-ref bpt-codeblob cookie-slot) 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-bpt-lra cookie)))
    (do ((frame frame (frame-down frame)))
        ((not frame) nil)
      (when (and (compiled-frame-p frame)
                 (sap= lra (frame-saved-lra frame (frame-debug-fun frame))))
        (return t)))))

;;;; 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))
                             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)
     (let ((code (breakpoint-data-component data)))
       (with-pinned-objects (code)
         (setf (breakpoint-data-instruction data)
               (breakpoint-install (get-lisp-obj-address code)
                                   (breakpoint-data-offset data))))))
   (setf (breakpoint-data-breakpoints data)
         (append (breakpoint-data-breakpoints data) (list breakpoint)))
   (setf (breakpoint-internal-data breakpoint) data)))

;;;; 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
          (let ((code (breakpoint-data-component data)))
            (with-pinned-objects (code)
              (breakpoint-remove (get-lisp-obj-address code)
                                 (breakpoint-data-offset data)
                                 (breakpoint-data-instruction data))))
          (delete-breakpoint-data data))))
  (setf (breakpoint-status breakpoint) :inactive)
  breakpoint)

;;;; BREAKPOINT-INFO

;;; Return the user-maintained info associated with breakpoint. This
;;; is SETF'able.
(defun breakpoint-info (breakpoint)
  (breakpoint-%info breakpoint))
(defun (setf breakpoint-info) (value breakpoint)
  (setf (breakpoint-%info breakpoint) value)
  (let ((other (breakpoint-unknown-return-partner breakpoint)))
    (when other
      (setf (breakpoint-%info other) value)))
  value)

;;;; 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)

;;;; C call out stubs

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

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

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

;;;; breakpoint handlers (layer between C and exported interface)

;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
;;; FIXME: these data should hang off of the component itself.
(define-load-time-global *component-breakpoint-offsets*
    (make-hash-table :test 'eq :synchronized t))

;;; This returns the BREAKPOINT-DATA object associated with component cross
;;; offset. If none exists, this makes one, installs it, and returns it.
(defun breakpoint-data (component offset &optional (create t))
  (aver component)
  (flet ((install-breakpoint-data ()
           ;; Well, this has at least these three problems if not more:
           ;; 1. For the double-checked lock pattern to be correct we have to
           ;;    re-check whether a key is in the table within the scope of the lock.
           ;; 2. The push should probably be a PUSHNEW, but even better, it too
           ;;    needs to be locked or else dups can occur. Maybe use our newfangled
           ;;    ordered lockfree linked lists.
           ;; 3. The hash-table should probably be weak keyed
           (when create
             (let ((data (make-breakpoint-data component offset)))
               (push (cons offset data)
                     (gethash component *component-breakpoint-offsets*))
               data))))
    (let ((offsets (gethash component *component-breakpoint-offsets*)))
      (if offsets
          (let ((data (assoc offset offsets)))
            (if data
                (cdr data)
                (install-breakpoint-data)))
          (install-breakpoint-data)))))

;;; We use this when there are no longer any active breakpoints
;;; corresponding to DATA.
(defun delete-breakpoint-data (data)
  ;; Again, this looks brittle. Is there no danger of being interrupted
  ;; here?
  (let* ((component (breakpoint-data-component data))
         (offsets (delete (breakpoint-data-offset data)
                          (gethash component *component-breakpoint-offsets*)
                          :key #'car)))
    (if offsets
        (setf (gethash component *component-breakpoint-offsets*) offsets)
        (remhash component *component-breakpoint-offsets*)))
  (values))

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

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

;;; This handles code-location and DEBUG-FUN :FUN-START
;;; breakpoints.
(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
  (unless breakpoints
    (bug "breakpoint that nobody wants"))
  (unless (member data *executing-breakpoint-hooks*)
    (let ((*executing-breakpoint-hooks* (cons data
                                              *executing-breakpoint-hooks*)))
      (invoke-breakpoint-hooks breakpoints signal-context)))
  ;; At this point breakpoints may not hold the same list as
  ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
  ;; a breakpoint deactivation. In fact, if all breakpoints were
  ;; deactivated then data is invalid since it was deleted and so the
  ;; correct one must be looked up if it is to be used. If there are
  ;; no more breakpoints active at this location, then the normal
  ;; instruction has been put back, and we do not need to
  ;; DO-DISPLACED-INST.
  (setf data (breakpoint-data component offset nil))
  (when (and data (breakpoint-data-breakpoints data))
    ;; The breakpoint is still active, so we need to execute the
    ;; displaced instruction and leave the breakpoint instruction
    ;; behind. The best way to do this is different on each machine,
    ;; so we just leave it up to the C code.
    (breakpoint-do-displaced-inst signal-context
                                  (breakpoint-data-instruction data))
    ;; Some platforms have no usable sigreturn() call.  If your
    ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
    ;; it's polite to warn here
    #+(and sparc solaris)
    (error "BREAKPOINT-DO-DISPLACED-INST returned?")))

(defun invoke-breakpoint-hooks (breakpoints signal-context)
  (let* ((frame (signal-context-frame signal-context)))
    (dolist (bpt breakpoints)
      (funcall (breakpoint-hook-fun bpt)
               frame
               ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
               ;; hook function the original breakpoint, so that users
               ;; aren't forced to confront the fact that some
               ;; breakpoints really are two.
               (if (eq (breakpoint-kind bpt) :unknown-return-partner)
                   (breakpoint-unknown-return-partner bpt)
                   bpt)))))

(defun signal-context-frame (signal-context)
  (let* ((scp (sb-alien:sap-alien signal-context (* os-context-t)))
         (cfp (int-sap (context-register scp sb-vm::cfp-offset))))
    (compute-calling-frame cfp (context-pc scp) nil)))

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

;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly
;;; [new C code].
(defun handle-fun-end-breakpoint-aux (breakpoints data signal-context)
  ;; FIXME: This looks brittle: what if we are interrupted somewhere
  ;; here? ...or do we have interrupts disabled here?
  (delete-breakpoint-data data)
  (let* ((scp (sb-alien:sap-alien signal-context (* os-context-t)))
         (frame (signal-context-frame signal-context))
         (component (breakpoint-data-component data))
         (cookie (code-header-ref component cookie-slot)))
    (dolist (bpt breakpoints)
      (funcall (breakpoint-hook-fun bpt)
               frame bpt
               (get-fun-end-breakpoint-values bpt scp)
               cookie))))

(defun get-fun-end-breakpoint-values (bpt scp)
  (let ((ocfp (int-sap (context-register
                        scp
                        #-(or x86 x86-64) sb-vm::ocfp-offset
                        #+x86-64 sb-vm::rbx-offset
                        #+x86 sb-vm::ebx-offset)))
        (returns (sb-c::compiled-debug-fun-returns
                  (compiled-debug-fun-compiler-debug-fun
                   (breakpoint-what bpt))))
        (results nil))
    (case returns
      (:standard
       (let ((nargs (boxed-context-register scp sb-vm::nargs-offset))
             (reg-arg-offsets '#.sb-vm::*register-arg-offsets*))
         (dotimes (arg-num nargs)
           (push (if reg-arg-offsets
                     (boxed-context-register scp (pop reg-arg-offsets))
                     (stack-ref ocfp (+ arg-num
                                        #+(or x86 x86-64) sb-vm::sp->fp-offset)))
                 results))))
      (:fixed
       (bug "shouldn't get here"))
      (t
       (dovector (sc+offset returns)
         (push (sub-access-debug-var-slot ocfp sc+offset scp)
               results))))
    (nreverse results)))

;;;; MAKE-BPT-LRA (used for :FUN-END breakpoints)

;;; Make a breakpoint 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 new LRA object, the code component it is part of,
;;; and the PC offset for the trap instruction.
;;; Note: you can't cache these, because object identity confers a full dynamic
;;; state of the program, not merely a return PC location.
;;; (I tried changing this to DEFUN-CACHED, which failed a regression test)
(defun make-bpt-lra (real-lra &optional known-return-p)
  (declare (type system-area-pointer real-lra))
  (let* ((src-start
           ;; Just trap when using the known return values convention,
           ;; as call sites don't process unknown values in that case.
           (if known-return-p
               (foreign-symbol-sap "fun_end_breakpoint_trap" t)
               (foreign-symbol-sap "fun_end_breakpoint_guts" t)))
         ;; START-OFFSET is the distance from CODE-INSTRUCTIONS to the
         ;; start of the copied :FUN-END code.
         (start-offset n-word-bytes) ; Jump Table prefix word
         ;; TRAP-OFFSET is the distance from CODE-INSTRUCTIONS to the
         ;; actual magic fun_end breakpoint trap.
         (trap-offset
           (+ start-offset
              (sap- (foreign-symbol-sap "fun_end_breakpoint_trap" t)
                    src-start)))
         ;; The length of the assembly code we are copying.
         (length (sap- (foreign-symbol-sap "fun_end_breakpoint_end" t)
                       src-start))
         (code-object
           (sb-c:allocate-code-object
            nil
            ;; Ensure required boxed header alignment.
            (align-up bpt-lra-boxed-nwords sb-c::code-boxed-words-align)
            (+ start-offset
               length
               ;; 2 extra trailing raw bytes represent CODE-N-ENTRIES
               ;; (which is zero)
               2))))
    (setf (%code-debug-info code-object) :bpt-lra)
    (with-pinned-objects (code-object)
      (let ((dst-start
              (sap+ (code-instructions code-object) start-offset)))
        (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))
        #-darwin-jit
        (system-area-ub8-copy src-start 0 dst-start 0 length)
        #+darwin-jit
        (sb-vm::jit-memcpy dst-start src-start length)
        #-(or x86 x86-64)
        (sanctify-for-execution code-object)
        ;; CODE-OBJECT is implicitly pinned after leaving
        ;; WITH-PINNED-OBJECTS (and would be pinned even if the W-P-O
        ;; were deleted), so it's OK to return a SAP into CODE-OBJECT.
        (values dst-start code-object trap-offset)))))

;;;; 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.)
    ))


;;;; Single-stepping

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

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

(defvar *step-frame* nil)

(defun handle-single-step-before-trap (context)
  (let ((step-info (single-step-info-from-context context)))
    ;; If there was not enough debug information available, there's no
    ;; sense in signaling the condition.
    (when step-info
      (let ((*step-frame*
             (signal-context-frame (sb-alien:alien-sap context))))
        (sb-impl::step-form step-info
                            ;; We could theoretically store information in
                            ;; the debug-info about to determine the
                            ;; arguments here, but for now let's just pass
                            ;; on it.
                            :unknown)))))

;;; This function will replace the fdefn / function that was in the
;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
;;; ensure that the full call will use the wrapper instead of the
;;; original, conditional trap must be emitted before the fdefn /
;;; function is converted into a raw address.
(defun handle-single-step-around-trap (context callee-register-offset)
  ;; Fetch the function / fdefn we're about to call from the
  ;; appropriate register.
  (let* ((callee
          #+linkage-space
          (sb-vm::linkage-addr->name (context-register context callee-register-offset) :abs)
          #-linkage-space
          (make-lisp-obj (context-register context callee-register-offset)))
         (step-info (single-step-info-from-context context)))
    ;; If there was not enough debug information available, there's no
    ;; sense in signaling the condition.
    (unless step-info
      (return-from handle-single-step-around-trap))
    (let* ((fun (lambda (&rest args)
                  (flet ((call ()
                           (apply (typecase callee
                                    (fdefn (fdefn-fun callee))
                                    ((or function #+linkage-space symbol) callee))
                                  args)))
                    ;; Signal a step condition
                    (let* ((step-in
                             (let ((*step-frame* (frame-down (top-frame))))
                               (sb-impl::step-form step-info args))))
                      ;; And proceed based on its return value.
                      (if step-in
                          ;; STEP-INTO was selected. Use *STEP-OUT* to
                          ;; let the stepper know that selecting the
                          ;; STEP-OUT restart is valid inside this
                          (let ((sb-impl::*step-out* :maybe))
                            ;; Pass the return values of the call to
                            ;; STEP-VALUES, which will signal a
                            ;; condition with them in the VALUES slot.
                            (unwind-protect
                                 (multiple-value-call #'sb-impl::step-values
                                   step-info
                                   (call))
                              ;; If the user selected the STEP-OUT
                              ;; restart during the call, resume
                              ;; stepping
                              (when (eq sb-impl::*step-out* t)
                                (sb-impl::enable-stepping))))
                          ;; STEP-NEXT / CONTINUE / OUT selected:
                          ;; Disable the stepper for the duration of
                          ;; the call.
                          (sb-impl::with-stepping-disabled
                            (call)))))))
           (new-callee (etypecase callee
                         #+linkage-space ((or list symbol) (sb-vm::stepper-fun fun))
                         #-linkage-space
                         (fdefn
                          (let ((fdefn (make-fdefn '(#:dummy))))
                            (setf (fdefn-fun fdefn) fun)
                            fdefn))
                         (function fun))))
      ;; And then store the wrapper in the same place.
      (with-pinned-objects (new-callee)
        ;; %SET-CONTEXT-REGISTER is a function, so the address of
        ;; NEW-CALLEE gets converted to a fixnum before passing, which
        ;; won't keep NEW-CALLEE pinned down. Once it's inside
        ;; CONTEXT, which is registered in thread->interrupt_contexts,
        ;; it will properly point to NEW-CALLEE.
        (typecase callee
         #+linkage-space ((or list symbol)
          ;; the new callee is a funcallable instance that jumps to FUN.
          ;; Point the callee register to the address of the FIN's trampoline word
          (setf (context-register context callee-register-offset)
                (+ (get-lisp-obj-address new-callee)
                   (- sb-vm:n-word-bytes sb-vm:fun-pointer-lowtag))))
         (t
          (setf (context-register context callee-register-offset)
                (get-lisp-obj-address new-callee))))))))

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

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

;;;; fetching errorful function name

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

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

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

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