Handle run-program with :directory nil.

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

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index f4b2044..e8a188d 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -41,75 +41,66 @@
    "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
     that must be handled, but they are not programmer errors."))
 
    "All DEBUG-CONDITIONs inherit from this type. These are serious conditions
     that must be handled, but they are not programmer errors."))
 

-(define-condition no-debug-info (debug-condition)
-  ()
-  #!+sb-doc
-  (:documentation "There is no usable debugging information available.")
-  (:report (lambda (condition stream)
-            (declare (ignore condition))
-            (fresh-line stream)
-            (write-line "no debugging information available" stream))))
-
-(define-condition no-debug-function-returns (debug-condition)
-  ((debug-function :reader no-debug-function-returns-debug-function
-                  :initarg :debug-function))
+(define-condition no-debug-fun-returns (debug-condition)
+  ((debug-fun :reader no-debug-fun-returns-debug-fun
+              :initarg :debug-fun))

   #!+sb-doc
   (:documentation
   #!+sb-doc
   (:documentation

-   "The system could not return values from a frame with DEBUG-FUNCTION since
+   "The system could not return values from a frame with DEBUG-FUN since

     it lacked information about returning values.")
   (:report (lambda (condition stream)
     it lacked information about returning values.")
   (:report (lambda (condition stream)

-            (let ((fun (debug-function-function
-                        (no-debug-function-returns-debug-function condition))))
-              (format stream
-                      "~&Cannot return values from ~:[frame~;~:*~S~] since ~
-                       the debug information lacks details about returning ~
-                       values here."
-                      fun)))))
+             (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)
 
 (define-condition no-debug-blocks (debug-condition)

-  ((debug-function :reader no-debug-blocks-debug-function
-                  :initarg :debug-function))
+  ((debug-fun :reader no-debug-blocks-debug-fun
+              :initarg :debug-fun))

   #!+sb-doc
   #!+sb-doc

-  (:documentation "The debug-function has no debug-block information.")
+  (:documentation "The debug-fun has no debug-block information.")

   (:report (lambda (condition stream)
   (:report (lambda (condition stream)

-            (format stream "~&~S has no debug-block information."
-                    (no-debug-blocks-debug-function condition)))))
+             (format stream "~&~S has no debug-block information."
+                     (no-debug-blocks-debug-fun condition)))))

 
 (define-condition no-debug-vars (debug-condition)
 
 (define-condition no-debug-vars (debug-condition)

-  ((debug-function :reader no-debug-vars-debug-function
-                  :initarg :debug-function))
+  ((debug-fun :reader no-debug-vars-debug-fun
+              :initarg :debug-fun))

   #!+sb-doc
   #!+sb-doc

-  (:documentation "The debug-function has no DEBUG-VAR information.")
+  (:documentation "The DEBUG-FUN has no DEBUG-VAR information.")

   (:report (lambda (condition stream)
   (:report (lambda (condition stream)

-            (format stream "~&~S has no debug variable information."
-                    (no-debug-vars-debug-function condition)))))
+             (format stream "~&~S has no debug variable information."
+                     (no-debug-vars-debug-fun condition)))))

 
 (define-condition lambda-list-unavailable (debug-condition)
 
 (define-condition lambda-list-unavailable (debug-condition)

-  ((debug-function :reader lambda-list-unavailable-debug-function
-                  :initarg :debug-function))
+  ((debug-fun :reader lambda-list-unavailable-debug-fun
+              :initarg :debug-fun))

   #!+sb-doc
   (:documentation
   #!+sb-doc
   (:documentation

-   "The debug-function has no lambda-list since argument DEBUG-VARs are
+   "The DEBUG-FUN has no lambda list since argument DEBUG-VARs are

     unavailable.")
   (:report (lambda (condition stream)
     unavailable.")
   (:report (lambda (condition stream)

-            (format stream "~&~S has no lambda-list information available."
-                    (lambda-list-unavailable-debug-function condition)))))
+             (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)
 
 (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)))))
+             (format stream "~&~S has :invalid or :unknown value in ~S."
+                     (invalid-value-debug-var condition)
+                     (invalid-value-frame condition)))))

 
 

-(define-condition ambiguous-variable-name (debug-condition)
-  ((name :reader ambiguous-variable-name-name :initarg :name)
-   (frame :reader ambiguous-variable-name-frame :initarg :frame))
+(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)
   (:report (lambda (condition stream)

-            (format stream "~&~S names more than one valid variable in ~S."
-                    (ambiguous-variable-name-name condition)
-                    (ambiguous-variable-name-frame condition)))))
+             (format stream "~&~S names more than one valid variable in ~S."
+                     (ambiguous-var-name-name condition)
+                     (ambiguous-var-name-frame condition)))))

 \f
 ;;;; errors and DEBUG-SIGNAL
 
 \f
 ;;;; errors and DEBUG-SIGNAL
 

@@ -127,55 +118,56 @@
    "All programmer errors from using the interface for building debugging
     tools inherit from this type."))
 
    "All programmer errors from using the interface for building debugging
     tools inherit from this type."))
 

-(define-condition unhandled-condition (debug-error)
-  ((condition :reader unhandled-condition-condition :initarg :condition))
+(define-condition unhandled-debug-condition (debug-error)
+  ((condition :reader unhandled-debug-condition-condition :initarg :condition))

   (:report (lambda (condition stream)
   (:report (lambda (condition stream)

-            (format stream "~&unhandled DEBUG-CONDITION:~%~A"
-                    (unhandled-condition-condition condition)))))
+             (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
 
 (define-condition unknown-code-location (debug-error)
   ((code-location :reader unknown-code-location-code-location

-                 :initarg :code-location))
+                  :initarg :code-location))

   (:report (lambda (condition stream)
   (:report (lambda (condition stream)

-            (format stream "~&invalid use of an unknown code-location: ~S"
-                    (unknown-code-location-code-location condition)))))
+             (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)
 
 (define-condition unknown-debug-var (debug-error)
   ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)

-   (debug-function :reader unknown-debug-var-debug-function
-                  :initarg :debug-function))
+   (debug-fun :reader unknown-debug-var-debug-fun
+              :initarg :debug-fun))

   (:report (lambda (condition stream)
   (:report (lambda (condition stream)

-            (format stream "~&~S is not in ~S."
-                    (unknown-debug-var-debug-var condition)
-                    (unknown-debug-var-debug-function condition)))))
+             (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)
 
 (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-function-mismatch (debug-error)
-  ((code-location :reader frame-function-mismatch-code-location
-                 :initarg :code-location)
-   (frame :reader frame-function-mismatch-frame :initarg :frame)
-   (form :reader frame-function-mismatch-form :initarg :form))
+             (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)
   (:report (lambda (condition stream)

-            (format stream
-                    "~&Form was preprocessed for ~S,~% but called on ~S:~%  ~S"
-                    (frame-function-mismatch-code-location condition)
-                    (frame-function-mismatch-frame condition)
-                    (frame-function-mismatch-form condition)))))
-
-;;; This signals debug-conditions. If they go unhandled, then signal an
-;;; unhandled-condition error.
+             (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)
 ;;;
 ;;; ??? Get SIGNAL in the right package!
 (defmacro debug-signal (datum &rest arguments)
   `(let ((condition (make-condition ,datum ,@arguments)))
      (signal condition)

-     (error 'unhandled-condition :condition condition)))
+     (error 'unhandled-debug-condition :condition condition)))

 \f
 ;;;; structures
 ;;;;
 \f
 ;;;; structures
 ;;;;

@@ -183,51 +175,49 @@
 ;;;; 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
 ;;;; 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 "DI" package.
+;;;; name in the "SB-DI" package.

 
 ;;;; DEBUG-VARs
 
 ;;; These exist for caching data stored in packed binary form in
 
 ;;;; DEBUG-VARs
 
 ;;; These exist for caching data stored in packed binary form in

-;;; compiler debug-functions. Debug-functions store these.
-(defstruct (debug-var (:constructor nil))
+;;; compiler DEBUG-FUNs.
+(defstruct (debug-var (:constructor nil)
+                      (:copier nil))

   ;; the name of the variable
   ;; the name of the variable

-  (symbol (required-argument) :type symbol)
+  (symbol (missing-arg) :type symbol)

   ;; a unique integer identification relative to other variables with the same
   ;; symbol
   ;; a unique integer identification relative to other variables with the same
   ;; symbol

-  (id 0 :type sb!c::index)
+  (id 0 :type index)

   ;; Does the variable always have a valid value?
   (alive-p nil :type boolean))
 (def!method print-object ((debug-var debug-var) stream)
   (print-unreadable-object (debug-var stream :type t :identity t)
     (format stream
   ;; Does the variable always have a valid value?
   (alive-p nil :type boolean))
 (def!method print-object ((debug-var debug-var) stream)
   (print-unreadable-object (debug-var stream :type t :identity t)
     (format stream

-           "~S ~D"
-           (debug-var-symbol debug-var)
-           (debug-var-id debug-var))))
+            "~S ~W"
+            (debug-var-symbol debug-var)
+            (debug-var-id debug-var))))

 
 #!+sb-doc
 (setf (fdocumentation 'debug-var-id 'function)
 
 #!+sb-doc
 (setf (fdocumentation 'debug-var-id 'function)

-  "Returns the integer that makes DEBUG-VAR's name and package unique
+  "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
    with respect to other DEBUG-VARs in the same function.")
 
 (defstruct (compiled-debug-var

-           (:include debug-var)
-           (:constructor make-compiled-debug-var
-                         (symbol id alive-p sc-offset save-sc-offset)))
-  ;; Storage class and offset. (unexported).
-  (sc-offset nil :type sb!c::sc-offset)
-  ;; Storage class and offset when saved somewhere.
-  (save-sc-offset nil :type (or sb!c::sc-offset null)))
-
-(defstruct (interpreted-debug-var
-           (:include debug-var (alive-p t))
-           (:constructor make-interpreted-debug-var (symbol ir1-var)))
-  ;; This is the IR1 structure that holds information about interpreted vars.
-  (ir1-var nil :type sb!c::lambda-var))
+            (:include debug-var)
+            (:constructor make-compiled-debug-var
+                (symbol id alive-p sc-offset save-sc-offset info))
+            (:copier nil))
+  ;; storage class and offset (unexported)
+  (sc-offset nil :type sb!c:sc-offset)
+  ;; storage class and offset when saved somewhere
+  (save-sc-offset nil :type (or sb!c:sc-offset null))
+  (info nil))

 
 ;;;; frames
 
 
 ;;;; frames
 

-;;; These represent call-frames on the stack.
-(defstruct (frame (:constructor nil))
+;;; These represent call frames on the stack.
+(defstruct (frame (:constructor nil)
+                  (:copier nil))

   ;; the next frame up, or NIL when top frame
   (up nil :type (or frame null))
   ;; the previous frame down, or NIL when the bottom frame. Before
   ;; the next frame up, or NIL when top frame
   (up nil :type (or frame null))
   ;; the previous frame down, or NIL when the bottom frame. Before

@@ -235,266 +225,181 @@
   ;; to the control stack for the given frame. This lets us get the
   ;; next frame down and the return-pc for that frame.
   (%down :unparsed :type (or frame (member nil :unparsed)))
   ;; to the control stack for the given frame. This lets us get the
   ;; next frame down and the return-pc for that frame.
   (%down :unparsed :type (or frame (member nil :unparsed)))

-  ;; the debug-function for the function whose call this frame
-  ;; represents
-  (debug-function nil :type debug-function)
-  ;; the code-location to continue upon return to frame
+  ;; the DEBUG-FUN for the function whose call this frame represents
+  (debug-fun nil :type debug-fun)
+  ;; the CODE-LOCATION where the frame's DEBUG-FUN will continue
+  ;; running when program execution returns to this frame. If someone
+  ;; interrupted this frame, the result could be an unknown
+  ;; CODE-LOCATION.

   (code-location nil :type code-location)
   ;; an a-list of catch-tags to code-locations
   (%catches :unparsed :type (or list (member :unparsed)))
   (code-location nil :type code-location)
   ;; an a-list of catch-tags to code-locations
   (%catches :unparsed :type (or list (member :unparsed)))

-  ;; pointer to frame on control stack. (unexported) When this frame
-  ;; is an interpreted-frame, this pointer is an index into the
-  ;; interpreter's stack.
+  ;; pointer to frame on control stack (unexported)

   pointer
   ;; This is the frame's number for prompt printing. Top is zero.
   (number 0 :type index))
 
   pointer
   ;; This is the frame's number for prompt printing. Top is zero.
   (number 0 :type index))
 

-#!+sb-doc
-(setf (fdocumentation 'frame-up 'function)
-  "Returns the frame immediately above frame on the stack. When frame is
-   the top of the stack, this returns nil.")
-
-#!+sb-doc
-(setf (fdocumentation 'frame-debug-function 'function)
-  "Returns the debug-function for the function whose call frame represents.")
-
-#!+sb-doc
-(setf (fdocumentation 'frame-code-location 'function)
-  "Returns the code-location where the frame's debug-function will continue
-   running when program execution returns to this frame. If someone
-   interrupted this frame, the result could be an unknown code-location.")
-

 (defstruct (compiled-frame
 (defstruct (compiled-frame

-           (:include frame)
-           (:constructor make-compiled-frame
-                         (pointer up debug-function code-location number
-                                  #!+gengc saved-state-chain
-                                  &optional escaped)))
+            (: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
   ;; This indicates whether someone interrupted the frame.
   ;; (unexported). If escaped, this is a pointer to the state that was

-  ;; saved when we were interrupted. On the non-gengc system, this is
-  ;; a pointer to an os_context_t, i.e. the third argument to an
-  ;; SA_SIGACTION-style signal handler. On the gengc system, this is a
-  ;; state pointer from SAVED-STATE-CHAIN.
-  escaped
-  ;; a list of SAPs to saved states. Each time we unwind past an
-  ;; exception, we pop the next entry off this list. When we get to
-  ;; the end of the list, there is nothing else on the stack.
-  #!+gengc (saved-state-chain nil :type list))
+  ;; saved when we were interrupted, an os_context_t, i.e. the third
+  ;; argument to an SA_SIGACTION-style signal handler.
+  escaped)

 (def!method print-object ((obj compiled-frame) str)
   (print-unreadable-object (obj str :type t)
     (format str
 (def!method print-object ((obj compiled-frame) str)
   (print-unreadable-object (obj str :type t)
     (format str

-           "~S~:[~;, interrupted~]"
-           (debug-function-name (frame-debug-function obj))
-           (compiled-frame-escaped obj))))
-
-(defstruct (interpreted-frame
-           (:include frame)
-           (:constructor make-interpreted-frame
-                         (pointer up debug-function code-location number
-                          real-frame closure)))
-  ;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP.
-  (real-frame nil :type compiled-frame)
-  ;; This is the closed over data used by the interpreter.
-  (closure nil :type simple-vector))
-(def!method print-object ((obj interpreted-frame) str)
-  (print-unreadable-object (obj str :type t)
-    (prin1 (debug-function-name (frame-debug-function obj)) str)))
-
-;;;; DEBUG-FUNCTIONs
+            "~S~:[~;, interrupted~]"
+            (debug-fun-name (frame-debug-fun obj))
+            (compiled-frame-escaped obj))))
+\f
+;;;; DEBUG-FUNs

 
 ;;; These exist for caching data stored in packed binary form in
 
 ;;; These exist for caching data stored in packed binary form in

-;;; compiler debug-functions. *COMPILED-DEBUG-FUNCTIONS* maps a
-;;; SB!C::DEBUG-FUNCTION to a DEBUG-FUNCTION. There should only be one
-;;; DEBUG-FUNCTION in existence for any function; that is, all
-;;; code-locations and other objects that reference DEBUG-FUNCTIONs
-;;; point to unique objects. This is due to the overhead in cached
-;;; information.
-(defstruct debug-function
-  ;; Some representation of the function arguments. See
-  ;; DEBUG-FUNCTION-LAMBDA-LIST.
+;;; compiler DEBUG-FUNs. *COMPILED-DEBUG-FUNS* maps a SB!C::DEBUG-FUN
+;;; to a DEBUG-FUN. There should only be one DEBUG-FUN in existence
+;;; for any function; that is, all CODE-LOCATIONs and other objects
+;;; that reference DEBUG-FUNs point to unique objects. This is
+;;; due to the overhead in cached information.
+(defstruct (debug-fun (:constructor nil)
+                      (:copier nil))
+  ;; some representation of the function arguments. See
+  ;; DEBUG-FUN-LAMBDA-LIST.

   ;; NOTE: must parse vars before parsing arg list stuff.
   (%lambda-list :unparsed)
   ;; NOTE: must parse vars before parsing arg list stuff.
   (%lambda-list :unparsed)

-  ;; Cached DEBUG-VARS information. (unexported).
+  ;; cached DEBUG-VARS information (unexported).

   ;; These are sorted by their name.
   (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
   ;; 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
+  ;; 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)))
   ;; parse the packed binary info, but none is available.
   (blocks :unparsed :type (or simple-vector null (member :unparsed)))

-  ;; The actual function if available.
+  ;; the actual function if available

   (%function :unparsed :type (or null function (member :unparsed))))
   (%function :unparsed :type (or null function (member :unparsed))))

-(def!method print-object ((obj debug-function) stream)
+(def!method print-object ((obj debug-fun) stream)

   (print-unreadable-object (obj stream :type t)
   (print-unreadable-object (obj stream :type t)

-    (prin1 (debug-function-name obj) stream)))
-
-(defstruct (compiled-debug-function
-           (:include debug-function)
-           (:constructor %make-compiled-debug-function
-                         (compiler-debug-fun component)))
-  ;; Compiler's dumped debug-function information. (unexported).
-  (compiler-debug-fun nil :type sb!c::compiled-debug-function)
-  ;; Code object. (unexported).
+    (prin1 (debug-fun-name obj) stream)))
+
+(defstruct (compiled-debug-fun
+            (:include debug-fun)
+            (:constructor %make-compiled-debug-fun
+                          (compiler-debug-fun component))
+            (:copier nil))
+  ;; compiler's dumped DEBUG-FUN information (unexported)
+  (compiler-debug-fun nil :type sb!c::compiled-debug-fun)
+  ;; code object (unexported).

   component
   component

-  ;; The :FUNCTION-START breakpoint (if any) used to facilitate
-  ;; function end breakpoints.
+  ;; the :FUN-START breakpoint (if any) used to facilitate
+  ;; function end breakpoints

   (end-starter nil :type (or null breakpoint)))
 
   (end-starter nil :type (or null breakpoint)))
 

-;;; This maps SB!C::COMPILED-DEBUG-FUNCTIONs to
-;;; COMPILED-DEBUG-FUNCTIONs, so we can get at cached stuff and not
-;;; duplicate COMPILED-DEBUG-FUNCTION structures.
-(defvar *compiled-debug-functions* (make-hash-table :test 'eq))
-
-;;; Make a COMPILED-DEBUG-FUNCTION for a SB!C::COMPILER-DEBUG-FUNCTION
-;;; and its component. This maps the latter to the former in
-;;; *COMPILED-DEBUG-FUNCTIONS*. If there already is a
-;;; COMPILED-DEBUG-FUNCTION, then this returns it from
-;;; *COMPILED-DEBUG-FUNCTIONS*.
-(defun make-compiled-debug-function (compiler-debug-fun component)
-  (or (gethash compiler-debug-fun *compiled-debug-functions*)
-      (setf (gethash compiler-debug-fun *compiled-debug-functions*)
-           (%make-compiled-debug-function compiler-debug-fun component))))
-
-(defstruct (interpreted-debug-function
-           (:include debug-function)
-           (:constructor %make-interpreted-debug-function (ir1-lambda)))
-  ;; This is the IR1 lambda that this debug-function represents.
-  (ir1-lambda nil :type sb!c::clambda))
-
-(defstruct (bogus-debug-function
-           (:include debug-function)
-           (:constructor make-bogus-debug-function
-                         (%name &aux (%lambda-list nil) (%debug-vars nil)
-                                (blocks nil) (%function nil))))
-  %name)
-
-(defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq))
-
-(defun make-interpreted-debug-function (ir1-lambda)
-  (let ((home-lambda (sb!c::lambda-home ir1-lambda)))
-    (or (gethash home-lambda *ir1-lambda-debug-function*)
-       (setf (gethash home-lambda *ir1-lambda-debug-function*)
-             (%make-interpreted-debug-function home-lambda)))))
+;;; This maps SB!C::COMPILED-DEBUG-FUNs to
+;;; COMPILED-DEBUG-FUNs, so we can get at cached stuff and not
+;;; duplicate COMPILED-DEBUG-FUN structures.
+(defvar *compiled-debug-funs* (make-hash-table :test 'eq :weakness :key))

 
 

+;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its
+;;; component. This maps the latter to the former in
+;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN,
+;;; then this returns it from *COMPILED-DEBUG-FUNS*.
+;;;
+;;; FIXME: It seems this table can potentially grow without bounds,
+;;; and retains roots to functions that might otherwise be collected.
+(defun make-compiled-debug-fun (compiler-debug-fun component)
+  (let ((table *compiled-debug-funs*))
+    (with-locked-system-table (table)
+      (or (gethash compiler-debug-fun table)
+          (setf (gethash compiler-debug-fun table)
+                (%make-compiled-debug-fun compiler-debug-fun component))))))
+
+(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)
+\f

 ;;;; DEBUG-BLOCKs
 
 ;;; These exist for caching data stored in packed binary form in compiler
 ;;;; DEBUG-BLOCKs
 
 ;;; These exist for caching data stored in packed binary form in compiler

-;;; debug-blocks.
-(defstruct (debug-block (:constructor nil))
+;;; DEBUG-BLOCKs.
+(defstruct (debug-block (:constructor nil)
+                        (:copier nil))

   ;; Code-locations where execution continues after this block.
   (successors nil :type list)
   ;; 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. In an interpreted-debug-block, this is
-  ;; always nil. This slot is in all debug-blocks since it is an exported
-  ;; interface.
+  ;; This indicates whether the block is a special glob of code shared
+  ;; by various functions and tucked away elsewhere in a component.
+  ;; This kind of block has no start code-location. This slot is in
+  ;; all debug-blocks since it is an exported interface.

   (elsewhere-p nil :type boolean))
 (def!method print-object ((obj debug-block) str)
   (print-unreadable-object (obj str :type t)
   (elsewhere-p nil :type boolean))
 (def!method print-object ((obj debug-block) str)
   (print-unreadable-object (obj str :type t)

-    (prin1 (debug-block-function-name obj) str)))
+    (prin1 (debug-block-fun-name obj) str)))

 
 #!+sb-doc
 (setf (fdocumentation 'debug-block-successors 'function)
 
 #!+sb-doc
 (setf (fdocumentation 'debug-block-successors 'function)

-  "Returns the list of possible code-locations where execution may continue
+  "Return the list of possible code-locations where execution may continue

    when the basic-block represented by debug-block completes its execution.")
 
 #!+sb-doc
 (setf (fdocumentation 'debug-block-elsewhere-p 'function)
    when the basic-block represented by debug-block completes its execution.")
 
 #!+sb-doc
 (setf (fdocumentation 'debug-block-elsewhere-p 'function)

-  "Returns whether debug-block represents elsewhere code.")
+  "Return whether debug-block represents elsewhere code.")

 
 (defstruct (compiled-debug-block (:include debug-block)
 
 (defstruct (compiled-debug-block (:include debug-block)

-                                (:constructor
-                                 make-compiled-debug-block
-                                 (code-locations successors elsewhere-p)))
-  ;; Code-location information for the block.
+                                 (:constructor
+                                  make-compiled-debug-block
+                                  (code-locations successors elsewhere-p))
+                                 (:copier nil))
+  ;; code-location information for the block

   (code-locations nil :type simple-vector))
   (code-locations nil :type simple-vector))

-
-(defstruct (interpreted-debug-block (:include debug-block
-                                             (elsewhere-p nil))
-                                   (:constructor %make-interpreted-debug-block
-                                                 (ir1-block)))
-  ;; This is the IR1 block this debug-block represents.
-  (ir1-block nil :type sb!c::cblock)
-  ;; Code-location information for the block.
-  (locations :unparsed :type (or (member :unparsed) simple-vector)))
-
-(defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
-
-;;; Make a DEBUG-BLOCK for the interpreter's IR1-BLOCK. If we have it
-;;; in the cache, return it. If we need to make it, then first make
-;;; DEBUG-BLOCKs for all the IR1-BLOCKs in IR1-BLOCK's home lambda;
-;;; this makes sure all the successors of IR1-BLOCK have DEBUG-BLOCKs.
-;;; We need this to fill in the resulting DEBUG-BLOCK's successors
-;;; list with DEBUG-BLOCKs, not IR1-BLOCKs. After making all the
-;;; possible DEBUG-BLOCKs we'll need to reference, go back over the
-;;; list of new DEBUG-BLOCKs and fill in their successor slots with
-;;; lists of DEBUG-BLOCKs. Then look up our argument IR1-BLOCK to find
-;;; its DEBUG-BLOCK since we know we have it now.
-(defun make-interpreted-debug-block (ir1-block)
-  (check-type ir1-block sb!c::cblock)
-  (let ((res (gethash ir1-block *ir1-block-debug-block*)))
-    (or res
-       (let ((lambda (sb!c::block-home-lambda ir1-block)))
-         (sb!c::do-blocks (block (sb!c::block-component ir1-block))
-           (when (eq lambda (sb!c::block-home-lambda block))
-             (push (setf (gethash block *ir1-block-debug-block*)
-                         (%make-interpreted-debug-block block))
-                   res)))
-         (dolist (block res)
-           (let* ((successors nil)
-                  (cblock (interpreted-debug-block-ir1-block block))
-                  (succ (sb!c::block-succ cblock))
-                  (valid-succ
-                   (if (and succ
-                            (eq (car succ)
-                                (sb!c::component-tail
-                                 (sb!c::block-component cblock))))
-                       ()
-                       succ)))
-             (dolist (sblock valid-succ)
-               (let ((dblock (gethash sblock *ir1-block-debug-block*)))
-                 (when dblock
-                   (push dblock successors))))
-             (setf (debug-block-successors block) (nreverse successors))))
-         (gethash ir1-block *ir1-block-debug-block*)))))
-
+\f

 ;;;; breakpoints
 
 ;;; This is an internal structure that manages information about a
 ;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
 (defstruct (breakpoint-data (:constructor make-breakpoint-data
 ;;;; 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)))
+                                          (component offset))
+                            (:copier nil))

   ;; This is the component in which the breakpoint lies.
   component
   ;; This is the byte offset into the component.
   ;; This is the component in which the breakpoint lies.
   component
   ;; This is the byte offset into the component.

-  (offset nil :type sb!c::index)
+  (offset nil :type index)

   ;; The original instruction replaced by the breakpoint.
   ;; The original instruction replaced by the breakpoint.

-  (instruction nil :type (or null (unsigned-byte 32)))
+  (instruction nil :type (or null sb!vm::word))

   ;; A list of user breakpoints at this location.
   (breakpoints nil :type list))
 (def!method print-object ((obj breakpoint-data) str)
   (print-unreadable-object (obj str :type t)
     (format str "~S at ~S"
   ;; A list of user breakpoints at this location.
   (breakpoints nil :type list))
 (def!method print-object ((obj breakpoint-data) str)
   (print-unreadable-object (obj str :type t)
     (format str "~S at ~S"

-           (debug-function-name
-            (debug-function-from-pc (breakpoint-data-component obj)
-                                    (breakpoint-data-offset obj)))
-           (breakpoint-data-offset obj))))
+            (debug-fun-name
+             (debug-fun-from-pc (breakpoint-data-component obj)
+                                (breakpoint-data-offset obj)))
+            (breakpoint-data-offset obj))))

 
 (defstruct (breakpoint (:constructor %make-breakpoint
 
 (defstruct (breakpoint (:constructor %make-breakpoint

-                                    (hook-function what kind %info)))
+                                     (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
   ;; 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 :FUNCTION-END breakpoints
-  ;; as values to return for the function containing the breakpoint.
-  ;; :FUNCTION-END breakpoint hook-functions also take a cookie
-  ;; argument. See COOKIE-FUN slot.
-  (hook-function nil :type function)
-  ;; CODE-LOCATION or DEBUG-FUNCTION
-  (what nil :type (or code-location debug-function))
-  ;; :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END for that kind
+  ;; list of values. Values are supplied for :FUN-END breakpoints as
+  ;; values to return for the function containing the breakpoint.
+  ;; :FUN-END breakpoint hook functions also take a cookie argument.
+  ;; See the COOKIE-FUN slot.
+  (hook-fun (required-arg) :type function)
+  ;; CODE-LOCATION or DEBUG-FUN
+  (what nil :type (or code-location debug-fun))
+  ;; :CODE-LOCATION, :FUN-START, or :FUN-END for that kind

   ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
   ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
   ;; 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 :function-start :function-end
-                         :unknown-return-partner))
+  (kind nil :type (member :code-location :fun-start :fun-end
+                          :unknown-return-partner))

   ;; Status helps the user and the implementation.
   (status :inactive :type (member :active :inactive :deleted))
   ;; This is a backpointer to a breakpoint-data.
   ;; Status helps the user and the implementation.
   (status :inactive :type (member :active :inactive :deleted))
   ;; This is a backpointer to a breakpoint-data.

@@ -505,7 +410,7 @@
   ;; 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))
   ;; 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))

-  ;; :FUNCTION-END breakpoints use a breakpoint at the :FUNCTION-START
+  ;; :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
   ;; 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

@@ -513,10 +418,10 @@
   ;; and delete it.
   (start-helper nil :type (or null breakpoint))
   ;; This is a hook users supply to get a dynamically unique cookie
   ;; and delete it.
   (start-helper nil :type (or null breakpoint))
   ;; This is a hook users supply to get a dynamically unique cookie

-  ;; for identifying :FUNCTION-END breakpoint executions. That is, if
-  ;; there is one :FUNCTION-END breakpoint, but there may be multiple
+  ;; 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
   ;; pending calls of its function on the stack. This function takes

-  ;; the cookie, and the hook-function takes the cookie too.
+  ;; 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)
   (cookie-fun nil :type (or null function))
   ;; This slot users can set with whatever information they find useful.
   %info)

@@ -524,135 +429,77 @@
   (let ((what (breakpoint-what obj)))
     (print-unreadable-object (obj str :type t)
       (format str
   (let ((what (breakpoint-what obj)))
     (print-unreadable-object (obj str :type t)
       (format str

-             "~S~:[~;~:*~S~]"
-             (etypecase what
-               (code-location what)
-               (debug-function (debug-function-name what)))
-             (etypecase what
-               (code-location nil)
-               (debug-function (breakpoint-kind obj)))))))
-
-#!+sb-doc
-(setf (fdocumentation 'breakpoint-hook-function 'function)
-  "Returns the breakpoint's function the system calls when execution encounters
-   the breakpoint, and it is active. This is SETF'able.")
-
-#!+sb-doc
-(setf (fdocumentation 'breakpoint-what 'function)
-  "Returns the breakpoint's what specification.")
-
-#!+sb-doc
-(setf (fdocumentation 'breakpoint-kind 'function)
-  "Returns the breakpoint's kind specification.")
-
+              "~S~:[~;~:*~S~]"
+              (etypecase what
+                (code-location what)
+                (debug-fun (debug-fun-name what)))
+              (etypecase what
+                (code-location nil)
+                (debug-fun (breakpoint-kind obj)))))))
+\f

 ;;;; CODE-LOCATIONs
 
 ;;;; CODE-LOCATIONs
 

-(defstruct (code-location (:constructor nil))
-  ;; This is the debug-function containing code-location.
-  (debug-function nil :type debug-function)
+(defstruct (code-location (:constructor nil)
+                          (:copier nil))
+  ;; the DEBUG-FUN containing this CODE-LOCATION
+  (debug-fun nil :type debug-fun)

   ;; This is initially :UNSURE. Upon first trying to access an
   ;; This is initially :UNSURE. Upon first trying to access an

-  ;; :unparsed slot, if the data is unavailable, then this becomes t,
+  ;; :UNPARSED slot, if the data is unavailable, then this becomes T,

   ;; and the code-location is unknown. If the data is available, this
   ;; and the code-location is unknown. If the data is available, this

-  ;; becomes nil, a known location. We can't use a separate type
+  ;; 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))
   ;; 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))

-  ;; This is the debug-block containing code-location. Possibly toss
-  ;; this out and just find it in the blocks cache in debug-function.
+  ;; 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
   (%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 sb!c::index (member :unparsed)))
+  ;; 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
   ;; This is the depth-first number of the node that begins

-  ;; code-location within its top-level form.
-  (%form-number :unparsed :type (or sb!c::index (member :unparsed))))
+  ;; code-location within its top level form.
+  (%form-number :unparsed :type (or index (member :unparsed))))

 (def!method print-object ((obj code-location) str)
   (print-unreadable-object (obj str :type t)
 (def!method print-object ((obj code-location) str)
   (print-unreadable-object (obj str :type t)

-    (prin1 (debug-function-name (code-location-debug-function obj))
-          str)))
-
-#!+sb-doc
-(setf (fdocumentation 'code-location-debug-function 'function)
-  "Returns the debug-function representing information about the function
-   corresponding to the code-location.")
+    (prin1 (debug-fun-name (code-location-debug-fun obj))
+           str)))

 
 (defstruct (compiled-code-location
 
 (defstruct (compiled-code-location

-           (:include code-location)
-           (:constructor make-known-code-location
-                         (pc debug-function %tlf-offset %form-number
-                             %live-set kind &aux (%unknown-p nil)))
-           (:constructor make-compiled-code-location (pc debug-function)))
-  ;; This is an index into debug-function's component slot.
-  (pc nil :type sb!c::index)
-  ;; This is a bit-vector indexed by a variable's position in
-  ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a
+             (:include code-location)
+             (:constructor make-known-code-location
+                           (pc debug-fun %tlf-offset %form-number
+                               %live-set kind step-info &aux (%unknown-p nil)))
+             (:constructor make-compiled-code-location (pc debug-fun))
+             (:copier nil))
+  ;; an index into DEBUG-FUN's component slot
+  (pc nil :type index)
+  ;; a bit-vector indexed by a variable's position in
+  ;; DEBUG-FUN-DEBUG-VARS indicating whether the variable has a

   ;; valid value at this code-location. (unexported).
   (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
   ;; (unexported) To see SB!C::LOCATION-KIND, do
   ;; valid value at this code-location. (unexported).
   (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
   ;; (unexported) To see SB!C::LOCATION-KIND, do

-  ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
-  (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)))
-
-(defstruct (interpreted-code-location
-           (:include code-location
-                     (%unknown-p nil))
-           (:constructor make-interpreted-code-location
-                         (ir1-node debug-function)))
-  ;; This is an index into debug-function's component slot.
-  (ir1-node nil :type sb!c::node))
-
-;;; DEBUG-SOURCEs
-
-#!-sb-fluid (declaim (inline debug-source-root-number))
+  ;; (SB!KERNEL:TYPEXPAND 'SB!C::LOCATION-KIND).
+  (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))
+  (step-info :unparsed :type (or (member :unparsed :foo) simple-string)))
+\f
+;;;; DEBUG-SOURCEs
+
+;;; Return the number of top level forms processed by the compiler
+;;; before compiling this source. If this source is uncompiled, this
+;;; is zero. This may be zero even if the source is compiled since the
+;;; first form in the first file compiled in one compilation, for
+;;; example, must have a root number of zero -- the compiler saw no
+;;; other top level forms before it.

 (defun debug-source-root-number (debug-source)
 (defun debug-source-root-number (debug-source)

-  #!+sb-doc
-  "Returns the number of top-level forms processed by the compiler before
-   compiling this source. If this source is uncompiled, this is zero. This
-   may be zero even if the source is compiled since the first form in the first
-   file compiled in one compilation, for example, must have a root number of
-   zero -- the compiler saw no other top-level forms before it."

   (sb!c::debug-source-source-root debug-source))
   (sb!c::debug-source-source-root debug-source))

-
-#!+sb-doc
-(setf (fdocumentation 'sb!c::debug-source-from 'function)
-  "Returns an indication of the type of source. The following are the possible
-   values:
-      :file    from a file (obtained by COMPILE-FILE if compiled).
-      :lisp    from Lisp (obtained by COMPILE if compiled).")
-
-#!+sb-doc
-(setf (fdocumentation 'sb!c::debug-source-name 'function)
-  "Returns the actual source in some sense represented by debug-source, which
-   is related to DEBUG-SOURCE-FROM:
-      :file    the pathname of the file.
-      :lisp    a lambda-expression.")
-
-#!+sb-doc
-(setf (fdocumentation 'sb!c::debug-source-created 'function)
-  "Returns the universal time someone created the source. This may be nil if
-   it is unavailable.")
-
-#!+sb-doc
-(setf (fdocumentation 'sb!c::debug-source-compiled 'function)
-  "Returns the time someone compiled the source. This is nil if the source
-   is uncompiled.")
-
-#!+sb-doc
-(setf (fdocumentation 'sb!c::debug-source-start-positions 'function)
-  "This function returns the file position of each top-level form as an array
-   if debug-source is from a :file. If DEBUG-SOURCE-FROM is :lisp,
-   this returns nil.")
-
-#!+sb-doc
-(setf (fdocumentation 'sb!c::debug-source-p 'function)
-  "Returns whether object is a debug-source.")

 \f
 ;;;; frames
 
 \f
 ;;;; frames
 

-;;; This is used in FIND-ESCAPE-FRAME and with the bogus components
-;;; and LRAs used for :function-end breakpoints. When a components
-;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the
+;;; This is used in FIND-ESCAPED-FRAME and with the bogus components
+;;; and LRAs used for :FUN-END breakpoints. When a component's
+;;; debug-info slot is :BOGUS-LRA, then the REAL-LRA-SLOT contains the

 ;;; real component to continue executing, as opposed to the bogus
 ;;; component which appeared in some frame's LRA location.
 (defconstant real-lra-slot sb!vm:code-constants-offset)
 ;;; real component to continue executing, as opposed to the bogus
 ;;; component which appeared in some frame's LRA location.
 (defconstant real-lra-slot sb!vm:code-constants-offset)

@@ -662,53 +509,63 @@
 (defun current-fp () (current-fp))
 (defun stack-ref (s n) (stack-ref s n))
 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))
 (defun current-fp () (current-fp))
 (defun stack-ref (s n) (stack-ref s n))
 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))

-(defun function-code-header (fun) (function-code-header fun))
-#!-gengc (defun lra-code-header (lra) (lra-code-header lra))
-(defun make-lisp-obj (value) (make-lisp-obj value))
+(defun fun-code-header (fun) (fun-code-header fun))
+(defun lra-code-header (lra) (lra-code-header lra))
+(defun %make-lisp-obj (value) (%make-lisp-obj value))

 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))

-(defun function-word-offset (fun) (function-word-offset fun))
+(defun fun-word-offset (fun) (fun-word-offset fun))

 
 

-#!-sb-fluid (declaim (inline cstack-pointer-valid-p))
-(defun cstack-pointer-valid-p (x)
+#!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
+(defun control-stack-pointer-valid-p (x &optional (aligned t))

   (declare (type system-area-pointer x))
   (declare (type system-area-pointer x))

-  #!-x86 ; stack grows toward high address values
-  (and (sap< x (current-sp))
-       (sap<= #!-gengc (int-sap control-stack-start)
-             #!+gengc (mutator-control-stack-base)
-             x)
-       (zerop (logand (sap-int x) #b11)))
-  #!+x86 ; stack grows toward low address values
-  (and (sap>= x (current-sp))
-       (sap> (int-sap control-stack-end) x)
-       (zerop (logand (sap-int x) #b11))))
-
-#!+(or gengc x86)
-(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
+  (let* (#!-stack-grows-downward-not-upward
+         (control-stack-start
+          (descriptor-sap *control-stack-start*))
+         #!+stack-grows-downward-not-upward
+         (control-stack-end
+          (descriptor-sap *control-stack-end*)))
+    #!-stack-grows-downward-not-upward
+    (and (sap< x (current-sp))
+         (sap<= control-stack-start x)
+         (or (not aligned) (zerop (logand (sap-int x)
+                                          (1- (ash 1 sb!vm:word-shift))))))
+    #!+stack-grows-downward-not-upward
+    (and (sap>= x (current-sp))
+         (sap> control-stack-end x)
+         (or (not aligned) (zerop (logand (sap-int x)
+                                          (1- (ash 1 sb!vm:word-shift))))))))
+
+(declaim (inline component-ptr-from-pc))
+(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)

   (pc system-area-pointer))
 
   (pc system-area-pointer))
 

-#!+(or gengc x86)
+(declaim (inline valid-lisp-pointer-p))
+(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
+  (pointer system-area-pointer))
+
+(declaim (inline component-from-component-ptr))

 (defun component-from-component-ptr (component-ptr)
   (declare (type system-area-pointer component-ptr))
   (make-lisp-obj (logior (sap-int component-ptr)
 (defun component-from-component-ptr (component-ptr)
   (declare (type system-area-pointer component-ptr))
   (make-lisp-obj (logior (sap-int component-ptr)

-                        sb!vm:other-pointer-type)))
+                         sb!vm:other-pointer-lowtag)))

 
 

-;;;; X86 support
-
-#!+x86
-(progn
+;;;; (OR X86 X86-64) support

 
 (defun compute-lra-data-from-pc (pc)
   (declare (type system-area-pointer pc))
   (let ((component-ptr (component-ptr-from-pc pc)))
     (unless (sap= component-ptr (int-sap #x0))
        (let* ((code (component-from-component-ptr component-ptr))
 
 (defun compute-lra-data-from-pc (pc)
   (declare (type system-area-pointer pc))
   (let ((component-ptr (component-ptr-from-pc pc)))
     (unless (sap= component-ptr (int-sap #x0))
        (let* ((code (component-from-component-ptr component-ptr))

-             (code-header-len (* (get-header-data code) sb!vm:word-bytes))
-             (pc-offset (- (sap-int pc)
-                           (- (get-lisp-obj-address code)
-                              sb!vm:other-pointer-type)
-                           code-header-len)))
-;       (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
-        (values pc-offset code)))))
+              (code-header-len (* (get-header-data code) sb!vm:n-word-bytes))
+              (pc-offset (- (sap-int pc)
+                            (- (get-lisp-obj-address code)
+                               sb!vm:other-pointer-lowtag)
+                            code-header-len)))
+         ;;(format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
+         (values pc-offset code)))))
+
+#!+(or x86 x86-64)
+(progn

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

@@ -720,10 +577,13 @@
 (defun ra-pointer-valid-p (ra)
   (declare (type system-area-pointer ra))
   (and
 (defun ra-pointer-valid-p (ra)
   (declare (type system-area-pointer ra))
   (and

-   ;; Not the first page which is unmapped.
+   ;; 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)
    (>= (sap-int ra) 4096)

-   ;; Not a Lisp stack pointer.
-   (not (cstack-pointer-valid-p ra))))
+   ;; 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
 
 ;;; 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

@@ -732,68 +592,19 @@
 ;;; XXX Should probably check whether it has reached the bottom of the
 ;;; stack.
 ;;;
 ;;; XXX Should probably check whether it has reached the bottom of the
 ;;; stack.
 ;;;

-;;; XXX Should handle interrupted frames, both Lisp and C. At present it
-;;; manages to find a fp trail, see linux hack below.
-(defun x86-call-context (fp &key (depth 8))
-  (declare (type system-area-pointer fp)
-          (fixnum depth))
-  ;;(format t "*CC ~S ~S~%" fp depth)
-  (cond
-   ((not (cstack-pointer-valid-p fp))
-    #+nil (format t "debug invalid fp ~S~%" fp)
-    nil)
-   (t
-    ;; Check the two possible frame pointers.
-    (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ sb!vm::ocfp-save-offset) 4))))
-         (lisp-ra (sap-ref-sap fp (- (* (1+ sb!vm::return-pc-save-offset)
-                                        4))))
-         (c-ocfp (sap-ref-sap fp (* 0 sb!vm:word-bytes)))
-         (c-ra (sap-ref-sap fp (* 1 sb!vm:word-bytes))))
-      (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
-                 (ra-pointer-valid-p lisp-ra)
-                 (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
-                 (ra-pointer-valid-p c-ra))
-            #+nil (format t
-                          "*C Both valid ~S ~S ~S ~S~%"
-                          lisp-ocfp lisp-ra c-ocfp c-ra)
-            ;; Look forward another step to check their validity.
-            (let ((lisp-path-fp (x86-call-context lisp-ocfp
-                                                  :depth (- depth 1)))
-                  (c-path-fp (x86-call-context c-ocfp :depth (- depth 1))))
-              (cond ((and lisp-path-fp c-path-fp)
-                     ;; Both still seem valid - choose the smallest.
-                     #+nil (format t "debug: both still valid ~S ~S ~S ~S~%"
-                                   lisp-ocfp lisp-ra c-ocfp c-ra)
-                     (if (sap< lisp-ocfp c-ocfp)
-                         (values lisp-ra lisp-ocfp)
-                       (values c-ra c-ocfp)))
-                    (lisp-path-fp
-                     ;; The lisp convention is looking good.
-                     #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
-                     (values lisp-ra lisp-ocfp))
-                    (c-path-fp
-                     ;; The C convention is looking good.
-                     #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
-                     (values c-ra c-ocfp))
-                    (t
-                     ;; Neither seems right?
-                     #+nil (format t "debug: no valid2 fp found ~S ~S~%"
-                                   lisp-ocfp c-ocfp)
-                     nil))))
-           ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
-                 (ra-pointer-valid-p lisp-ra))
-            ;; The lisp convention is looking good.
-            #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
-            (values lisp-ra lisp-ocfp))
-           ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
-                 #!-linux (ra-pointer-valid-p c-ra))
-            ;; The C convention is looking good.
-            #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
-            (values c-ra c-ocfp))
-           (t
-            #+nil (format t "debug: no valid fp found ~S ~S~%"
-                          lisp-ocfp c-ocfp)
-            nil))))))
+;;; XXX Should handle interrupted frames, both Lisp and C. At present
+;;; it manages to find a fp trail, see linux hack below.
+(declaim (maybe-inline x86-call-context))
+(defun x86-call-context (fp)
+  (declare (type system-area-pointer fp))
+  (let ((ocfp (sap-ref-sap fp (sb!vm::frame-byte-offset ocfp-save-offset)))
+        (ra (sap-ref-sap fp (sb!vm::frame-byte-offset return-pc-save-offset))))
+    (if (and (control-stack-pointer-valid-p fp)
+             (sap> ocfp fp)
+             (control-stack-pointer-valid-p ocfp)
+             (ra-pointer-valid-p ra))
+        (values t ra ocfp)
+        (values nil (int-sap 0) (int-sap 0)))))

 
 ) ; #+x86 PROGN
 \f
 
 ) ; #+x86 PROGN
 \f

@@ -803,184 +614,126 @@
 (defun descriptor-sap (x)
   (int-sap (get-lisp-obj-address x)))
 
 (defun descriptor-sap (x)
   (int-sap (get-lisp-obj-address x)))
 

+;;; Return the top frame of the control stack as it was before calling
+;;; this function.

 (defun top-frame ()
 (defun top-frame ()

-  #!+sb-doc
-  "Returns the top frame of the control stack as it was before calling this
-   function."
-  (multiple-value-bind (fp pc) (%caller-frame-and-pc)
-    (possibly-an-interpreted-frame
-     (compute-calling-frame (descriptor-sap fp)
-                           #!-gengc pc #!+gengc (descriptor-sap pc)
-                           nil)
-     nil)))
+  (/noshow0 "entering TOP-FRAME")
+  (compute-calling-frame (descriptor-sap (%caller-frame))
+                         (%caller-pc)
+                         nil))

 
 

+;;; Flush all of the frames above FRAME, and renumber all the frames
+;;; below FRAME.

 (defun flush-frames-above (frame)
 (defun flush-frames-above (frame)

-  #!+sb-doc
-  "Flush all of the frames above FRAME, and renumber all the frames below
-   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)))
 
   (setf (frame-up frame) nil)
   (do ((number 0 (1+ number))
        (frame frame (frame-%down frame)))
       ((not (frame-p frame)))
     (setf (frame-number frame) number)))
 

-;;; We have to access the old-fp and return-pc out of frame and pass them to
-;;; COMPUTE-CALLING-FRAME.
+(defun find-saved-frame-down (fp up-frame)
+  (multiple-value-bind (saved-fp saved-pc)
+      (sb!alien-internals:find-saved-fp-and-pc fp)
+    (when saved-fp
+      (compute-calling-frame (descriptor-sap saved-fp)
+                             (descriptor-sap saved-pc)
+                             up-frame
+                             t))))
+
+;;; Return the frame immediately below FRAME on the stack; or when
+;;; FRAME is the bottom of the stack, return NIL.

 (defun frame-down (frame)
 (defun frame-down (frame)

-  #!+sb-doc
-  "Returns the frame immediately below frame on the stack. When frame is
-   the bottom of the stack, this returns nil."
+  (/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 ((down (frame-%down frame)))
     (if (eq down :unparsed)

-       (let* ((real (frame-real-frame frame))
-              (debug-fun (frame-debug-function real)))
-         (setf (frame-%down frame)
-               (etypecase debug-fun
-                 (compiled-debug-function
-                  (let ((c-d-f (compiled-debug-function-compiler-debug-fun
-                                debug-fun)))
-                    (possibly-an-interpreted-frame
-                     (compute-calling-frame
-                      (descriptor-sap
-                       (get-context-value
-                        real sb!vm::ocfp-save-offset
-                        (sb!c::compiled-debug-function-old-fp c-d-f)))
-                      #!-gengc
-                      (get-context-value
-                       real sb!vm::lra-save-offset
-                       (sb!c::compiled-debug-function-return-pc c-d-f))
-                      #!+gengc
-                      (descriptor-sap
-                       (get-context-value
-                        real sb!vm::ra-save-offset
-                        (sb!c::compiled-debug-function-return-pc c-d-f)))
-                      frame)
-                     frame)))
-                 (bogus-debug-function
-                  (let ((fp (frame-pointer real)))
-                    (when (cstack-pointer-valid-p fp)
-                      #!+x86
-                       (multiple-value-bind (ra ofp) (x86-call-context fp)
-                         (compute-calling-frame ofp ra frame))
-                       #!-x86
-                      (compute-calling-frame
-                       #!-alpha
-                       (sap-ref-sap fp (* sb!vm::ocfp-save-offset
-                                          sb!vm:word-bytes))
-                       #!+alpha
-                       (int-sap
-                        (sap-ref-32 fp (* sb!vm::ocfp-save-offset
-                                          sb!vm:word-bytes)))
-
-                       #!-gengc
-                       (stack-ref fp sb!vm::lra-save-offset)
-                       #!+gengc
-                       (sap-ref-sap fp (* sb!vm::ra-save-offset
-                                          sb!vm:word-bytes))
-                       frame)))))))
-       down)))
+        (let ((debug-fun (frame-debug-fun frame)))
+          (/noshow0 "in DOWN :UNPARSED case")
+          (setf (frame-%down frame)
+                (etypecase debug-fun
+                  (compiled-debug-fun
+                   (let ((c-d-f (compiled-debug-fun-compiler-debug-fun
+                                 debug-fun)))
+                     (compute-calling-frame
+                      (descriptor-sap
+                       (get-context-value
+                        frame ocfp-save-offset
+                        (sb!c::compiled-debug-fun-old-fp c-d-f)))
+                      (get-context-value
+                       frame lra-save-offset
+                       (sb!c::compiled-debug-fun-return-pc c-d-f))
+                      frame)))
+                  (bogus-debug-fun
+                   (let ((fp (frame-pointer frame)))
+                     (when (control-stack-pointer-valid-p fp)
+                       #!+(or x86 x86-64)
+                       (multiple-value-bind (ok ra ofp) (x86-call-context fp)
+                         (if ok
+                             (compute-calling-frame ofp ra frame)
+                             (find-saved-frame-down fp frame)))
+                       #!-(or x86 x86-64)
+                       (compute-calling-frame
+                        #!-alpha
+                        (sap-ref-sap fp (* ocfp-save-offset
+                                           sb!vm:n-word-bytes))
+                        #!+alpha
+                        (int-sap
+                         (sap-ref-32 fp (* ocfp-save-offset
+                                           sb!vm:n-word-bytes)))
+
+                        (stack-ref fp lra-save-offset)
+
+                        frame)))))))
+        down)))

 
 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
 ;;; standard save location offset on the stack. LOC is the saved
 ;;; SC-OFFSET describing the main location.
 
 ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
 ;;; standard save location offset on the stack. LOC is the saved
 ;;; SC-OFFSET describing the main location.

-#!-x86
-(defun get-context-value (frame stack-slot loc)
-  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
-          (type sb!c::sc-offset loc))
-  (let ((pointer (frame-pointer frame))
-       (escaped (compiled-frame-escaped frame)))
-    (if escaped
-       (sub-access-debug-var-slot pointer loc escaped)
-       (stack-ref pointer stack-slot))))
-#!+x86

 (defun get-context-value (frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
 (defun get-context-value (frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)

-          (type sb!c::sc-offset loc))
+           (type sb!c:sc-offset loc))

   (let ((pointer (frame-pointer frame))
   (let ((pointer (frame-pointer frame))

-       (escaped (compiled-frame-escaped frame)))
+        (escaped (compiled-frame-escaped frame)))

     (if escaped
     (if escaped

-       (sub-access-debug-var-slot pointer loc escaped)
-       (ecase stack-slot
-         (#.sb!vm::ocfp-save-offset
-          (stack-ref pointer stack-slot))
-         (#.sb!vm::lra-save-offset
-          (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
-
-#!-x86
-(defun (setf get-context-value) (value frame stack-slot loc)
-  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
-          (type sb!c::sc-offset loc))
-  (let ((pointer (frame-pointer frame))
-       (escaped (compiled-frame-escaped frame)))
-    (if escaped
-       (sub-set-debug-var-slot pointer loc value escaped)
-       (setf (stack-ref pointer stack-slot) value))))
+        (sub-access-debug-var-slot pointer loc escaped)
+        #!-(or x86 x86-64)
+        (stack-ref pointer stack-slot)
+        #!+(or x86 x86-64)
+        (ecase stack-slot
+          (#.ocfp-save-offset
+           (stack-ref pointer stack-slot))
+          (#.lra-save-offset
+           (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot)))))))

 
 

-#!+x86

 (defun (setf get-context-value) (value frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
 (defun (setf get-context-value) (value frame stack-slot loc)
   (declare (type compiled-frame frame) (type unsigned-byte stack-slot)

-          (type sb!c::sc-offset loc))
+           (type sb!c:sc-offset loc))

   (let ((pointer (frame-pointer frame))
   (let ((pointer (frame-pointer frame))

-       (escaped (compiled-frame-escaped frame)))
+        (escaped (compiled-frame-escaped frame)))

     (if escaped
     (if escaped

-       (sub-set-debug-var-slot pointer loc value escaped)
-       (ecase stack-slot
-         (#.sb!vm::ocfp-save-offset
-          (setf (stack-ref pointer stack-slot) value))
-         (#.sb!vm::lra-save-offset
-          (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
-
-(defvar *debugging-interpreter* nil
-  #!+sb-doc
-  "When set, the debugger foregoes making interpreted-frames, so you can
-   debug the functions that manifest the interpreter.")
-
-;;; This takes a newly computed frame, FRAME, and the frame above it
-;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when
-;;; we hit the bottom of the control stack. When FRAME represents a
-;;; call to SB!EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame
-;;; to replace FRAME. The interpreted frame points to FRAME.
-(defun possibly-an-interpreted-frame (frame up-frame)
-  (if (or (not frame)
-         (not (eq (debug-function-name (frame-debug-function frame))
-                  'sb!eval::internal-apply-loop))
-         *debugging-interpreter*
-         (compiled-frame-escaped frame))
-      frame
-      (flet ((get-var (name location)
-              (let ((vars (sb!di:ambiguous-debug-vars
-                           (sb!di:frame-debug-function frame) name)))
-                (when (or (null vars) (> (length vars) 1))
-                  (error "zero or more than one ~A variable in ~
-                          SB!EVAL::INTERNAL-APPLY-LOOP"
-                         (string-downcase name)))
-                (if (eq (debug-var-validity (car vars) location)
-                        :valid)
-                    (car vars)))))
-       (let* ((code-loc (frame-code-location frame))
-              (ptr-var (get-var "FRAME-PTR" code-loc))
-              (node-var (get-var "NODE" code-loc))
-              (closure-var (get-var "CLOSURE" code-loc)))
-         (if (and ptr-var node-var closure-var)
-             (let* ((node (debug-var-value node-var frame))
-                    (d-fun (make-interpreted-debug-function
-                            (sb!c::block-home-lambda (sb!c::node-block
-                                                      node)))))
-               (make-interpreted-frame
-                (debug-var-value ptr-var frame)
-                up-frame
-                d-fun
-                (make-interpreted-code-location node d-fun)
-                (frame-number frame)
-                frame
-                (debug-var-value closure-var frame)))
-             frame)))))
+        (sub-set-debug-var-slot pointer loc value escaped)
+        #!-(or x86 x86-64)
+        (setf (stack-ref pointer stack-slot) value)
+        #!+(or x86 x86-64)
+        (ecase stack-slot
+          (#.ocfp-save-offset
+           (setf (stack-ref pointer stack-slot) value))
+          (#.lra-save-offset
+           (setf (sap-ref-sap pointer (sb!vm::frame-byte-offset stack-slot))
+                 value))))))
+
+(defun foreign-function-backtrace-name (sap)
+  (let ((name (sap-foreign-symbol sap)))
+    (if name
+        (format nil "foreign function: ~A" name)
+        (format nil "foreign function: #x~X" (sap-int sap)))))

 
 ;;; This returns a frame for the one existing in time immediately
 ;;; prior to the frame referenced by current-fp. This is current-fp's
 ;;; caller or the next frame down the control stack. If there is no
 
 ;;; 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 nil when
+;;; 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
 ;;; we call this to get the top of the stack.
 ;;;
 ;;; The current frame contains the pointer to the temporally previous

@@ -990,722 +743,742 @@
 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
 ;;; calls into C. In this case, the code object is stored on the stack
 ;;; after the LRA, and the LRA is the word offset.
 ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
 ;;; calls into C. In this case, the code object is stored on the stack
 ;;; after the LRA, and the LRA is the word offset.

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

 (defun compute-calling-frame (caller lra up-frame)
   (declare (type system-area-pointer caller))
 (defun compute-calling-frame (caller lra up-frame)
   (declare (type system-area-pointer caller))

-  (when (cstack-pointer-valid-p caller)
+  (/noshow0 "entering COMPUTE-CALLING-FRAME")
+  (when (control-stack-pointer-valid-p caller)
+    (/noshow0 "in WHEN")

     (multiple-value-bind (code pc-offset escaped)
     (multiple-value-bind (code pc-offset escaped)

-       (if lra
-           (multiple-value-bind (word-offset code)
-               (if (fixnump lra)
-                   (let ((fp (frame-pointer up-frame)))
-                     (values lra
-                             (stack-ref fp (1+ sb!vm::lra-save-offset))))
-                   (values (get-header-data lra)
-                           (lra-code-header lra)))
-             (if code
-                 (values code
-                         (* (1+ (- word-offset (get-header-data code)))
-                            sb!vm:word-bytes)
-                         nil)
-                 (values :foreign-function
-                         0
-                         nil)))
-           (find-escaped-frame caller))
+        (if lra
+            (multiple-value-bind (word-offset code)
+                (if (fixnump lra)
+                    (let ((fp (frame-pointer up-frame)))
+                      (values lra
+                              (stack-ref fp (1+ lra-save-offset))))
+                    (values (get-header-data lra)
+                            (lra-code-header lra)))
+              (if code
+                  (values code
+                          (* (1+ (- word-offset (get-header-data code)))
+                             sb!vm:n-word-bytes)
+                          nil)
+                  (values :foreign-function
+                          0
+                          nil)))
+            (find-escaped-frame caller))

       (if (and (code-component-p code)
       (if (and (code-component-p code)

-              (eq (%code-debug-info code) :bogus-lra))
-         (let ((real-lra (code-header-ref code real-lra-slot)))
-           (compute-calling-frame caller real-lra up-frame))
-         (let ((d-fun (case code
-                        (:undefined-function
-                         (make-bogus-debug-function
-                          "undefined function"))
-                        (:foreign-function
-                         (make-bogus-debug-function
-                          "foreign function call land"))
-                        ((nil)
-                         (make-bogus-debug-function
-                          "bogus stack frame"))
-                        (t
-                         (debug-function-from-pc code pc-offset)))))
-           (make-compiled-frame caller up-frame d-fun
-                                (code-location-from-pc d-fun pc-offset
-                                                       escaped)
-                                (if up-frame (1+ (frame-number up-frame)) 0)
-                                escaped))))))
-
-#!+x86
-(defun compute-calling-frame (caller ra up-frame)
+               (eq (%code-debug-info code) :bogus-lra))
+          (let ((real-lra (code-header-ref code real-lra-slot)))
+            (compute-calling-frame caller real-lra up-frame))
+          (let ((d-fun (case code
+                         (:undefined-function
+                          (make-bogus-debug-fun
+                           "undefined function"))
+                         (:foreign-function
+                          (make-bogus-debug-fun
+                           (foreign-function-backtrace-name
+                            (int-sap (get-lisp-obj-address lra)))))
+                         ((nil)
+                          (make-bogus-debug-fun
+                           "bogus stack frame"))
+                         (t
+                          (debug-fun-from-pc code pc-offset)))))
+            (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+            (make-compiled-frame caller up-frame d-fun
+                                 (code-location-from-pc d-fun pc-offset
+                                                        escaped)
+                                 (if up-frame (1+ (frame-number up-frame)) 0)
+                                 escaped))))))
+
+#!+(or x86 x86-64)
+(defun compute-calling-frame (caller ra up-frame &optional savedp)

   (declare (type system-area-pointer caller ra))
   (declare (type system-area-pointer caller ra))

-;  (format t "ccf: ~A ~A ~A~%" caller ra up-frame)
-  (when (cstack-pointer-valid-p caller)
-;    (format t "ccf2~%")
+  (/noshow0 "entering COMPUTE-CALLING-FRAME")
+  (when (control-stack-pointer-valid-p caller)
+    (/noshow0 "in WHEN")

     ;; First check for an escaped frame.
     ;; First check for an escaped frame.

-    (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
-       (cond (code
-              ;; If it's escaped it may be a function end breakpoint trap.
-;             (format t "ccf2: escaped ~S ~S~%" code pc-offset)
-              (when (and (code-component-p code)
-                         (eq (%code-debug-info code) :bogus-lra))
-                ;; If :bogus-lra grab the real lra.
-                (setq pc-offset (code-header-ref
-                                 code (1+ real-lra-slot)))
-                (setq code (code-header-ref code real-lra-slot))
-;               (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset)
-                (assert code)))
-             (t
-              ;; Not escaped
-              (multiple-value-setq (pc-offset code)
-                (compute-lra-data-from-pc ra))
-;             (format t "ccf4 ~S ~S~%" code pc-offset)
-              (unless code
-                (setf code :foreign-function
-                      pc-offset 0
-                      escaped nil))))
-
-       (let ((d-fun (case code
-                          (:undefined-function
-                           (make-bogus-debug-function
-                            "undefined function"))
-                          (:foreign-function
-                           (make-bogus-debug-function
-                            "foreign function call land"))
-                          ((nil)
-                           (make-bogus-debug-function
-                            "bogus stack frame"))
-                          (t
-                           (debug-function-from-pc code pc-offset)))))
-         (make-compiled-frame caller up-frame d-fun
-                              (code-location-from-pc d-fun pc-offset
-                                                     escaped)
-                              (if up-frame (1+ (frame-number up-frame)) 0)
-                              escaped)))))
-
-#!-(or gengc x86)
-;;; FIXME: The original CMU CL code had support for this case, but it
-;;; must have been fairly stale even in CMU CL, since it had
-;;; references to the MIPS package, and there have been enough
-;;; relevant changes in SBCL (particularly using
-;;; POSIX/SIGACTION0-style signal context instead of BSD-style
-;;; sigcontext) that this code is unmaintainable (since as of
-;;; sbcl-0.6.7, and for the foreseeable future, we can't test it,
-;;; since we only support X86 and its gencgc).
-;;;
-;;; If we restore this case, the best approach would be to go back to
-;;; the original CMU CL code and start from there.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (error "hopelessly stale"))
-#!+x86
+    (multiple-value-bind (code pc-offset escaped off-stack)
+        (find-escaped-frame caller)
+      (/noshow0 "at COND")
+      (cond (code
+             ;; If it's escaped it may be a function end breakpoint trap.
+             (when (and (code-component-p code)
+                        (eq (%code-debug-info code) :bogus-lra))
+               ;; If :bogus-lra grab the real lra.
+               (setq pc-offset (code-header-ref
+                                code (1+ real-lra-slot)))
+               (setq code (code-header-ref code real-lra-slot))
+               (aver code)))
+            ((not escaped)
+             (multiple-value-setq (pc-offset code)
+               (compute-lra-data-from-pc ra))
+             (unless code
+               (setf code :foreign-function
+                     pc-offset 0))))
+      (let ((d-fun (case code
+                     (:undefined-function
+                      (make-bogus-debug-fun
+                       "undefined function"))
+                     (:foreign-function
+                      (make-bogus-debug-fun
+                       (foreign-function-backtrace-name ra)))
+                     ((nil)
+                      (make-bogus-debug-fun
+                       "bogus stack frame"))
+                     (t
+                      (debug-fun-from-pc code pc-offset)))))
+        (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
+        (make-compiled-frame caller up-frame d-fun
+                             (code-location-from-pc d-fun pc-offset
+                                                    escaped)
+                             (if up-frame (1+ (frame-number up-frame)) 0)
+                             ;; If we have an interrupt-context that's not on
+                             ;; our stack at all, and we're computing the
+                             ;; from from a saved FP, we're probably looking
+                             ;; at an interrupted syscall.
+                             (or escaped (and savedp off-stack)))))))
+
+(defun nth-interrupt-context (n)
+  (declare (type (unsigned-byte 32) n)
+           (optimize (speed 3) (safety 0)))
+  (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
+                       (+ sb!vm::thread-interrupt-contexts-offset
+                          #!-alpha n
+                          #!+alpha (* 2 n)))
+                      (* os-context-t)))
+
+;;;; Perform the lookup which FOREIGN-SYMBOL-ADDRESS would do if the
+;;;; linkage table were disabled, i.e. always return the actual symbol
+;;;; address, not the linkage table trampoline, even if the symbol would
+;;;; ordinarily go through the linkage table.  Important when
+;;;; SB-DYNAMIC-CORE is enabled and our caller assumes `name' to be a
+;;;; "static" symbol; a concept which doesn't exist in such builds.
+(defun true-foreign-symbol-address (name)
+  #!+linkage-table  ;we have dlsym -- let's use it.
+  (find-dynamic-foreign-symbol-address name)
+  #!-linkage-table  ;possibly no dlsym, but hence no indirection anyway.
+  (foreign-symbol-address))
+
+;;;; See above.
+(defun true-foreign-symbol-sap (name)
+  (int-sap (true-foreign-symbol-address name)))
+
+#!+(or x86 x86-64)
+(defun find-escaped-frame (frame-pointer)
+  (declare (type system-area-pointer frame-pointer))
+  (/noshow0 "entering FIND-ESCAPED-FRAME")
+  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
+    (let* ((context (nth-interrupt-context index))
+           (cfp (int-sap (sb!vm:context-register context sb!vm::cfp-offset))))
+      (/noshow0 "got CONTEXT")
+      (unless (control-stack-pointer-valid-p cfp)
+        (return (values nil nil nil t)))
+      (when (sap= frame-pointer cfp)
+        (without-gcing
+          (/noshow0 "in WITHOUT-GCING")
+          (let* ((component-ptr (component-ptr-from-pc
+                                 (sb!vm:context-pc context)))
+                 (code (unless (sap= component-ptr (int-sap #x0))
+                         (component-from-component-ptr component-ptr))))
+            (/noshow0 "got CODE")
+            (when (null code)
+              ;; KLUDGE: Detect undefined functions by a range-check
+              ;; against the trampoline address and the following
+              ;; function in the runtime.
+              (if (< (true-foreign-symbol-address "undefined_tramp")
+                     (sap-int (sb!vm:context-pc context))
+                     (true-foreign-symbol-address #!+x86 "closure_tramp"
+                                                    #!+x86-64 "alloc_tramp"))
+                  (return (values :undefined-function 0 context))
+                  (return (values code 0 context))))
+            (let* ((code-header-len (* (get-header-data code)
+                                       sb!vm:n-word-bytes))
+                   (pc-offset
+                     (- (sap-int (sb!vm:context-pc context))
+                        (- (get-lisp-obj-address code)
+                           sb!vm:other-pointer-lowtag)
+                        code-header-len)))
+              (/noshow "got PC-OFFSET")
+              (unless (<= 0 pc-offset
+                          (* (code-header-ref code sb!vm:code-code-size-slot)
+                             sb!vm:n-word-bytes))
+                ;; We were in an assembly routine. Therefore, use the
+                ;; LRA as the pc.
+                ;;
+                ;; FIXME: Should this be WARN or ERROR or what?
+                (format t "** pc-offset ~S not in code obj ~S?~%"
+                        pc-offset code))
+              (/noshow0 "returning from FIND-ESCAPED-FRAME")
+              (return
+                (values code pc-offset context)))))))))
+
+#!-(or x86 x86-64)

 (defun find-escaped-frame (frame-pointer)
   (declare (type system-area-pointer frame-pointer))
 (defun find-escaped-frame (frame-pointer)
   (declare (type system-area-pointer frame-pointer))

-  (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil))
-    (sb!alien:with-alien
-       ((lisp-interrupt-contexts (array (* os-context-t) nil)
-                                 :extern))
-      (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
-       (when (= (sap-int frame-pointer)
-                (sb!vm:context-register context sb!vm::cfp-offset))
-         (without-gcing
-          (let* ((component-ptr (component-ptr-from-pc
-                                 (sb!vm:context-pc context)))
-                 (code (if (sap= component-ptr (int-sap #x0))
-                           nil ; FIXME: UNLESS might be clearer than IF.
-                           (component-from-component-ptr component-ptr))))
-            (when (null code)
-              (return (values code 0 context)))
-            (let* ((code-header-len (* (get-header-data code)
-                                       sb!vm:word-bytes))
-                   (pc-offset
-                    (- (sap-int (sb!vm:context-pc context))
-                       (- (get-lisp-obj-address code)
-                          sb!vm:other-pointer-type)
-                       code-header-len)))
-              (unless (<= 0 pc-offset
-                          (* (code-header-ref code sb!vm:code-code-size-slot)
-                             sb!vm:word-bytes))
-                ;; We were in an assembly routine. Therefore, use the LRA as
-                ;; the pc.
-                (format t "** pc-offset ~S not in code obj ~S?~%"
-                        pc-offset code))
-              (return
-               (values code pc-offset context))))))))))
+  (/noshow0 "entering FIND-ESCAPED-FRAME")
+  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
+    (let ((scp (nth-interrupt-context index)))
+      (/noshow0 "got SCP")
+      (when (= (sap-int frame-pointer)
+               (sb!vm:context-register scp sb!vm::cfp-offset))
+        (without-gcing
+          (/noshow0 "in WITHOUT-GCING")
+          (let ((code (code-object-from-bits
+                       (sb!vm:context-register scp sb!vm::code-offset))))
+            (/noshow0 "got CODE")
+            (when (symbolp code)
+              (return (values code 0 scp)))
+            (let* ((code-header-len (* (get-header-data code)
+                                       sb!vm:n-word-bytes))
+                   (pc-offset
+                     (- (sap-int (sb!vm:context-pc scp))
+                        (- (get-lisp-obj-address code)
+                           sb!vm:other-pointer-lowtag)
+                        code-header-len)))
+              (let ((code-size (* (code-header-ref code
+                                                   sb!vm:code-code-size-slot)
+                                  sb!vm:n-word-bytes)))
+                (unless (<= 0 pc-offset code-size)
+                  ;; We were in an assembly routine.
+                  (multiple-value-bind (new-pc-offset computed-return)
+                      (find-pc-from-assembly-fun code scp)
+                    (setf pc-offset new-pc-offset)
+                    (unless (<= 0 pc-offset code-size)
+                      (cerror
+                       "Set PC-OFFSET to zero and continue backtrace."
+                       'bug
+                       :format-control
+                       "~@<PC-OFFSET (~D) not in code object. Frame details:~
+                       ~2I~:@_PC: #X~X~:@_CODE: ~S~:@_CODE FUN: ~S~:@_LRA: ~
+                       #X~X~:@_COMPUTED RETURN: #X~X.~:>"
+                       :format-arguments
+                       (list pc-offset
+                             (sap-int (sb!vm:context-pc scp))
+                             code
+                             (%code-entry-points code)
+                             (sb!vm:context-register scp sb!vm::lra-offset)
+                             computed-return))
+                      ;; We failed to pinpoint where PC is, but set
+                      ;; pc-offset to 0 to keep the backtrace from
+                      ;; exploding.
+                      (setf pc-offset 0)))))
+              (/noshow0 "returning from FIND-ESCAPED-FRAME")
+              (return
+                (if (eq (%code-debug-info code) :bogus-lra)
+                    (let ((real-lra (code-header-ref code
+                                                     real-lra-slot)))
+                      (values (lra-code-header real-lra)
+                              (get-header-data real-lra)
+                              nil))
+                    (values code pc-offset scp))))))))))
+
+#!-(or x86 x86-64)
+(defun find-pc-from-assembly-fun (code scp)
+  "Finds the PC for the return from an assembly routine properly.
+For some architectures (such as PPC) this will not be the $LRA
+register."
+  (let ((return-machine-address (sb!vm::return-machine-address scp))
+        (code-header-len (* (get-header-data code) sb!vm:n-word-bytes)))
+    (values (- return-machine-address
+               (- (get-lisp-obj-address code)
+                  sb!vm:other-pointer-lowtag)
+               code-header-len)
+            return-machine-address)))

 
 ;;; Find the code object corresponding to the object represented by
 ;;; bits and return it. We assume bogus functions correspond to the
 ;;; undefined-function.
 
 ;;; Find the code object corresponding to the object represented by
 ;;; bits and return it. We assume bogus functions correspond to the
 ;;; undefined-function.

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

 (defun code-object-from-bits (bits)
   (declare (type (unsigned-byte 32) bits))
 (defun code-object-from-bits (bits)
   (declare (type (unsigned-byte 32) bits))

-  (let ((object (make-lisp-obj bits)))
+  (let ((object (make-lisp-obj bits nil)))

     (if (functionp object)
     (if (functionp object)

-       (or (function-code-header object)
-           :undefined-function)
-       (let ((lowtag (get-lowtag object)))
-         (if (= lowtag sb!vm:other-pointer-type)
-             (let ((type (get-type object)))
-               (cond ((= type sb!vm:code-header-type)
-                      object)
-                     ((= type sb!vm:return-pc-header-type)
-                      (lra-code-header object))
-                     (t
-                      nil))))))))
-
-;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a
-;;; list of SAPs, each SAP pointing to a saved exception state.
-#!+gengc
-(declaim (special *saved-state-chain*))
-
-;;; CMU CL had
-;;;   (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (error "hopelessly stale"))
-
-;;; CMU CL had
-;;;   (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (error "hopelessly stale"))
-
-;;; CMU CL had
-;;;   (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (error "hopelessly stale"))
+        (or (fun-code-header object)
+            :undefined-function)
+        (let ((lowtag (lowtag-of object)))
+          (when (= lowtag sb!vm:other-pointer-lowtag)
+            (let ((widetag (widetag-of object)))
+              (cond ((= widetag sb!vm:code-header-widetag)
+                     object)
+                    ((= widetag sb!vm:return-pc-header-widetag)
+                     (lra-code-header object))
+                    (t
+                     nil))))))))

 \f
 ;;;; frame utilities
 
 \f
 ;;;; frame utilities
 

-;;; This returns a COMPILED-DEBUG-FUNCTION for code and pc. We fetch
-;;; the SB!C::DEBUG-INFO and run down its function-map to get a
-;;; SB!C::COMPILED-DEBUG-FUNCTION from the pc. The result only needs
-;;; to reference the component, for function constants, and the
-;;; SB!C::COMPILED-DEBUG-FUNCTION.
-(defun debug-function-from-pc (component pc)
+;;; This returns a COMPILED-DEBUG-FUN for COMPONENT and PC. We fetch the
+;;; SB!C::DEBUG-INFO and run down its FUN-MAP to get a
+;;; SB!C::COMPILED-DEBUG-FUN from the PC. The result only needs to
+;;; reference the COMPONENT, for function constants, and the
+;;; SB!C::COMPILED-DEBUG-FUN.
+(defun debug-fun-from-pc (component pc)

   (let ((info (%code-debug-info component)))
     (cond
   (let ((info (%code-debug-info component)))
     (cond

-     ((not info)
-      (debug-signal 'no-debug-info))
+      ((not info)
+       ;; FIXME: It seems that most of these (at least on x86) are
+       ;; actually assembler routines, and could be named by looking
+       ;; at the sb-fasl:*assembler-routines*.
+       (make-bogus-debug-fun "no debug information for frame"))

      ((eq info :bogus-lra)
      ((eq info :bogus-lra)

-      (make-bogus-debug-function "function end breakpoint"))
+      (make-bogus-debug-fun "function end breakpoint"))

      (t
      (t

-      (let* ((function-map (get-debug-info-function-map info))
-            (len (length function-map)))
-       (declare (simple-vector function-map))
-       (if (= len 1)
-           (make-compiled-debug-function (svref function-map 0) component)
-           (let ((i 1)
-                 (elsewhere-p
-                  (>= pc (sb!c::compiled-debug-function-elsewhere-pc
-                          (svref function-map 0)))))
-             ;; FIXME: I don't think SB!C is the home package of INDEX.
-             (declare (type sb!c::index i))
-             (loop
-               (when (or (= i len)
-                         (< pc (if elsewhere-p
-                                   (sb!c::compiled-debug-function-elsewhere-pc
-                                    (svref function-map (1+ i)))
-                                   (svref function-map i))))
-                 (return (make-compiled-debug-function
-                          (svref function-map (1- i))
-                          component)))
-               (incf i 2)))))))))
-
-;;; This returns a code-location for the COMPILED-DEBUG-FUNCTION,
+      (let* ((fun-map (sb!c::compiled-debug-info-fun-map info))
+             (len (length fun-map)))
+        (declare (type simple-vector fun-map))
+        (if (= len 1)
+            (make-compiled-debug-fun (svref fun-map 0) component)
+            (let ((i 1)
+                  (elsewhere-p
+                   (>= pc (sb!c::compiled-debug-fun-elsewhere-pc
+                           (svref fun-map 0)))))
+              (declare (type sb!int:index i))
+              (loop
+                (when (or (= i len)
+                          (< pc (if elsewhere-p
+                                    (sb!c::compiled-debug-fun-elsewhere-pc
+                                     (svref fun-map (1+ i)))
+                                    (svref fun-map i))))
+                  (return (make-compiled-debug-fun
+                           (svref fun-map (1- i))
+                           component)))
+                (incf i 2)))))))))
+
+;;; This returns a code-location for the COMPILED-DEBUG-FUN,

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

-  #!+sb-doc
-  "Returns an a-list 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."
-  (let ((catch
-        #!-gengc (descriptor-sap sb!impl::*current-catch-block*)
-        #!+gengc (mutator-current-catch-block))
-       (res nil)
-       (fp (frame-pointer (frame-real-frame frame))))
-    (loop
-      (when (zerop (sap-int catch)) (return (nreverse res)))
-      (when (sap= fp
-                 #!-alpha
-                 (sap-ref-sap catch
-                                     (* sb!vm:catch-block-current-cont-slot
-                                        sb!vm:word-bytes))
-                 #!+alpha
-                 (:int-sap
-                  (sap-ref-32 catch
-                                     (* sb!vm:catch-block-current-cont-slot
-                                        sb!vm:word-bytes))))
-       (let* (#!-(or gengc x86)
-              (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
-              #!+(or gengc x86)
-              (ra (sap-ref-sap
-                   catch (* sb!vm:catch-block-entry-pc-slot
-                            sb!vm:word-bytes)))
-              #!-x86
-              (component
-               (stack-ref catch sb!vm:catch-block-current-code-slot))
-              #!+x86
-              (component (component-from-component-ptr
-                          (component-ptr-from-pc ra)))
-              (offset
-               #!-(or gengc x86)
-               (* (- (1+ (get-header-data lra))
-                     (get-header-data component))
-                  sb!vm:word-bytes)
-               #!+gengc
-               (+ (- (sap-int ra)
-                     (get-lisp-obj-address component)
-                     (get-header-data component))
-                  sb!vm:other-pointer-type)
-               #!+x86
-               (- (sap-int ra)
-                  (- (get-lisp-obj-address component)
-                     sb!vm:other-pointer-type)
-                  (* (get-header-data component) sb!vm:word-bytes))))
-         (push (cons #!-x86
-                     (stack-ref catch sb!vm:catch-block-tag-slot)
-                     #!+x86
-                     (make-lisp-obj
-                      (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
-                                                  sb!vm:word-bytes)))
-                     (make-compiled-code-location
-                      offset (frame-debug-function frame)))
-               res)))
-      (setf catch
-           #!-alpha
-           (sap-ref-sap catch
-                               (* sb!vm:catch-block-previous-catch-slot
-                                  sb!vm:word-bytes))
-           #!+alpha
-           (:int-sap
-            (sap-ref-32 catch
-                               (* sb!vm:catch-block-previous-catch-slot
-                                  sb!vm:word-bytes)))))))
-
-;;; If an interpreted frame, return the real frame, otherwise frame.
-(defun frame-real-frame (frame)
-  (etypecase frame
-    (compiled-frame frame)
-    (interpreted-frame (interpreted-frame-real-frame frame))))
-\f
-;;;; operations on DEBUG-FUNCTIONs
+  (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+        (reversed-result nil)
+        (fp (frame-pointer frame)))
+    (loop until (zerop (sap-int catch))
+          finally (return (nreverse reversed-result))
+          do
+          (when (sap= fp
+                      #!-alpha
+                      (sap-ref-sap catch
+                                   (* sb!vm:catch-block-current-cont-slot
+                                      sb!vm:n-word-bytes))
+                      #!+alpha
+                      (int-sap
+                       (sap-ref-32 catch
+                                   (* sb!vm:catch-block-current-cont-slot
+                                      sb!vm:n-word-bytes))))
+            (let* (#!-(or x86 x86-64)
+                   (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
+                   #!+(or x86 x86-64)
+                   (ra (sap-ref-sap
+                        catch (* sb!vm:catch-block-entry-pc-slot
+                                 sb!vm:n-word-bytes)))
+                   #!-(or x86 x86-64)
+                   (component
+                    (stack-ref catch sb!vm:catch-block-current-code-slot))
+                   #!+(or x86 x86-64)
+                   (component (component-from-component-ptr
+                               (component-ptr-from-pc ra)))
+                   (offset
+                    #!-(or x86 x86-64)
+                    (* (- (1+ (get-header-data lra))
+                          (get-header-data component))
+                       sb!vm:n-word-bytes)
+                    #!+(or x86 x86-64)
+                    (- (sap-int ra)
+                       (- (get-lisp-obj-address component)
+                          sb!vm:other-pointer-lowtag)
+                       (* (get-header-data component) sb!vm:n-word-bytes))))
+              (push (cons #!-(or x86 x86-64)
+                          (stack-ref catch sb!vm:catch-block-tag-slot)
+                          #!+(or x86 x86-64)
+                          (make-lisp-obj
+                           (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+                                                  sb!vm:n-word-bytes)))
+                          (make-compiled-code-location
+                           offset (frame-debug-fun frame)))
+                    reversed-result)))
+          (setf catch
+                #!-alpha
+                (sap-ref-sap catch
+                             (* sb!vm:catch-block-previous-catch-slot
+                                sb!vm:n-word-bytes))
+                #!+alpha
+                (int-sap
+                 (sap-ref-32 catch
+                             (* sb!vm:catch-block-previous-catch-slot
+                                sb!vm:n-word-bytes)))))))
+
+;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
+(defun replace-frame-catch-tag (frame old-tag new-tag)
+  (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+        (fp (frame-pointer frame)))
+    (loop until (zerop (sap-int catch))
+          do (when (sap= fp
+                         #!-alpha
+                         (sap-ref-sap catch
+                                      (* sb!vm:catch-block-current-cont-slot
+                                         sb!vm:n-word-bytes))
+                         #!+alpha
+                         (int-sap
+                          (sap-ref-32 catch
+                                      (* sb!vm:catch-block-current-cont-slot
+                                         sb!vm:n-word-bytes))))
+               (let ((current-tag
+                      #!-(or x86 x86-64)
+                      (stack-ref catch sb!vm:catch-block-tag-slot)
+                      #!+(or x86 x86-64)
+                      (make-lisp-obj
+                       (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+                                              sb!vm:n-word-bytes)))))
+                 (when (eq current-tag old-tag)
+                   #!-(or x86 x86-64)
+                   (setf (stack-ref catch sb!vm:catch-block-tag-slot) new-tag)
+                   #!+(or x86 x86-64)
+                   (setf (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+                                                sb!vm:n-word-bytes))
+                         (get-lisp-obj-address new-tag)))))
+          do (setf catch
+                   #!-alpha
+                   (sap-ref-sap catch
+                                (* sb!vm:catch-block-previous-catch-slot
+                                   sb!vm:n-word-bytes))
+                   #!+alpha
+                   (int-sap
+                    (sap-ref-32 catch
+                                (* sb!vm:catch-block-previous-catch-slot
+                                   sb!vm:n-word-bytes)))))))

 
 

-(defmacro do-debug-function-blocks ((block-var debug-function &optional result)
-                                   &body body)
-  #!+sb-doc
-  "Executes the forms in a context with block-var bound to each debug-block in
-   debug-function successively. Result is an optional form to execute for
-   return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no
-   result form. This signals a no-debug-blocks condition when the
-   debug-function lacks debug-block information."
+
+\f
+;;;; operations on DEBUG-FUNs
+
+;;; Execute the forms in a context with BLOCK-VAR bound to each
+;;; DEBUG-BLOCK in DEBUG-FUN successively. Result is an optional
+;;; form to execute for return values, and DO-DEBUG-FUN-BLOCKS
+;;; returns nil if there is no result form. This signals a
+;;; NO-DEBUG-BLOCKS condition when the DEBUG-FUN lacks
+;;; DEBUG-BLOCK information.
+(defmacro do-debug-fun-blocks ((block-var debug-fun &optional result)
+                               &body body)

   (let ((blocks (gensym))
   (let ((blocks (gensym))

-       (i (gensym)))
-    `(let ((,blocks (debug-function-debug-blocks ,debug-function)))
+        (i (gensym)))
+    `(let ((,blocks (debug-fun-debug-blocks ,debug-fun)))

        (declare (simple-vector ,blocks))
        (dotimes (,i (length ,blocks) ,result)
        (declare (simple-vector ,blocks))
        (dotimes (,i (length ,blocks) ,result)

-        (let ((,block-var (svref ,blocks ,i)))
-          ,@body)))))
-
-(defmacro do-debug-function-variables ((var debug-function &optional result)
-                                      &body body)
-  #!+sb-doc
-  "Executes body in a context with var bound to each debug-var in
-   debug-function. This returns the value of executing result (defaults to
-   nil). This may iterate over only some of debug-function's variables or none
-   depending on debug policy; for example, possibly the compilation only
-   preserved argument information."
+         (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))
   (let ((vars (gensym))

-       (i (gensym)))
-    `(let ((,vars (debug-function-debug-vars ,debug-function)))
+        (i (gensym)))
+    `(let ((,vars (debug-fun-debug-vars ,debug-fun)))

        (declare (type (or null simple-vector) ,vars))
        (if ,vars
        (declare (type (or null simple-vector) ,vars))
        (if ,vars

-          (dotimes (,i (length ,vars) ,result)
-            (let ((,var (svref ,vars ,i)))
-              ,@body))
-          ,result))))
-
-(defun debug-function-function (debug-function)
-  #!+sb-doc
-  "Returns the Common Lisp function associated with the debug-function. This
-   returns nil if the function is unavailable or is non-existent as a user
-   callable function object."
-  (let ((cached-value (debug-function-%function debug-function)))
+           (dotimes (,i (length ,vars) ,result)
+             (let ((,var (svref ,vars ,i)))
+               ,@body))
+           ,result))))
+
+;;; Return the object of type FUNCTION associated with the DEBUG-FUN,
+;;; or NIL if the function is unavailable or is non-existent as a user
+;;; callable function object.
+(defun debug-fun-fun (debug-fun)
+  (let ((cached-value (debug-fun-%function debug-fun)))

     (if (eq cached-value :unparsed)
     (if (eq cached-value :unparsed)

-       (setf (debug-function-%function debug-function)
-             (etypecase debug-function
-               (compiled-debug-function
-                (let ((component
-                       (compiled-debug-function-component debug-function))
-                      (start-pc
-                       (sb!c::compiled-debug-function-start-pc
-                        (compiled-debug-function-compiler-debug-fun
-                         debug-function))))
-                  (do ((entry (%code-entry-points component)
-                              (%function-next entry)))
-                      ((null entry) nil)
-                    (when (= start-pc
-                             (sb!c::compiled-debug-function-start-pc
-                              (compiled-debug-function-compiler-debug-fun
-                               (function-debug-function entry))))
-                      (return entry)))))
-               (interpreted-debug-function
-                (sb!c::lambda-eval-info-function
-                 (sb!c::leaf-info
-                  (interpreted-debug-function-ir1-lambda debug-function))))
-               (bogus-debug-function nil)))
-       cached-value)))
-
-(defun debug-function-name (debug-function)
-  #!+sb-doc
-  "Returns the name of the function represented by debug-function. This may
-   be a string or a cons; do not assume it is a symbol."
-  (etypecase debug-function
-    (compiled-debug-function
-     (sb!c::compiled-debug-function-name
-      (compiled-debug-function-compiler-debug-fun debug-function)))
-    (interpreted-debug-function
-     (sb!c::lambda-name (interpreted-debug-function-ir1-lambda
-                        debug-function)))
-    (bogus-debug-function
-     (bogus-debug-function-%name debug-function))))
-
-(defun function-debug-function (fun)
-  #!+sb-doc
-  "Returns a debug-function that represents debug information for function."
-  (case (get-type fun)
-    (#.sb!vm:closure-header-type
-     (function-debug-function (%closure-function fun)))
-    (#.sb!vm:funcallable-instance-header-type
-     (cond ((sb!eval:interpreted-function-p fun)
-           (make-interpreted-debug-function
-            (or (sb!eval::interpreted-function-definition fun)
-                (sb!eval::convert-interpreted-fun fun))))
-          (t
-           (function-debug-function (funcallable-instance-function fun)))))
-    ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
-      (let* ((name (%function-name fun))
-            (component (function-code-header fun))
-            (res (find-if
-                  #'(lambda (x)
-                      (and (sb!c::compiled-debug-function-p x)
-                           (eq (sb!c::compiled-debug-function-name x) name)
-                           (eq (sb!c::compiled-debug-function-kind x) nil)))
-                  (get-debug-info-function-map
-                   (%code-debug-info component)))))
-       (if res
-           (make-compiled-debug-function res component)
-           ;; KLUDGE: comment from CMU CL:
-           ;;   This used to be the non-interpreted branch, but
-           ;;   William wrote it to return the debug-fun of fun's XEP
-           ;;   instead of fun's debug-fun. The above code does this
-           ;;   more correctly, but it doesn't get or eliminate all
-           ;;   appropriate cases. It mostly works, and probably
-           ;;   works for all named functions anyway.
-           ;; -- WHN 20000120
-           (debug-function-from-pc component
-                                   (* (- (function-word-offset fun)
-                                         (get-header-data component))
-                                      sb!vm:word-bytes)))))))
-
-(defun debug-function-kind (debug-function)
-  #!+sb-doc
-  "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL,
-   :TOP-level, :CLEANUP, or NIL."
+        (setf (debug-fun-%function debug-fun)
+              (etypecase debug-fun
+                (compiled-debug-fun
+                 (let ((component
+                        (compiled-debug-fun-component debug-fun))
+                       (start-pc
+                        (sb!c::compiled-debug-fun-start-pc
+                         (compiled-debug-fun-compiler-debug-fun debug-fun))))
+                   (do ((entry (%code-entry-points component)
+                               (%simple-fun-next entry)))
+                       ((null entry) nil)
+                     (when (= start-pc
+                              (sb!c::compiled-debug-fun-start-pc
+                               (compiled-debug-fun-compiler-debug-fun
+                                (fun-debug-fun entry))))
+                       (return entry)))))
+                (bogus-debug-fun nil)))
+        cached-value)))
+
+;;; Return the name of the function represented by DEBUG-FUN. This may
+;;; be a string or a cons; do not assume it is a symbol.
+(defun debug-fun-name (debug-fun)
+  (declare (type debug-fun debug-fun))
+  (etypecase debug-fun
+    (compiled-debug-fun
+     (sb!c::compiled-debug-fun-name
+      (compiled-debug-fun-compiler-debug-fun debug-fun)))
+    (bogus-debug-fun
+     (bogus-debug-fun-%name debug-fun))))
+
+;;; Return a DEBUG-FUN that represents debug information for FUN.
+(defun fun-debug-fun (fun)
+  (declare (type function fun))
+  (let ((simple-fun (%fun-fun fun)))
+    (let* ((name (%simple-fun-name simple-fun))
+           (component (fun-code-header simple-fun))
+           (res (find-if
+                 (lambda (x)
+                   (and (sb!c::compiled-debug-fun-p x)
+                        (eq (sb!c::compiled-debug-fun-name x) name)
+                        (eq (sb!c::compiled-debug-fun-kind x) nil)))
+                 (sb!c::compiled-debug-info-fun-map
+                  (%code-debug-info component)))))
+      (if res
+          (make-compiled-debug-fun res component)
+          ;; KLUDGE: comment from CMU CL:
+          ;;   This used to be the non-interpreted branch, but
+          ;;   William wrote it to return the debug-fun of fun's XEP
+          ;;   instead of fun's debug-fun. The above code does this
+          ;;   more correctly, but it doesn't get or eliminate all
+          ;;   appropriate cases. It mostly works, and probably
+          ;;   works for all named functions anyway.
+          ;; -- WHN 20000120
+          (debug-fun-from-pc component
+                             (* (- (fun-word-offset simple-fun)
+                                   (get-header-data component))
+                                sb!vm:n-word-bytes))))))
+
+;;; Return the kind of the function, which is one of :OPTIONAL,
+;;; :EXTERNAL, :TOPLEVEL, :CLEANUP, or NIL.
+(defun debug-fun-kind (debug-fun)

   ;; FIXME: This "is one of" information should become part of the function
   ;; declamation, not just a doc string
   ;; FIXME: This "is one of" information should become part of the function
   ;; declamation, not just a doc string

-  (etypecase debug-function
-    (compiled-debug-function
-     (sb!c::compiled-debug-function-kind
-      (compiled-debug-function-compiler-debug-fun debug-function)))
-    (interpreted-debug-function
-     (sb!c::lambda-kind (interpreted-debug-function-ir1-lambda
-                        debug-function)))
-    (bogus-debug-function
+  (etypecase debug-fun
+    (compiled-debug-fun
+     (sb!c::compiled-debug-fun-kind
+      (compiled-debug-fun-compiler-debug-fun debug-fun)))
+    (bogus-debug-fun

      nil)))
 
      nil)))
 

-(defun debug-var-info-available (debug-function)
-  #!+sb-doc
-  "Is there any variable information for DEBUG-FUNCTION?"
-  (not (not (debug-function-debug-vars debug-function))))
-
-(defun debug-function-symbol-variables (debug-function symbol)
-  #!+sb-doc
-  "Returns a list of debug-vars in debug-function 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-function; for example, possibly debug-function only
-   knows about its arguments."
-  (let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol)))
-       (package (and (symbol-package symbol)
-                     (package-name (symbol-package symbol)))))
+;;; Is there any variable information for DEBUG-FUN?
+(defun debug-var-info-available (debug-fun)
+  (not (not (debug-fun-debug-vars debug-fun))))
+
+;;; Return a list of DEBUG-VARs in DEBUG-FUN having the same name
+;;; and package as SYMBOL. If SYMBOL is uninterned, then this returns
+;;; a list of DEBUG-VARs without package names and with the same name
+;;; as symbol. The result of this function is limited to the
+;;; availability of variable information in DEBUG-FUN; for
+;;; example, possibly DEBUG-FUN only knows about its arguments.
+(defun debug-fun-symbol-vars (debug-fun symbol)
+  (let ((vars (ambiguous-debug-vars debug-fun (symbol-name symbol)))
+        (package (and (symbol-package symbol)
+                      (package-name (symbol-package symbol)))))

     (delete-if (if (stringp package)
     (delete-if (if (stringp package)

-                  (lambda (var)
-                    (let ((p (debug-var-package-name var)))
-                      (or (not (stringp p))
-                          (string/= p package))))
-                  (lambda (var)
-                    (stringp (debug-var-package-name var))))
-              vars)))
-
-(defun ambiguous-debug-vars (debug-function name-prefix-string)
-   "Returns a list of debug-vars in debug-function whose names contain
-    name-prefix-string as an intial substring. The result of this function is
-    limited to the availability of variable information in debug-function; for
-    example, possibly debug-function only knows about its arguments."
+                   (lambda (var)
+                     (let ((p (debug-var-package-name var)))
+                       (or (not (stringp p))
+                           (string/= p package))))
+                   (lambda (var)
+                     (stringp (debug-var-package-name var))))
+               vars)))
+
+;;; Return a list of DEBUG-VARs in DEBUG-FUN whose names contain
+;;; NAME-PREFIX-STRING as an initial substring. The result of this
+;;; function is limited to the availability of variable information in
+;;; debug-fun; for example, possibly debug-fun only knows
+;;; about its arguments.
+(defun ambiguous-debug-vars (debug-fun name-prefix-string)

   (declare (simple-string name-prefix-string))
   (declare (simple-string name-prefix-string))

-  (let ((variables (debug-function-debug-vars debug-function)))
+  (let ((variables (debug-fun-debug-vars debug-fun)))

     (declare (type (or null simple-vector) variables))
     (if variables
     (declare (type (or null simple-vector) variables))
     (if variables

-       (let* ((len (length variables))
-              (prefix-len (length name-prefix-string))
-              (pos (find-variable name-prefix-string variables len))
-              (res nil))
-         (when pos
-           ;; Find names from pos to variable's len that contain prefix.
-           (do ((i pos (1+ i)))
-               ((= i len))
-             (let* ((var (svref variables i))
-                    (name (debug-var-symbol-name var))
-                    (name-len (length name)))
-               (declare (simple-string name))
-               (when (/= (or (string/= name-prefix-string name
-                                       :end1 prefix-len :end2 name-len)
-                             prefix-len)
-                         prefix-len)
-                 (return))
-               (push var res)))
-           (setq res (nreverse res)))
-         res))))
-
-;;; This returns a position in variables for one containing name as an
-;;; initial substring. End is the length of variables if supplied.
-(defun find-variable (name variables &optional end)
+        (let* ((len (length variables))
+               (prefix-len (length name-prefix-string))
+               (pos (find-var name-prefix-string variables len))
+               (res nil))
+          (when pos
+            ;; Find names from pos to variable's len that contain prefix.
+            (do ((i pos (1+ i)))
+                ((= i len))
+              (let* ((var (svref variables i))
+                     (name (debug-var-symbol-name var))
+                     (name-len (length name)))
+                (declare (simple-string name))
+                (when (/= (or (string/= name-prefix-string name
+                                        :end1 prefix-len :end2 name-len)
+                              prefix-len)
+                          prefix-len)
+                  (return))
+                (push var res)))
+            (setq res (nreverse res)))
+          res))))
+
+;;; This returns a position in VARIABLES for one containing NAME as an
+;;; initial substring. END is the length of VARIABLES if supplied.
+(defun find-var (name variables &optional end)

   (declare (simple-vector variables)
   (declare (simple-vector variables)

-          (simple-string name))
+           (simple-string name))

   (let ((name-len (length name)))
     (position name variables
   (let ((name-len (length name)))
     (position name variables

-             :test #'(lambda (x y)
-                       (let* ((y (debug-var-symbol-name y))
-                              (y-len (length y)))
-                         (declare (simple-string y))
-                         (and (>= y-len name-len)
-                              (string= x y :end1 name-len :end2 name-len))))
-             :end (or end (length variables)))))
-
-(defun debug-function-lambda-list (debug-function)
-  #!+sb-doc
-  "Returns a list representing the lambda-list for debug-function. 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 it
-   is unreferenced in debug-function. This signals a lambda-list-unavailable
-   condition when there is no argument list information."
-  (etypecase debug-function
-    (compiled-debug-function
-     (compiled-debug-function-lambda-list debug-function))
-    (interpreted-debug-function
-     (interpreted-debug-function-lambda-list debug-function))
-    (bogus-debug-function
-     nil)))
+              :test (lambda (x y)
+                      (let* ((y (debug-var-symbol-name y))
+                             (y-len (length y)))
+                        (declare (simple-string y))
+                        (and (>= y-len name-len)
+                             (string= x y :end1 name-len :end2 name-len))))
+              :end (or end (length variables)))))
+
+;;; Return a list representing the lambda-list for DEBUG-FUN. The
+;;; list has the following structure:
+;;;   (required-var1 required-var2
+;;;    ...
+;;;    (:optional var3 suppliedp-var4)
+;;;    (:optional var5)
+;;;    ...
+;;;    (:rest var6) (:rest var7)
+;;;    ...
+;;;    (:keyword keyword-symbol var8 suppliedp-var9)
+;;;    (:keyword keyword-symbol var10)
+;;;    ...
+;;;   )
+;;; Each VARi is a DEBUG-VAR; however it may be the symbol :DELETED if
+;;; it is unreferenced in DEBUG-FUN. This signals a
+;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
+;;; information.
+(defun debug-fun-lambda-list (debug-fun)
+  (etypecase debug-fun
+    (compiled-debug-fun (compiled-debug-fun-lambda-list debug-fun))
+    (bogus-debug-fun nil)))

 
 

-;;; The hard part is when the lambda-list is unparsed. If it is
-;;; unparsed, and all the arguments are required, this is still pretty
-;;; easy; just whip the appropriate DEBUG-VARs into a list. Otherwise,
-;;; we have to pick out the funny arguments including any suppliedp
-;;; variables. In this situation, the ir1-lambda is an external entry
-;;; point that takes arguments users really pass in. It looks at those
-;;; and computes defaults and suppliedp variables, ultimately passing
-;;; everything defined as a a parameter to the real function as final
-;;; arguments. If this has to compute the lambda list, it caches it in
-;;; debug-function.
-(defun interpreted-debug-function-lambda-list (debug-function)
-  (let ((lambda-list (debug-function-%lambda-list debug-function))
-       (debug-vars (debug-function-debug-vars debug-function))
-       (ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))
-       (res nil))
-    (if (eq lambda-list :unparsed)
-       (flet ((frob (v debug-vars)
-                (if (sb!c::lambda-var-refs v)
-                    (find v debug-vars
-                          :key #'interpreted-debug-var-ir1-var)
-                    :deleted)))
-         (let ((xep-args (sb!c::lambda-optional-dispatch ir1-lambda)))
-           (if (and xep-args
-                    (eq (sb!c::optional-dispatch-main-entry xep-args)
-                        ir1-lambda))
-               ;; There are rest, optional, keyword, and suppliedp vars.
-               (let ((final-args (sb!c::lambda-vars ir1-lambda)))
-                 (dolist (xep-arg (sb!c::optional-dispatch-arglist xep-args))
-                   (let ((info (sb!c::lambda-var-arg-info xep-arg))
-                         (final-arg (pop final-args)))
-                     (cond (info
-                            (case (sb!c::arg-info-kind info)
-                              (:required
-                               (push (frob final-arg debug-vars) res))
-                              (:keyword
-                               (push (list :keyword
-                                           (sb!c::arg-info-keyword info)
-                                           (frob final-arg debug-vars))
-                                     res))
-                              (:rest
-                               (push (list :rest (frob final-arg debug-vars))
-                                     res))
-                              (:optional
-                               (push (list :optional
-                                           (frob final-arg debug-vars))
-                                     res)))
-                            (when (sb!c::arg-info-supplied-p info)
-                              (nconc
-                               (car res)
-                               (list (frob (pop final-args) debug-vars)))))
-                           (t
-                            (push (frob final-arg debug-vars) res)))))
-                 (setf (debug-function-%lambda-list debug-function)
-                       (nreverse res)))
-               ;; All required args, so return them in a list.
-               (dolist (v (sb!c::lambda-vars ir1-lambda)
-                          (setf (debug-function-%lambda-list debug-function)
-                                (nreverse res)))
-                 (push (frob v debug-vars) res)))))
-       ;; Everything's unparsed and cached, so return it.
-       lambda-list)))
-
-;;; If this has to compute the lambda list, it caches it in debug-function.
-(defun compiled-debug-function-lambda-list (debug-function)
-  (let ((lambda-list (debug-function-%lambda-list debug-function)))
+;;; 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)
     (cond ((eq lambda-list :unparsed)

-          (multiple-value-bind (args argsp)
-              (parse-compiled-debug-function-lambda-list debug-function)
-            (setf (debug-function-%lambda-list debug-function) args)
-            (if argsp
-                args
-                (debug-signal 'lambda-list-unavailable
-                              :debug-function debug-function))))
-         (lambda-list)
-         ((bogus-debug-function-p debug-function)
-          nil)
-         ((sb!c::compiled-debug-function-arguments
-           (compiled-debug-function-compiler-debug-fun
-            debug-function))
-          ;; 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-function debug-function)))))
-
-;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a
-;;; compiled-debug-function 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, nil and t
-;;; means there were no arguments, but nil and nil means there was no
-;;; argument information.
-(defun parse-compiled-debug-function-lambda-list (debug-function)
-  (let ((args (sb!c::compiled-debug-function-arguments
-              (compiled-debug-function-compiler-debug-fun
-               debug-function))))
+           (multiple-value-bind (args argsp)
+               (parse-compiled-debug-fun-lambda-list debug-fun)
+             (setf (debug-fun-%lambda-list debug-fun) args)
+             (if argsp
+                 args
+                 (debug-signal 'lambda-list-unavailable
+                               :debug-fun debug-fun))))
+          (lambda-list)
+          ((bogus-debug-fun-p debug-fun)
+           nil)
+          ((sb!c::compiled-debug-fun-arguments
+            (compiled-debug-fun-compiler-debug-fun debug-fun))
+           ;; If the packed information is there (whether empty or not) as
+           ;; opposed to being nil, then returned our cached value (nil).
+           nil)
+          (t
+           ;; Our cached value is nil, and the packed lambda-list information
+           ;; is nil, so we don't have anything available.
+           (debug-signal 'lambda-list-unavailable
+                         :debug-fun debug-fun)))))
+
+;;; COMPILED-DEBUG-FUN-LAMBDA-LIST calls this when a
+;;; COMPILED-DEBUG-FUN has no lambda list information cached. It
+;;; returns the lambda list as the first value and whether there was
+;;; any argument information as the second value. Therefore,
+;;; (VALUES NIL T) means there were no arguments, but (VALUES NIL NIL)
+;;; means there was no argument information.
+(defun parse-compiled-debug-fun-lambda-list (debug-fun)
+  (let ((args (sb!c::compiled-debug-fun-arguments
+               (compiled-debug-fun-compiler-debug-fun debug-fun))))

     (cond
      ((not args)
       (values nil nil))
      ((eq args :minimal)
     (cond
      ((not args)
       (values nil nil))
      ((eq args :minimal)

-      (values (coerce (debug-function-debug-vars debug-function) 'list)
-             t))
+      (values (coerce (debug-fun-debug-vars debug-fun) 'list)
+              t))

      (t
      (t

-      (let ((vars (debug-function-debug-vars debug-function))
-           (i 0)
-           (len (length args))
-           (res nil)
-           (optionalp nil))
-       (declare (type (or null simple-vector) vars))
-       (loop
-         (when (>= i len) (return))
-         (let ((ele (aref args i)))
-           (cond
-            ((symbolp ele)
-             (case ele
-               (sb!c::deleted
-                ;; Deleted required arg at beginning of args array.
-                (push :deleted res))
-               (sb!c::optional-args
-                (setf optionalp t))
-               (sb!c::supplied-p
-                ;; SUPPLIED-P var immediately following keyword or
-                ;; optional. Stick the extra var in the result
-                ;; element representing the keyword or optional,
-                ;; which is the previous one.
-                (nconc (car res)
-                       (list (compiled-debug-function-lambda-list-var
-                              args (incf i) vars))))
-               (sb!c::rest-arg
-                (push (list :rest
-                            (compiled-debug-function-lambda-list-var
-                             args (incf i) vars))
-                      res))
-               (sb!c::more-arg
-                ;; Just ignore the fact that the next two args are
-                ;; the more arg context and count, and act like they
-                ;; are regular arguments.
-                nil)
-               (t
-                ;; keyword arg
-                (push (list :keyword
-                            ele
-                            (compiled-debug-function-lambda-list-var
-                             args (incf i) vars))
-                      res))))
-            (optionalp
-             ;; We saw an optional marker, so the following
-             ;; non-symbols are indexes indicating optional
-             ;; variables.
-             (push (list :optional (svref vars ele)) res))
-            (t
-             ;; Required arg at beginning of args array.
-             (push (svref vars ele) res))))
-         (incf i))
-       (values (nreverse res) t))))))
-
-;;; This is used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST.
-(defun compiled-debug-function-lambda-list-var (args i vars)
+      (let ((vars (debug-fun-debug-vars debug-fun))
+            (i 0)
+            (len (length args))
+            (res nil)
+            (optionalp nil))
+        (declare (type (or null simple-vector) vars))
+        (loop
+          (when (>= i len) (return))
+          (let ((ele (aref args i)))
+            (cond
+             ((symbolp ele)
+              (case ele
+                (sb!c::deleted
+                 ;; Deleted required arg at beginning of args array.
+                 (push :deleted res))
+                (sb!c::optional-args
+                 (setf optionalp t))
+                (sb!c::supplied-p
+                 ;; SUPPLIED-P var immediately following keyword or
+                 ;; optional. Stick the extra var in the result
+                 ;; element representing the keyword or optional,
+                 ;; which is the previous one.
+                 ;;
+                 ;; FIXME: NCONC used for side-effect: the effect is defined,
+                 ;; but this is bad style no matter what.
+                 (nconc (car res)
+                        (list (compiled-debug-fun-lambda-list-var
+                               args (incf i) vars))))
+                (sb!c::rest-arg
+                 (push (list :rest
+                             (compiled-debug-fun-lambda-list-var
+                              args (incf i) vars))
+                       res))
+                (sb!c::more-arg
+                 ;; The next two args are the &MORE arg context and count.
+                 (push (list :more
+                             (compiled-debug-fun-lambda-list-var
+                              args (incf i) vars)
+                             (compiled-debug-fun-lambda-list-var
+                              args (incf i) vars))
+                       res))
+                (t
+                 ;; &KEY arg
+                 (push (list :keyword
+                             ele
+                             (compiled-debug-fun-lambda-list-var
+                              args (incf i) vars))
+                       res))))
+             (optionalp
+              ;; We saw an optional marker, so the following
+              ;; non-symbols are indexes indicating optional
+              ;; variables.
+              (push (list :optional (svref vars ele)) res))
+             (t
+              ;; Required arg at beginning of args array.
+              (push (svref vars ele) res))))
+          (incf i))
+        (values (nreverse res) t))))))
+
+;;; This is used in COMPILED-DEBUG-FUN-LAMBDA-LIST.
+(defun compiled-debug-fun-lambda-list-var (args i vars)

   (declare (type (simple-array * (*)) args)
   (declare (type (simple-array * (*)) args)

-          (simple-vector vars))
+           (simple-vector vars))

   (let ((ele (aref args i)))
     (cond ((not (symbolp ele)) (svref vars ele))
   (let ((ele (aref args i)))
     (cond ((not (symbolp ele)) (svref vars ele))

-         ((eq ele 'sb!c::deleted) :deleted)
-         (t (error "malformed arguments description")))))
+          ((eq ele 'sb!c::deleted) :deleted)
+          (t (error "malformed arguments description")))))

 
 

-(defun compiled-debug-function-debug-info (debug-fun)
-  (%code-debug-info (compiled-debug-function-component debug-fun)))
+(defun compiled-debug-fun-debug-info (debug-fun)
+  (%code-debug-info (compiled-debug-fun-component debug-fun)))

 \f
 ;;;; unpacking variable and basic block data
 
 \f
 ;;;; unpacking variable and basic block data
 

@@ -1713,7 +1486,7 @@
   (make-array 20 :adjustable t :fill-pointer t))
 (defvar *other-parsing-buffer*
   (make-array 20 :adjustable t :fill-pointer t))
   (make-array 20 :adjustable t :fill-pointer t))
 (defvar *other-parsing-buffer*
   (make-array 20 :adjustable t :fill-pointer t))

-;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARS and UNCOMPACT-FUNCTION-MAP
+;;; PARSE-DEBUG-BLOCKS and PARSE-DEBUG-VARS

 ;;; use this to unpack binary encoded information. It returns the
 ;;; values returned by the last form in body.
 ;;;
 ;;; use this to unpack binary encoded information. It returns the
 ;;; values returned by the last form in body.
 ;;;

@@ -1731,401 +1504,229 @@
 ;;; simple-vector.
 (eval-when (:compile-toplevel :execute)
 (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
 ;;; simple-vector.
 (eval-when (:compile-toplevel :execute)
 (sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)

-                                    &body body)
+                                     &body body)

   (let ((len (gensym))
   (let ((len (gensym))

-       (res (gensym)))
+        (res (gensym)))

     `(unwind-protect
     `(unwind-protect

-        (let ((,buffer-var *parsing-buffer*)
-              ,@(if other-var `((,other-var *other-parsing-buffer*))))
-          (setf (fill-pointer ,buffer-var) 0)
-          ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
-          (macrolet ((result (buf)
-                       `(let* ((,',len (length ,buf))
-                               (,',res (make-array ,',len)))
-                          (replace ,',res ,buf :end1 ,',len :end2 ,',len)
-                          (fill ,buf nil :end ,',len)
-                          (setf (fill-pointer ,buf) 0)
-                          ,',res)))
-            ,@body))
+         (let ((,buffer-var *parsing-buffer*)
+               ,@(if other-var `((,other-var *other-parsing-buffer*))))
+           (setf (fill-pointer ,buffer-var) 0)
+           ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
+           (macrolet ((result (buf)
+                        `(let* ((,',len (length ,buf))
+                                (,',res (make-array ,',len)))
+                           (replace ,',res ,buf :end1 ,',len :end2 ,',len)
+                           (fill ,buf nil :end ,',len)
+                           (setf (fill-pointer ,buf) 0)
+                           ,',res)))
+             ,@body))

      (fill *parsing-buffer* nil)
      ,@(if other-var `((fill *other-parsing-buffer* nil))))))
 ) ; EVAL-WHEN
 
 ;;; The argument is a debug internals structure. This returns the
      (fill *parsing-buffer* nil)
      ,@(if other-var `((fill *other-parsing-buffer* nil))))))
 ) ; EVAL-WHEN
 
 ;;; The argument is a debug internals structure. This returns the

-;;; debug-blocks for debug-function, regardless of whether we have
-;;; unpacked them yet. It signals a no-debug-blocks condition if it
-;;; can't return the blocks.
-(defun debug-function-debug-blocks (debug-function)
-  (let ((blocks (debug-function-blocks debug-function)))
+;;; DEBUG-BLOCKs for DEBUG-FUN, regardless of whether we have unpacked
+;;; them yet. It signals a NO-DEBUG-BLOCKS condition if it can't
+;;; return the blocks.
+(defun debug-fun-debug-blocks (debug-fun)
+  (let ((blocks (debug-fun-blocks debug-fun)))

     (cond ((eq blocks :unparsed)
     (cond ((eq blocks :unparsed)

-          (setf (debug-function-blocks debug-function)
-                (parse-debug-blocks debug-function))
-          (unless (debug-function-blocks debug-function)
-            (debug-signal 'no-debug-blocks
-                          :debug-function debug-function))
-          (debug-function-blocks debug-function))
-         (blocks)
-         (t
-          (debug-signal 'no-debug-blocks
-                        :debug-function debug-function)))))
-
-;;; This returns a simple-vector of debug-blocks or nil. NIL indicates
-;;; there was no basic block information.
-(defun parse-debug-blocks (debug-function)
-  (etypecase debug-function
-    (compiled-debug-function
-     (parse-compiled-debug-blocks debug-function))
-    (bogus-debug-function
-     (debug-signal 'no-debug-blocks :debug-function debug-function))
-    (interpreted-debug-function
-     (parse-interpreted-debug-blocks debug-function))))
+           (setf (debug-fun-blocks debug-fun)
+                 (parse-debug-blocks debug-fun))
+           (unless (debug-fun-blocks debug-fun)
+             (debug-signal 'no-debug-blocks
+                           :debug-fun debug-fun))
+           (debug-fun-blocks debug-fun))
+          (blocks)
+          (t
+           (debug-signal 'no-debug-blocks
+                         :debug-fun debug-fun)))))
+
+;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there
+;;; was no basic block information.
+(defun parse-debug-blocks (debug-fun)
+  (etypecase debug-fun
+    (compiled-debug-fun
+     (parse-compiled-debug-blocks debug-fun))
+    (bogus-debug-fun
+     (debug-signal 'no-debug-blocks :debug-fun debug-fun))))

 
 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.
 
 ;;; This does some of the work of PARSE-DEBUG-BLOCKS.

-(defun parse-compiled-debug-blocks (debug-function)
-  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun
-                    debug-function))
-        (var-count (length (debug-function-debug-vars debug-function)))
-        (blocks (sb!c::compiled-debug-function-blocks debug-fun))
-        ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
-        ;; element size of the packed binary representation of the
-        ;; blocks data.
-        (live-set-len (ceiling var-count 8))
-        (tlf-number (sb!c::compiled-debug-function-tlf-number debug-fun)))
-    (unless blocks (return-from parse-compiled-debug-blocks nil))
+(defun parse-compiled-debug-blocks (debug-fun)
+  (let* ((var-count (length (debug-fun-debug-vars debug-fun)))
+         (compiler-debug-fun (compiled-debug-fun-compiler-debug-fun
+                              debug-fun))
+         (blocks (sb!c::compiled-debug-fun-blocks compiler-debug-fun))
+         ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
+         ;; element size of the packed binary representation of the
+         ;; blocks data.
+         (live-set-len (ceiling var-count 8))
+         (tlf-number (sb!c::compiled-debug-fun-tlf-number compiler-debug-fun)))
+    (unless blocks
+      (return-from parse-compiled-debug-blocks nil))

     (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
       (with-parsing-buffer (blocks-buffer locations-buffer)
     (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
       (with-parsing-buffer (blocks-buffer locations-buffer)

-       (let ((i 0)
-             (len (length blocks))
-             (last-pc 0))
-         (loop
-           (when (>= i len) (return))
-           (let ((succ-and-flags (aref+ blocks i))
-                 (successors nil))
-             (declare (type (unsigned-byte 8) succ-and-flags)
-                      (list successors))
-             (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
-                              succ-and-flags))
-               (push (sb!c::read-var-integer blocks i) successors))
-             (let* ((locations
-                     (dotimes (k (sb!c::read-var-integer blocks i)
-                                 (result locations-buffer))
-                       (let ((kind (svref sb!c::compiled-code-location-kinds
-                                          (aref+ blocks i)))
-                             (pc (+ last-pc
-                                    (sb!c::read-var-integer blocks i)))
-                             (tlf-offset (or tlf-number
-                                             (sb!c::read-var-integer blocks
-                                                                     i)))
-                             (form-number (sb!c::read-var-integer blocks i))
-                             (live-set (sb!c::read-packed-bit-vector
-                                        live-set-len blocks i)))
-                         (vector-push-extend (make-known-code-location
-                                              pc debug-function tlf-offset
-                                              form-number live-set kind)
-                                             locations-buffer)
-                         (setf last-pc pc))))
-                    (block (make-compiled-debug-block
-                            locations successors
-                            (not (zerop (logand
-                                         sb!c::compiled-debug-block-elsewhere-p
-                                         succ-and-flags))))))
-               (vector-push-extend block blocks-buffer)
-               (dotimes (k (length locations))
-                 (setf (code-location-%debug-block (svref locations k))
-                       block))))))
-       (let ((res (result blocks-buffer)))
-         (declare (simple-vector res))
-         (dotimes (i (length res))
-           (let* ((block (svref res i))
-                  (succs nil))
-             (dolist (ele (debug-block-successors block))
-               (push (svref res ele) succs))
-             (setf (debug-block-successors block) succs)))
-         res)))))
-
-;;; This does some of the work of PARSE-DEBUG-BLOCKS.
-(defun parse-interpreted-debug-blocks (debug-function)
-  (let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)))
-    (with-parsing-buffer (buffer)
-      (sb!c::do-blocks (block (sb!c::block-component
-                              (sb!c::node-block (sb!c::lambda-bind
-                                                 ir1-lambda))))
-       (when (eq ir1-lambda (sb!c::block-home-lambda block))
-         (vector-push-extend (make-interpreted-debug-block block) buffer)))
-      (result buffer))))
-
-;;; The argument is a debug internals structure. This returns nil if
+        (let ((i 0)
+              (len (length blocks))
+              (last-pc 0))
+          (loop
+            (when (>= i len) (return))
+            (let ((succ-and-flags (aref+ blocks i))
+                  (successors nil))
+              (declare (type (unsigned-byte 8) succ-and-flags)
+                       (list successors))
+              (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
+                               succ-and-flags))
+                (push (sb!c:read-var-integer blocks i) successors))
+              (let* ((locations
+                      (dotimes (k (sb!c:read-var-integer blocks i)
+                                  (result locations-buffer))
+                        (let ((kind (svref sb!c::*compiled-code-location-kinds*
+                                           (aref+ blocks i)))
+                              (pc (+ last-pc
+                                     (sb!c:read-var-integer blocks i)))
+                              (tlf-offset (or tlf-number
+                                              (sb!c:read-var-integer blocks i)))
+                              (form-number (sb!c:read-var-integer blocks i))
+                              (live-set (sb!c:read-packed-bit-vector
+                                         live-set-len blocks i))
+                              (step-info (sb!c:read-var-string blocks i)))
+                          (vector-push-extend (make-known-code-location
+                                               pc debug-fun tlf-offset
+                                               form-number live-set kind
+                                               step-info)
+                                              locations-buffer)
+                          (setf last-pc pc))))
+                     (block (make-compiled-debug-block
+                             locations successors
+                             (not (zerop (logand
+                                          sb!c::compiled-debug-block-elsewhere-p
+                                          succ-and-flags))))))
+                (vector-push-extend block blocks-buffer)
+                (dotimes (k (length locations))
+                  (setf (code-location-%debug-block (svref locations k))
+                        block))))))
+        (let ((res (result blocks-buffer)))
+          (declare (simple-vector res))
+          (dotimes (i (length res))
+            (let* ((block (svref res i))
+                   (succs nil))
+              (dolist (ele (debug-block-successors block))
+                (push (svref res ele) succs))
+              (setf (debug-block-successors block) succs)))
+          res)))))
+
+;;; The argument is a debug internals structure. This returns NIL if

 ;;; there is no variable information. It returns an empty
 ;;; simple-vector if there were no locals in the function. Otherwise
 ;;; 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-function-debug-vars (debug-function)
-  (let ((vars (debug-function-%debug-vars debug-function)))
+;;; 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)
     (if (eq vars :unparsed)

-       (setf (debug-function-%debug-vars debug-function)
-             (etypecase debug-function
-               (compiled-debug-function
-                (parse-compiled-debug-vars debug-function))
-               (bogus-debug-function nil)
-               (interpreted-debug-function
-                (parse-interpreted-debug-vars debug-function))))
-       vars)))
-
-;;; This grabs all the variables from DEBUG-FUN's ir1-lambda, from the
-;;; IR1 lambda vars, and all of its LET's. Each LET is an IR1 lambda.
-;;; For each variable, we make an INTERPRETED-DEBUG-VAR. We then SORT
-;;; all the variables by name. Then we go through, and for any
-;;; duplicated names we distinguish the INTERPRETED-DEBUG-VARs by
-;;; setting their id slots to a distinct number.
-(defun parse-interpreted-debug-vars (debug-fun)
-  (let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun))
-        (vars (flet ((frob (ir1-lambda buf)
-                       (dolist (v (sb!c::lambda-vars ir1-lambda))
-                         (vector-push-extend
-                          (let* ((id (sb!c::leaf-name v)))
-                            (make-interpreted-debug-var id v))
-                          buf))))
-                (with-parsing-buffer (buf)
-                  (frob ir1-lambda buf)
-                  (dolist (let-lambda (sb!c::lambda-lets ir1-lambda))
-                    (frob let-lambda buf))
-                  (result buf)))))
-    (declare (simple-vector vars))
-    (sort vars #'string< :key #'debug-var-symbol-name)
-    (let ((len (length vars)))
-      (when (> len 1)
-       (let ((i 0)
-             (j 1))
-         (block PUNT
-           (loop
-             (let* ((var-i (svref vars i))
-                    (var-j (svref vars j))
-                    (name (debug-var-symbol-name var-i)))
-               (when (string= name (debug-var-symbol-name var-j))
-                 (let ((count 1))
-                   (loop
-                     (setf (debug-var-id var-j) count)
-                     (when (= (incf j) len) (return-from PUNT))
-                     (setf var-j (svref vars j))
-                     (when (string/= name (debug-var-symbol-name var-j))
-                       (return))
-                     (incf count))))
-               (setf i j)
-               (incf j)
-               (when (= j len) (return))))))))
-    vars))
-
-;;; Vars is the parsed variables for a minimal debug function. We need to
-;;; assign names of the form ARG-NNN. We must pad with leading zeros, since
-;;; the arguments must be in alphabetical order.
+        (setf (debug-fun-%debug-vars debug-fun)
+              (etypecase debug-fun
+                (compiled-debug-fun
+                 (parse-compiled-debug-vars debug-fun))
+                (bogus-debug-fun nil)))
+        vars)))
+
+;;; VARS is the parsed variables for a minimal debug function. We need
+;;; to assign names of the form ARG-NNN. We must pad with leading
+;;; zeros, since the arguments must be in alphabetical order.

 (defun assign-minimal-var-names (vars)
   (declare (simple-vector vars))
   (let* ((len (length vars))
 (defun assign-minimal-var-names (vars)
   (declare (simple-vector vars))
   (let* ((len (length vars))

-        (width (length (format nil "~D" (1- len)))))
+         (width (length (format nil "~W" (1- len)))))

     (dotimes (i len)
     (dotimes (i len)

-      (setf (compiled-debug-var-symbol (svref vars i))
-           (intern (format nil "ARG-~V,'0D" width i)
-                   ;; KLUDGE: It's somewhat nasty to have a bare
-                   ;; package name string here. It would probably be
-                   ;; better to have #.(FIND-PACKAGE "SB!DEBUG")
-                   ;; instead, since then at least it would transform
-                   ;; correctly under package renaming and stuff.
-                   ;; However, genesis can't handle dumped packages..
-                   ;; -- WHN 20000129
-                   ;;
-                   ;; FIXME: Maybe this could be fixed by moving the
-                   ;; whole debug-int.lisp file to warm init? (after
-                   ;; which dumping a #.(FIND-PACKAGE ..) expression
-                   ;; would work fine) If this is possible, it would
-                   ;; probably be a good thing, since minimizing the
-                   ;; amount of stuff in cold init is basically good.
-                   "SB-DEBUG")))))
+      (without-package-locks
+        (setf (compiled-debug-var-symbol (svref vars i))
+              (intern (format nil "ARG-~V,'0D" width i)
+                      ;; The cross-compiler won't dump literal package
+                      ;; references because the target package objects
+                      ;; aren't created until partway through
+                      ;; cold-init. In lieu of adding smarts to the
+                      ;; build framework to handle this, we use an
+                      ;; explicit load-time-value form.
+                      (load-time-value (find-package "SB!DEBUG"))))))))

 
 ;;; Parse the packed representation of DEBUG-VARs from
 
 ;;; Parse the packed representation of DEBUG-VARs from

-;;; DEBUG-FUNCTION's SB!C::COMPILED-DEBUG-FUNCTION, returning a vector
+;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector

 ;;; of DEBUG-VARs, or NIL if there was no information to parse.
 ;;; of DEBUG-VARs, or NIL if there was no information to parse.

-(defun parse-compiled-debug-vars (debug-function)
-  (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun debug-function))
-        (packed-vars (sb!c::compiled-debug-function-variables cdebug-fun))
-        (args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun)
-                          :minimal)))
+(defun parse-compiled-debug-vars (debug-fun)
+  (let* ((cdebug-fun (compiled-debug-fun-compiler-debug-fun
+                      debug-fun))
+         (packed-vars (sb!c::compiled-debug-fun-vars cdebug-fun))
+         (args-minimal (eq (sb!c::compiled-debug-fun-arguments cdebug-fun)
+                           :minimal)))

     (when packed-vars
       (do ((i 0)
     (when packed-vars
       (do ((i 0)

-          (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
-         ((>= i (length packed-vars))
-          (let ((result (coerce buffer 'simple-vector)))
-            (when args-minimal
-              (assign-minimal-var-names result))
-            result))
-       (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
-         (let* ((flags (geti))
-                (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
-                (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
-                (live (logtest sb!c::compiled-debug-var-environment-live flags))
-                (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
-                (symbol (if minimal nil (geti)))
-                (id (if (logtest sb!c::compiled-debug-var-id-p flags)
-                        (geti)
-                        0))
-                (sc-offset (if deleted 0 (geti)))
-                (save-sc-offset (if save (geti) nil)))
-           (assert (not (and args-minimal (not minimal))))
-           (vector-push-extend (make-compiled-debug-var symbol
-                                                        id
-                                                        live
-                                                        sc-offset
-                                                        save-sc-offset)
-                               buffer)))))))
-\f
-;;;; unpacking minimal debug functions
-
-(eval-when (:compile-toplevel :execute)
-
-;;; sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP
-(sb!xc:defmacro make-uncompacted-debug-fun ()
-  '(sb!c::make-compiled-debug-function
-    :name
-    (let ((base (ecase (ldb sb!c::minimal-debug-function-name-style-byte
-                           options)
-                 (#.sb!c::minimal-debug-function-name-symbol
-                  (intern (sb!c::read-var-string map i)
-                          (sb!c::compiled-debug-info-package info)))
-                 (#.sb!c::minimal-debug-function-name-packaged
-                  (let ((pkg (sb!c::read-var-string map i)))
-                    (intern (sb!c::read-var-string map i) pkg)))
-                 (#.sb!c::minimal-debug-function-name-uninterned
-                  (make-symbol (sb!c::read-var-string map i)))
-                 (#.sb!c::minimal-debug-function-name-component
-                  (sb!c::compiled-debug-info-name info)))))
-      (if (logtest flags sb!c::minimal-debug-function-setf-bit)
-         `(setf ,base)
-         base))
-    :kind (svref sb!c::minimal-debug-function-kinds
-                (ldb sb!c::minimal-debug-function-kind-byte options))
-    :variables
-    (when vars-p
-      (let ((len (sb!c::read-var-integer map i)))
-       (prog1 (subseq map i (+ i len))
-         (incf i len))))
-    :arguments (when vars-p :minimal)
-    :returns
-    (ecase (ldb sb!c::minimal-debug-function-returns-byte options)
-      (#.sb!c::minimal-debug-function-returns-standard
-       :standard)
-      (#.sb!c::minimal-debug-function-returns-fixed
-       :fixed)
-      (#.sb!c::minimal-debug-function-returns-specified
-       (with-parsing-buffer (buf)
-        (dotimes (idx (sb!c::read-var-integer map i))
-          (vector-push-extend (sb!c::read-var-integer map i) buf))
-        (result buf))))
-    :return-pc (sb!c::read-var-integer map i)
-    :old-fp (sb!c::read-var-integer map i)
-    :nfp (when (logtest flags sb!c::minimal-debug-function-nfp-bit)
-          (sb!c::read-var-integer map i))
-    :start-pc
-    (progn
-      (setq code-start-pc (+ code-start-pc (sb!c::read-var-integer map i)))
-      (+ code-start-pc (sb!c::read-var-integer map i)))
-    :elsewhere-pc
-    (setq elsewhere-pc (+ elsewhere-pc (sb!c::read-var-integer map i)))))
-
-) ; EVAL-WHEN
-
-;;; Return a normal function map derived from a minimal debug info
-;;; function map. This involves looping parsing
-;;; minimal-debug-functions and then building a vector out of them.
-;;;
-;;; FIXME: This and its helper macro just above become dead code now
-;;; that we no longer use compacted function maps.
-(defun uncompact-function-map (info)
-  (declare (type sb!c::compiled-debug-info info))
-
-  ;; (This is stubified until we solve the problem of representing
-  ;; debug information in a way which plays nicely with package renaming.)
-  (error "FIXME: dead code UNCOMPACT-FUNCTION-MAP (was stub)")
-
-  (let* ((map (sb!c::compiled-debug-info-function-map info))
-        (i 0)
-        (len (length map))
-        (code-start-pc 0)
-        (elsewhere-pc 0))
-    (declare (type (simple-array (unsigned-byte 8) (*)) map))
-    (sb!int: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::minimal-debug-function-variables-bit))
-              (dfun (make-uncompacted-debug-fun)))
-         (res code-start-pc)
-         (res dfun)))
-
-      (coerce (cdr (res)) 'simple-vector))))
-
-;;; This variable maps minimal debug-info function maps to an unpacked
-;;; version thereof.
-(defvar *uncompacted-function-maps* (make-hash-table :test 'eq))
-
-;;; Return a function-map for a given compiled-debug-info object. If
-;;; the info is minimal, and has not been parsed, then parse it.
-;;;
-;;; FIXME: Now that we no longer use the minimal-debug-function
-;;; representation, calls to this function can be replaced by calls to
-;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function,
-;;; and this function and everything it calls become dead code which
-;;; can be deleted.
-(defun get-debug-info-function-map (info)
-  (declare (type sb!c::compiled-debug-info info))
-  (let ((map (sb!c::compiled-debug-info-function-map info)))
-    (if (simple-vector-p map)
-       map
-       (or (gethash map *uncompacted-function-maps*)
-           (setf (gethash map *uncompacted-function-maps*)
-                 (uncompact-function-map info))))))
+           (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+          ((>= i (length packed-vars))
+           (let ((result (coerce buffer 'simple-vector)))
+             (when args-minimal
+               (assign-minimal-var-names result))
+             result))
+        (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
+          (let* ((flags (geti))
+                 (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
+                 (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
+                 (more-context-p (logtest sb!c::compiled-debug-var-more-context-p flags))
+                 (more-count-p (logtest sb!c::compiled-debug-var-more-count-p flags))
+                 (live (logtest sb!c::compiled-debug-var-environment-live
+                                flags))
+                 (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
+                 (symbol (if minimal nil (geti)))
+                 (id (if (logtest sb!c::compiled-debug-var-id-p flags)
+                         (geti)
+                         0))
+                 (sc-offset (if deleted 0 (geti)))
+                 (save-sc-offset (if save (geti) nil)))
+            (aver (not (and args-minimal (not minimal))))
+            (vector-push-extend (make-compiled-debug-var symbol
+                                                         id
+                                                         live
+                                                         sc-offset
+                                                         save-sc-offset
+                                                         (cond (more-context-p :more-context)
+                                                               (more-count-p :more-count)))
+                                buffer)))))))

 \f
 ;;;; CODE-LOCATIONs
 
 \f
 ;;;; CODE-LOCATIONs
 

-;;; If we're sure of whether code-location is known, return t or nil.
-;;; If we're :unsure, then try to fill in the code-location's slots.
+;;; 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
 ;;; 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.
+;;; :UNSURE part to get the HANDLER-CASE into another function.

 (defun code-location-unknown-p (basic-code-location)
 (defun code-location-unknown-p (basic-code-location)

-  #!+sb-doc
-  "Returns whether basic-code-location is unknown. It returns nil when the
-   code-location is known."

   (ecase (code-location-%unknown-p basic-code-location)
     ((t) t)
     ((nil) nil)
     (:unsure
      (setf (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))))))
+           (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)
 (defun code-location-debug-block (basic-code-location)

-  #!+sb-doc
-  "Returns 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."

   (let ((block (code-location-%debug-block basic-code-location)))
     (if (eq block :unparsed)
   (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))
-         (interpreted-code-location
-          (setf (code-location-%debug-block basic-code-location)
-                (make-interpreted-debug-block
-                 (sb!c::node-block
-                  (interpreted-code-location-ir1-node basic-code-location))))))
-       block)))
-
-;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It
-;;; determines the correct one using the code-location's pc. This uses
-;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information
-;;; or signal a 'no-debug-blocks condition. The blocks are sorted by
+        (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
 ;;; 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

@@ -2136,137 +1737,112 @@
 ;;; 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))
 ;;; 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-function (code-location-debug-function
-                         basic-code-location))
-        (blocks (debug-function-debug-blocks debug-function))
-        (len (length blocks)))
+         (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)
     (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-function-elsewhere-pc
-                              (compiled-debug-function-compiler-debug-fun
-                               debug-function)))
-                          (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 sb!c::index i end))
-               (when (< pc
-                        (compiled-code-location-pc
-                         (svref (compiled-debug-block-code-locations
-                                 (svref blocks i))
-                                0)))
-                 (return (svref blocks (1- i)))))))))
-
+          (if (= len 1)
+              (svref blocks 0)
+              (do ((i 1 (1+ i))
+                   (end (1- len)))
+                  ((= i end)
+                   (let ((last (svref blocks end)))
+                     (cond
+                      ((debug-block-elsewhere-p last)
+                       (if (< pc
+                              (sb!c::compiled-debug-fun-elsewhere-pc
+                               (compiled-debug-fun-compiler-debug-fun
+                                debug-fun)))
+                           (svref blocks (1- end))
+                           last))
+                      ((< pc
+                          (compiled-code-location-pc
+                           (svref (compiled-debug-block-code-locations last)
+                                  0)))
+                       (svref blocks (1- end)))
+                      (t last))))
+                (declare (type index i end))
+                (when (< pc
+                         (compiled-code-location-pc
+                          (svref (compiled-debug-block-code-locations
+                                  (svref blocks i))
+                                 0)))
+                  (return (svref blocks (1- i)))))))))
+
+;;; Return the CODE-LOCATION's DEBUG-SOURCE.

 (defun code-location-debug-source (code-location)
 (defun code-location-debug-source (code-location)

-  #!+sb-doc
-  "Returns the code-location's debug-source."
-  (etypecase code-location
-    (compiled-code-location
-     (let* ((info (compiled-debug-function-debug-info
-                  (code-location-debug-function code-location)))
-           (sources (sb!c::compiled-debug-info-source info))
-           (len (length sources)))
-       (declare (list sources))
-       (when (zerop len)
-        (debug-signal 'no-debug-blocks :debug-function
-                      (code-location-debug-function code-location)))
-       (if (= len 1)
-          (car sources)
-          (do ((prev sources src)
-               (src (cdr sources) (cdr src))
-               (offset (code-location-top-level-form-offset code-location)))
-              ((null src) (car prev))
-            (when (< offset (sb!c::debug-source-source-root (car src)))
-              (return (car prev)))))))
-    (interpreted-code-location
-     (first
-      (let ((sb!c::*lexenv* (make-null-lexenv)))
-       (sb!c::debug-source-for-info
-        (sb!c::component-source-info
-         (sb!c::block-component
-          (sb!c::node-block
-           (interpreted-code-location-ir1-node code-location))))))))))
-
-(defun code-location-top-level-form-offset (code-location)
-  #!+sb-doc
-  "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."
+  (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)
   (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.
-               (error "internal error: unknown code location"))
-             (code-location-%tlf-offset code-location))
-            (interpreted-code-location
-             (setf (code-location-%tlf-offset code-location)
-                   (sb!c::source-path-tlf-number
-                    (sb!c::node-source-path
-                     (interpreted-code-location-ir1-node code-location)))))))
-         (t tlf-offset))))
-
+           (etypecase code-location
+             (compiled-code-location
+              (unless (fill-in-code-location code-location)
+                ;; This check should be unnecessary. We're missing
+                ;; debug info the compiler should have dumped.
+                (bug "unknown code location"))
+              (code-location-%tlf-offset code-location))
+             ;; (There used to be more cases back before sbcl-0.7.0,,
+             ;; when we did special tricks to debug the IR1
+             ;; interpreter.)
+             ))
+          (t tlf-offset))))
+
+;;; 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)
 (defun code-location-form-number (code-location)

-  #!+sb-doc
-  "Returns 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."

   (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)
   (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.
-               (error "internal error: unknown code location"))
-             (code-location-%form-number code-location))
-            (interpreted-code-location
-             (setf (code-location-%form-number code-location)
-                   (sb!c::source-path-form-number
-                    (sb!c::node-source-path
-                     (interpreted-code-location-ir1-node code-location)))))))
-         (t form-num))))
-
+           (etypecase code-location
+             (compiled-code-location
+              (unless (fill-in-code-location code-location)
+                ;; This check should be unnecessary. We're missing
+                ;; debug info the compiler should have dumped.
+                (bug "unknown code location"))
+              (code-location-%form-number code-location))
+             ;; (There used to be more cases back before sbcl-0.7.0,,
+             ;; when we did special tricks to debug the IR1
+             ;; interpreter.)
+             ))
+          (t form-num))))
+
+;;; Return the kind of CODE-LOCATION, one of:
+;;;  :INTERPRETED, :UNKNOWN-RETURN, :KNOWN-RETURN, :INTERNAL-ERROR,
+;;;  :NON-LOCAL-EXIT, :BLOCK-START, :CALL-SITE, :SINGLE-VALUE-RETURN,
+;;;  :NON-LOCAL-ENTRY

 (defun code-location-kind (code-location)
 (defun code-location-kind (code-location)

-  #!+sb-doc
-  "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"

   (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)
   (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.
-             (error "internal error: unknown code location"))
-            (t
-             (compiled-code-location-kind code-location)))))
-    (interpreted-code-location
-     :interpreted)))
+             ((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.
 
 ;;; This returns CODE-LOCATION's live-set if it is available. If
 ;;; there is no debug-block information, this returns NIL.

@@ -2274,121 +1850,103 @@
   (if (code-location-unknown-p code-location)
       nil
       (let ((live-set (compiled-code-location-%live-set code-location)))
   (if (code-location-unknown-p code-location)
       nil
       (let ((live-set (compiled-code-location-%live-set code-location)))

-       (cond ((eq live-set :unparsed)
-              (unless (fill-in-code-location code-location)
-                ;; This check should be unnecessary. We're missing debug info
-                ;; the compiler should have dumped.
-                ;;
-                ;; FIXME: This error and comment happen over and over again.
-                ;; Make them a shared function.
-                (error "internal error: unknown code location"))
-              (compiled-code-location-%live-set code-location))
-             (t live-set)))))
-
+        (cond ((eq live-set :unparsed)
+               (unless (fill-in-code-location code-location)
+                 ;; This check should be unnecessary. We're missing
+                 ;; debug info the compiler should have dumped.
+                 ;;
+                 ;; FIXME: This error and comment happen over and over again.
+                 ;; Make them a shared function.
+                 (bug "unknown code location"))
+               (compiled-code-location-%live-set code-location))
+              (t live-set)))))
+
+;;; true if OBJ1 and OBJ2 are the same place in the code

 (defun code-location= (obj1 obj2)
 (defun code-location= (obj1 obj2)

-  #!+sb-doc
-  "Returns whether obj1 and obj2 are the same place in the code."

   (etypecase obj1
     (compiled-code-location
      (etypecase obj2
        (compiled-code-location
   (etypecase obj1
     (compiled-code-location
      (etypecase obj2
        (compiled-code-location

-       (and (eq (code-location-debug-function obj1)
-                (code-location-debug-function obj2))
-            (sub-compiled-code-location= obj1 obj2)))
-       (interpreted-code-location
-       nil)))
-    (interpreted-code-location
-     (etypecase obj2
-       (compiled-code-location
-       nil)
-       (interpreted-code-location
-       (eq (interpreted-code-location-ir1-node obj1)
-           (interpreted-code-location-ir1-node obj2)))))))
+        (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)))
 
 (defun sub-compiled-code-location= (obj1 obj2)
   (= (compiled-code-location-pc obj1)
      (compiled-code-location-pc obj2)))
 

-;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil
+;;; Fill in CODE-LOCATION's :UNPARSED slots, returning T or NIL

 ;;; depending on whether the code-location was known in its
 ;;; depending on whether the code-location was known in its

-;;; debug-function's debug-block information. This may signal a
-;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and
+;;; 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))
 ;;; 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-function (code-location-debug-function code-location))
-        (blocks (debug-function-debug-blocks debug-function)))
+  (let* ((debug-fun (code-location-debug-fun code-location))
+         (blocks (debug-fun-debug-blocks debug-fun)))

     (declare (simple-vector blocks))
     (dotimes (i (length blocks) nil)
       (let* ((block (svref blocks i))
     (declare (simple-vector blocks))
     (dotimes (i (length blocks) nil)
       (let* ((block (svref blocks i))

-            (locations (compiled-debug-block-code-locations block)))
-       (declare (simple-vector locations))
-       (dotimes (j (length locations))
-         (let ((loc (svref locations j)))
-           (when (sub-compiled-code-location= code-location loc)
-             (setf (code-location-%debug-block code-location) block)
-             (setf (code-location-%tlf-offset code-location)
-                   (code-location-%tlf-offset loc))
-             (setf (code-location-%form-number code-location)
-                   (code-location-%form-number loc))
-             (setf (compiled-code-location-%live-set code-location)
-                   (compiled-code-location-%live-set loc))
-             (setf (compiled-code-location-kind code-location)
-                   (compiled-code-location-kind loc))
-             (return-from fill-in-code-location t))))))))
+             (locations (compiled-debug-block-code-locations block)))
+        (declare (simple-vector locations))
+        (dotimes (j (length locations))
+          (let ((loc (svref locations j)))
+            (when (sub-compiled-code-location= code-location loc)
+              (setf (code-location-%debug-block code-location) block)
+              (setf (code-location-%tlf-offset code-location)
+                    (code-location-%tlf-offset loc))
+              (setf (code-location-%form-number code-location)
+                    (code-location-%form-number loc))
+              (setf (compiled-code-location-%live-set code-location)
+                    (compiled-code-location-%live-set loc))
+              (setf (compiled-code-location-kind code-location)
+                    (compiled-code-location-kind loc))
+              (setf (compiled-code-location-step-info code-location)
+                    (compiled-code-location-step-info loc))
+              (return-from fill-in-code-location t))))))))

 \f
 ;;;; operations on DEBUG-BLOCKs
 
 \f
 ;;;; operations on DEBUG-BLOCKs
 

-(defmacro do-debug-block-locations ((code-var debug-block &optional return)
-                                   &body body)
-  #!+sb-doc
-  "Executes forms in a context with code-var bound to each code-location in
-   debug-block. This returns the value of executing result (defaults to nil)."
+;;; 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))
   (let ((code-locations (gensym))

-       (i (gensym)))
+        (i (gensym)))

     `(let ((,code-locations (debug-block-code-locations ,debug-block)))
        (declare (simple-vector ,code-locations))
     `(let ((,code-locations (debug-block-code-locations ,debug-block)))
        (declare (simple-vector ,code-locations))

-       (dotimes (,i (length ,code-locations) ,return)
-        (let ((,code-var (svref ,code-locations ,i)))
-          ,@body)))))
+       (dotimes (,i (length ,code-locations) ,result)
+         (let ((,code-var (svref ,code-locations ,i)))
+           ,@body)))))

 
 

-(defun debug-block-function-name (debug-block)
-  #!+sb-doc
-  "Returns the name of the function represented by debug-function. This may
-   be a string or a cons; do not assume it is a symbol."
+;;; 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))
   (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-function-name
-           (code-location-debug-function (svref code-locs 0))))))
-    (interpreted-debug-block
-     (sb!c::lambda-name (sb!c::block-home-lambda
-                        (interpreted-debug-block-ir1-block debug-block))))))
+           "??? 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))
 
 (defun debug-block-code-locations (debug-block)
   (etypecase debug-block
     (compiled-debug-block
      (compiled-debug-block-code-locations debug-block))

-    (interpreted-debug-block
-     (interpreted-debug-block-code-locations debug-block))))
-
-(defun interpreted-debug-block-code-locations (debug-block)
-  (let ((code-locs (interpreted-debug-block-locations debug-block)))
-    (if (eq code-locs :unparsed)
-       (with-parsing-buffer (buf)
-         (sb!c::do-nodes (node cont (interpreted-debug-block-ir1-block
-                                  debug-block))
-           (vector-push-extend (make-interpreted-code-location
-                                node
-                                (make-interpreted-debug-function
-                                 (sb!c::block-home-lambda (sb!c::node-block
-                                                           node))))
-                               buf))
-         (setf (interpreted-debug-block-locations debug-block)
-               (result buf)))
-       code-locs)))
+    ;; (There used to be more cases back before sbcl-0.7.0, when we
+    ;; did special tricks to debug the IR1 interpreter.)
+    ))

 \f
 ;;;; operations on debug variables
 
 \f
 ;;;; operations on debug variables
 

@@ -2401,649 +1959,571 @@
 (defun debug-var-package-name (debug-var)
   (package-name (symbol-package (debug-var-symbol debug-var))))
 
 (defun debug-var-package-name (debug-var)
   (package-name (symbol-package (debug-var-symbol debug-var))))
 

+;;; Return the value stored for DEBUG-VAR in frame, or if the value is
+;;; not :VALID, then signal an INVALID-VALUE error.

 (defun debug-var-valid-value (debug-var frame)
 (defun debug-var-valid-value (debug-var frame)

-  #!+sb-doc
-  "Returns the value stored for DEBUG-VAR in frame. If the value is not
-   :valid, then this signals an invalid-value error."

   (unless (eq (debug-var-validity debug-var (frame-code-location frame))
   (unless (eq (debug-var-validity debug-var (frame-code-location frame))

-             :valid)
+              :valid)

     (error 'invalid-value :debug-var debug-var :frame frame))
   (debug-var-value debug-var frame))
 
     (error 'invalid-value :debug-var debug-var :frame frame))
   (debug-var-value debug-var frame))
 

+;;; Returns the value stored for DEBUG-VAR in frame. The value may be
+;;; invalid. This is SETFable.

 (defun debug-var-value (debug-var frame)
 (defun debug-var-value (debug-var frame)

-  #!+sb-doc
-  "Returns the value stored for DEBUG-VAR in frame. The value may be
-   invalid. This is SETF'able."
-  (etypecase debug-var
-    (compiled-debug-var
-     (check-type frame compiled-frame)
-     (let ((res (access-compiled-debug-var-slot debug-var frame)))
-       (if (indirect-value-cell-p res)
-          (sb!c:value-cell-ref res)
-          res)))
-    (interpreted-debug-var
-     (check-type frame interpreted-frame)
-     (sb!eval::leaf-value-lambda-var
-      (interpreted-code-location-ir1-node (frame-code-location frame))
-      (interpreted-debug-var-ir1-var debug-var)
-      (frame-pointer frame)
-      (interpreted-frame-closure frame)))))
+  (aver (typep frame 'compiled-frame))
+  (let ((res (access-compiled-debug-var-slot debug-var frame)))
+    (if (indirect-value-cell-p res)
+        (value-cell-ref res)
+        res)))

 
 ;;; This returns what is stored for the variable represented by
 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
 ;;; cell if the variable is both closed over and set.
 (defun access-compiled-debug-var-slot (debug-var frame)
 
 ;;; This returns what is stored for the variable represented by
 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
 ;;; cell if the variable is both closed over and set.
 (defun access-compiled-debug-var-slot (debug-var frame)

+  (declare (optimize (speed 1)))

   (let ((escaped (compiled-frame-escaped frame)))
     (if escaped
   (let ((escaped (compiled-frame-escaped frame)))
     (if escaped

-       (sub-access-debug-var-slot
-        (frame-pointer frame)
-        (compiled-debug-var-sc-offset debug-var)
-        escaped)
-       (sub-access-debug-var-slot
-        (frame-pointer frame)
-        (or (compiled-debug-var-save-sc-offset debug-var)
-            (compiled-debug-var-sc-offset debug-var))))))
+        (sub-access-debug-var-slot
+         (frame-pointer frame)
+         (compiled-debug-var-sc-offset debug-var)
+         escaped)
+      (sub-access-debug-var-slot
+       (frame-pointer frame)
+       (or (compiled-debug-var-save-sc-offset debug-var)
+           (compiled-debug-var-sc-offset debug-var))))))

 
 ;;; a helper function for working with possibly-invalid values:
 
 ;;; a helper function for working with possibly-invalid values:

-;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
+;;; 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.)
 ;;;
 ;;; (Such values can arise in registers on machines with conservative
 ;;; GC, and might also arise in debug variable locations when
 ;;; those variables are invalid.)

-(defun make-valid-lisp-obj (val)
-  (/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
-  #!+sb-show (%primitive print (sb!impl::hexstr val))
+;;;
+;;; NOTE: this function is not GC-safe in the slightest when creating
+;;; a pointer to an object in dynamic space.  If a GC occurs between
+;;; the start of the call to VALID-LISP-POINTER-P and the end of
+;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
+;;; is constructed.  This can happen on CHENEYGC if an asynchronous
+;;; interrupt occurs within the window.  This can happen on GENCGC
+;;; under the same circumstances, but is more likely due to all GENCGC
+;;; platforms supporting threaded operation.  This is somewhat
+;;; mitigated on x86oids due to the conservative stack and interrupt
+;;; context "scavenging" on such platforms, but there still may be a
+;;; vulnerable window.
+(defun make-lisp-obj (val &optional (errorp t))

   (if (or
        ;; fixnum
   (if (or
        ;; fixnum

-       (zerop (logand val 3))
+       (zerop (logand val sb!vm:fixnum-tag-mask))
+       ;; immediate single float, 64-bit only
+       #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+       (= (logand val #xff) sb!vm:single-float-widetag)

        ;; character
        ;; character

-       (and (zerop (logand val #xffff0000)) ; Top bits zero
-           (= (logand val #xff) sb!vm:base-char-type)) ; Char tag
+       (and (zerop (logandc2 val #x1fffffff)) ; Top bits zero
+            (= (logand val #xff) sb!vm:character-widetag)) ; char tag

        ;; unbound marker
        ;; unbound marker

-       (= val sb!vm:unbound-marker-type)
+       (= val sb!vm:unbound-marker-widetag)
+       ;; undefined_tramp doesn't validate properly as a pointer, and
+       ;; the actual value can vary by backend (x86oids need not
+       ;; apply)
+       #!+(or alpha hppa mips ppc)
+       (= val (+ (- (foreign-symbol-address "undefined_tramp")
+                    (* sb!vm:n-word-bytes sb!vm:simple-fun-code-offset))
+                 sb!vm:fun-pointer-lowtag))
+       #!+sparc
+       (= val (foreign-symbol-address "undefined_tramp"))

        ;; pointer
        ;; pointer

-       (and (logand val 1)
-           ;; Check that the pointer is valid. XXX Could do a better
-           ;; job. FIXME: e.g. by calling out to an is_valid_pointer
-           ;; routine in the C runtime support code
-           (or (< sb!vm:read-only-space-start val
-                  (* sb!vm:*read-only-space-free-pointer*
-                     sb!vm:word-bytes))
-               (< sb!vm:static-space-start val
-                  (* sb!vm:*static-space-free-pointer*
-                     sb!vm:word-bytes))
-               (< sb!vm:dynamic-space-start val
-                  (sap-int (dynamic-space-free-pointer))))))
-      (make-lisp-obj val)
-      :invalid-object))
-
-;;; CMU CL had
-;;;   (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..)
-;;; code for this case.
-#!-x86
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (error "hopelessly stale"))
-
-#!+x86
+       (not (zerop (valid-lisp-pointer-p (int-sap val)))))
+      (values (%make-lisp-obj val) t)
+      (if errorp
+          (error "~S is not a valid argument to ~S"
+                 val 'make-lisp-obj)
+          (values (make-unprintable-object (format nil "invalid object #x~X" val))
+                  nil))))
+

 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)

-  (declare (type system-area-pointer fp))
-  (/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
-  #!+sb-show (%primitive print (sb!impl::hexstr fp))
-  #!+sb-show (%primitive print (sb!impl::hexstr sc-offset))
-  #!+sb-show (%primitive print (sb!impl::hexstr escaped))
+  ;; NOTE: The long-float support in here is obviously decayed.  When
+  ;; the x86oid and non-x86oid versions of this function were unified,
+  ;; the behavior of long-floats was preserved, which only served to
+  ;; highlight its brokenness.

   (macrolet ((with-escaped-value ((var) &body forms)
   (macrolet ((with-escaped-value ((var) &body forms)

-              `(if escaped
-                   (let ((,var (sb!vm:context-register
-                                escaped
-                                (sb!c:sc-offset-offset sc-offset))))
-                     (/show0 "in escaped case, ,VAR value=..")
-                     #!+sb-show (%primitive print (sb!impl::hexstr ,var))
-                     ,@forms)
-                   :invalid-value-for-unescaped-register-storage))
-            (escaped-float-value (format)
-              `(if escaped
-                   (sb!vm:context-float-register
-                    escaped (sb!c:sc-offset-offset sc-offset) ',format)
-                   :invalid-value-for-unescaped-register-storage))
-            (escaped-complex-float-value (format)
-              `(if escaped
-                   (complex
-                    (sb!vm:context-float-register
-                     escaped (sb!c:sc-offset-offset sc-offset) ',format)
-                    (sb!vm:context-float-register
-                     escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
-                   :invalid-value-for-unescaped-register-storage)))
+               `(if escaped
+                    (let ((,var (sb!vm:context-register
+                                 escaped
+                                 (sb!c:sc-offset-offset sc-offset))))
+                      ,@forms)
+                    :invalid-value-for-unescaped-register-storage))
+             (escaped-float-value (format)
+               `(if escaped
+                    (sb!vm:context-float-register
+                     escaped
+                     (sb!c:sc-offset-offset sc-offset)
+                     ',format)
+                    :invalid-value-for-unescaped-register-storage))
+             (escaped-complex-float-value (format offset)
+               `(if escaped
+                    (complex
+                     (sb!vm:context-float-register
+                      escaped (sb!c:sc-offset-offset sc-offset) ',format)
+                     (sb!vm:context-float-register
+                      escaped (+ (sb!c:sc-offset-offset sc-offset) ,offset) ',format))
+                    :invalid-value-for-unescaped-register-storage))
+             (with-nfp ((var) &body body)
+               ;; x86oids have no separate number stack, so dummy it
+               ;; up for them.
+               #!+(or x86 x86-64)
+               `(let ((,var fp))
+                  ,@body)
+               #!-(or x86 x86-64)
+               `(let ((,var (if escaped
+                                (sb!sys:int-sap
+                                 (sb!vm:context-register escaped
+                                                         sb!vm::nfp-offset))
+                                #!-alpha
+                                (sb!sys:sap-ref-sap fp (* nfp-save-offset
+                                                          sb!vm:n-word-bytes))
+                                #!+alpha
+                                (sb!vm::make-number-stack-pointer
+                                 (sb!sys:sap-ref-32 fp (* nfp-save-offset
+                                                          sb!vm:n-word-bytes))))))
+                  ,@body))
+             (stack-frame-offset (data-width offset)
+               #!+(or x86 x86-64)
+               `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset)
+                                           (1- ,data-width)
+                                           ,offset))
+               #!-(or x86 x86-64)
+               (declare (ignore data-width))
+               #!-(or x86 x86-64)
+               `(* (+ (sb!c:sc-offset-offset sc-offset) ,offset)
+                   sb!vm:n-word-bytes)))

     (ecase (sb!c:sc-offset-scn sc-offset)
     (ecase (sb!c:sc-offset-scn sc-offset)

-      ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
-       (/show0 "case of ANY-REG-SC-NUMBER or DESCRIPTOR-REG-SC-NUMBER")
+      ((#.sb!vm:any-reg-sc-number
+        #.sb!vm:descriptor-reg-sc-number
+        #!+rt #.sb!vm:word-pointer-reg-sc-number)

        (without-gcing
        (without-gcing

-       (with-escaped-value (val)
-         (/show0 "VAL=..")
-         #!+sb-show (%primitive print (sb!impl::hexstr val))
-         (make-valid-lisp-obj val))))
-      (#.sb!vm:base-char-reg-sc-number
-       (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
+        (with-escaped-value (val)
+          (make-lisp-obj val nil))))
+      (#.sb!vm:character-reg-sc-number

        (with-escaped-value (val)
        (with-escaped-value (val)

-        (code-char val)))
+         (code-char val)))

       (#.sb!vm:sap-reg-sc-number
       (#.sb!vm:sap-reg-sc-number

-       (/show0 "case of SAP-REG-SC-NUMBER")

        (with-escaped-value (val)
        (with-escaped-value (val)

-        (int-sap val)))
+         (sb!sys:int-sap val)))

       (#.sb!vm:signed-reg-sc-number
       (#.sb!vm:signed-reg-sc-number

-       (/show0 "case of SIGNED-REG-SC-NUMBER")

        (with-escaped-value (val)
        (with-escaped-value (val)

-        (if (logbitp (1- sb!vm:word-bits) val)
-            (logior val (ash -1 sb!vm:word-bits))
-            val)))
+         (if (logbitp (1- sb!vm:n-word-bits) val)
+             (logior val (ash -1 sb!vm:n-word-bits))
+             val)))

       (#.sb!vm:unsigned-reg-sc-number
       (#.sb!vm:unsigned-reg-sc-number

-       (/show0 "case of UNSIGNED-REG-SC-NUMBER")

        (with-escaped-value (val)
        (with-escaped-value (val)

-        val))
+         val))
+      #!-(or x86 x86-64)
+      (#.sb!vm:non-descriptor-reg-sc-number
+       (error "Local non-descriptor register access?"))
+      #!-(or x86 x86-64)
+      (#.sb!vm:interior-reg-sc-number
+       (error "Local interior register access?"))

       (#.sb!vm:single-reg-sc-number
       (#.sb!vm:single-reg-sc-number

-       (/show0 "case of SINGLE-REG-SC-NUMBER")

        (escaped-float-value single-float))
       (#.sb!vm:double-reg-sc-number
        (escaped-float-value single-float))
       (#.sb!vm:double-reg-sc-number

-       (/show0 "case of DOUBLE-REG-SC-NUMBER")

        (escaped-float-value double-float))
       #!+long-float
       (#.sb!vm:long-reg-sc-number
        (escaped-float-value double-float))
       #!+long-float
       (#.sb!vm:long-reg-sc-number

-       (/show0 "case of LONG-REG-SC-NUMBER")

        (escaped-float-value long-float))
       (#.sb!vm:complex-single-reg-sc-number
        (escaped-float-value long-float))
       (#.sb!vm:complex-single-reg-sc-number

-       (/show0 "case of COMPLEX-SINGLE-REG-SC-NUMBER")
-       (escaped-complex-float-value single-float))
+       (escaped-complex-float-value single-float 1))

       (#.sb!vm:complex-double-reg-sc-number
       (#.sb!vm:complex-double-reg-sc-number

-       (/show0 "case of COMPLEX-DOUBLE-REG-SC-NUMBER")
-       (escaped-complex-float-value double-float))
+       (escaped-complex-float-value double-float #!+sparc 2 #!-sparc 1))

       #!+long-float
       (#.sb!vm:complex-long-reg-sc-number
       #!+long-float
       (#.sb!vm:complex-long-reg-sc-number

-       (/show0 "case of COMPLEX-LONG-REG-SC-NUMBER")
-       (escaped-complex-float-value long-float))
+       (escaped-complex-float-value long-float
+                                    #!+sparc 4 #!+(or x86 x86-64) 1
+                                    #!-(or sparc x86 x86-64) 0))

       (#.sb!vm:single-stack-sc-number
       (#.sb!vm:single-stack-sc-number

-       (/show0 "case of SINGLE-STACK-SC-NUMBER")
-       (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                               sb!vm:word-bytes))))
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-single nfp (stack-frame-offset 1 0))))

       (#.sb!vm:double-stack-sc-number
       (#.sb!vm:double-stack-sc-number

-       (/show0 "case of DOUBLE-STACK-SC-NUMBER")
-       (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                               sb!vm:word-bytes))))
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-double nfp (stack-frame-offset 2 0))))

       #!+long-float
       (#.sb!vm:long-stack-sc-number
       #!+long-float
       (#.sb!vm:long-stack-sc-number

-       (/show0 "case of LONG-STACK-SC-NUMBER")
-       (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
-                             sb!vm:word-bytes))))
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-long nfp (stack-frame-offset 3 0))))

       (#.sb!vm:complex-single-stack-sc-number
       (#.sb!vm:complex-single-stack-sc-number

-       (/show0 "case of COMPLEX-STACK-SC-NUMBER")
-       (complex
-       (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                sb!vm:word-bytes)))
-       (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                                sb!vm:word-bytes)))))
+       (with-nfp (nfp)
+         (complex
+          (sb!sys:sap-ref-single nfp (stack-frame-offset 1 0))
+          (sb!sys:sap-ref-single nfp (stack-frame-offset 1 1)))))

       (#.sb!vm:complex-double-stack-sc-number
       (#.sb!vm:complex-double-stack-sc-number

-       (/show0 "case of COMPLEX-DOUBLE-STACK-SC-NUMBER")
-       (complex
-       (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                                sb!vm:word-bytes)))
-       (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
-                                sb!vm:word-bytes)))))
+       (with-nfp (nfp)
+         (complex
+          (sb!sys:sap-ref-double nfp (stack-frame-offset 2 0))
+          (sb!sys:sap-ref-double nfp (stack-frame-offset 2 2)))))

       #!+long-float
       (#.sb!vm:complex-long-stack-sc-number
       #!+long-float
       (#.sb!vm:complex-long-stack-sc-number

-       (/show0 "case of COMPLEX-LONG-STACK-SC-NUMBER")
-       (complex
-       (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
-                              sb!vm:word-bytes)))
-       (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
-                              sb!vm:word-bytes)))))
+       (with-nfp (nfp)
+         (complex
+          (sb!sys:sap-ref-long nfp (stack-frame-offset 3 0))
+          (sb!sys:sap-ref-long nfp
+                               (stack-frame-offset 3 #!+sparc 4
+                                                   #!+(or x86 x86-64) 3
+                                                   #!-(or sparc x86 x86-64) 0)))))

       (#.sb!vm:control-stack-sc-number
       (#.sb!vm:control-stack-sc-number

-       (/show0 "case of CONTROL-STACK-SC-NUMBER")

        (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
        (stack-ref fp (sb!c:sc-offset-offset sc-offset)))

-      (#.sb!vm:base-char-stack-sc-number
-       (/show0 "case of BASE-CHAR-STACK-SC-NUMBER")
-       (code-char
-       (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                            sb!vm:word-bytes)))))
+      (#.sb!vm:character-stack-sc-number
+       (with-nfp (nfp)
+         (code-char (sb!sys:sap-ref-word nfp (stack-frame-offset 1 0)))))

       (#.sb!vm:unsigned-stack-sc-number
       (#.sb!vm:unsigned-stack-sc-number

-       (/show0 "case of UNSIGNED-STACK-SC-NUMBER")
-       (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                           sb!vm:word-bytes))))
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-word nfp (stack-frame-offset 1 0))))

       (#.sb!vm:signed-stack-sc-number
       (#.sb!vm:signed-stack-sc-number

-       (/show0 "case of SIGNED-STACK-SC-NUMBER")
-       (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                  sb!vm:word-bytes))))
+       (with-nfp (nfp)
+         (sb!sys:signed-sap-ref-word nfp (stack-frame-offset 1 0))))

       (#.sb!vm:sap-stack-sc-number
       (#.sb!vm:sap-stack-sc-number

-       (/show0 "case of SAP-STACK-SC-NUMBER")
-       (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                            sb!vm:word-bytes)))))))
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-sap nfp (stack-frame-offset 1 0)))))))

 
 ;;; This stores value as the value of DEBUG-VAR in FRAME. In the
 ;;; COMPILED-DEBUG-VAR case, access the current value to determine if
 ;;; it is an indirect value cell. This occurs when the variable is
 
 ;;; 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. For INTERPRETED-DEBUG-VARs just call
-;;; SB!EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter
-;;; objects.
-(defun %set-debug-var-value (debug-var frame value)
-  (etypecase debug-var
-    (compiled-debug-var
-     (check-type frame compiled-frame)
-     (let ((current-value (access-compiled-debug-var-slot debug-var frame)))
-       (if (indirect-value-cell-p current-value)
-          (sb!c:value-cell-set current-value value)
-          (set-compiled-debug-var-slot debug-var frame value))))
-    (interpreted-debug-var
-     (check-type frame interpreted-frame)
-     (sb!eval::set-leaf-value-lambda-var
-      (interpreted-code-location-ir1-node (frame-code-location frame))
-      (interpreted-debug-var-ir1-var debug-var)
-      (frame-pointer frame)
-      (interpreted-frame-closure frame)
-      value)))
-  value)
-
-;;; This stores value for the variable represented by debug-var
+;;; both closed over and set.
+(defun %set-debug-var-value (debug-var frame new-value)
+  (aver (typep frame 'compiled-frame))
+  (let ((old-value (access-compiled-debug-var-slot debug-var frame)))
+    (if (indirect-value-cell-p old-value)
+        (value-cell-set old-value new-value)
+        (set-compiled-debug-var-slot debug-var frame new-value)))
+  new-value)
+
+;;; This stores VALUE for the variable represented by debug-var

 ;;; relative to the frame. This assumes the location directly contains
 ;;; the variable's value; that is, there is no indirect value cell
 ;;; currently there in case the variable is both closed over and set.
 (defun set-compiled-debug-var-slot (debug-var frame value)
   (let ((escaped (compiled-frame-escaped frame)))
     (if escaped
 ;;; relative to the frame. This assumes the location directly contains
 ;;; the variable's value; that is, there is no indirect value cell
 ;;; currently there in case the variable is both closed over and set.
 (defun set-compiled-debug-var-slot (debug-var frame value)
   (let ((escaped (compiled-frame-escaped frame)))
     (if escaped

-       (sub-set-debug-var-slot (frame-pointer frame)
-                               (compiled-debug-var-sc-offset debug-var)
-                               value escaped)
-       (sub-set-debug-var-slot
-        (frame-pointer frame)
-        (or (compiled-debug-var-save-sc-offset debug-var)
-            (compiled-debug-var-sc-offset debug-var))
-        value))))
-
-#!-x86
+        (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)
 (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)
   (macrolet ((set-escaped-value (val)

-              `(if escaped
-                   (setf (sb!vm:context-register
-                          escaped
-                          (sb!c:sc-offset-offset sc-offset))
-                         ,val)
-                   value))
-            (set-escaped-float-value (format val)
-              `(if escaped
-                   (setf (sb!vm:context-float-register
-                          escaped
-                          (sb!c:sc-offset-offset sc-offset)
-                          ',format)
-                         ,val)
-                   value))
-            (with-nfp ((var) &body body)
-              `(let ((,var (if escaped
-                               (int-sap
-                                (sb!vm:context-register escaped
-                                                        sb!vm::nfp-offset))
-                               #!-alpha
-                               (sap-ref-sap fp
-                                                   (* sb!vm::nfp-save-offset
-                                                      sb!vm:word-bytes))
-                               #!+alpha
-                               (%alpha::make-number-stack-pointer
-                                (sap-ref-32 fp
-                                                   (* sb!vm::nfp-save-offset
-                                                      sb!vm:word-bytes))))))
-                 ,@body)))
+               `(if escaped
+                    (setf (sb!vm:context-register
+                           escaped
+                           (sb!c:sc-offset-offset sc-offset))
+                          ,val)
+                    value))
+             (set-escaped-float-value (format val)
+               `(if escaped
+                    (setf (sb!vm:context-float-register
+                           escaped
+                           (sb!c:sc-offset-offset sc-offset)
+                           ',format)
+                          ,val)
+                    value))
+             (set-escaped-complex-float-value (format offset val)
+               `(progn
+                  (when escaped
+                    (setf (sb!vm:context-float-register
+                           escaped (sb!c:sc-offset-offset sc-offset) ',format)
+                          (realpart value))
+                    (setf (sb!vm:context-float-register
+                           escaped (+ (sb!c:sc-offset-offset sc-offset) ,offset)
+                           ',format)
+                          (imagpart value)))
+                  ,val))
+             (with-nfp ((var) &body body)
+               ;; x86oids have no separate number stack, so dummy it
+               ;; up for them.
+               #!+(or x86 x86-64)
+               `(let ((,var fp))
+                  ,@body)
+               #!-(or x86 x86-64)
+               `(let ((,var (if escaped
+                                (int-sap
+                                 (sb!vm:context-register escaped
+                                                         sb!vm::nfp-offset))
+                                #!-alpha
+                                (sap-ref-sap fp
+                                             (* nfp-save-offset
+                                                sb!vm:n-word-bytes))
+                                #!+alpha
+                                (sb!vm::make-number-stack-pointer
+                                 (sap-ref-32 fp
+                                             (* nfp-save-offset
+                                                sb!vm:n-word-bytes))))))
+                  ,@body))
+             (stack-frame-offset (data-width offset)
+               #!+(or x86 x86-64)
+               `(sb!vm::frame-byte-offset (+ (sb!c:sc-offset-offset sc-offset)
+                                           (1- ,data-width)
+                                           ,offset))
+               #!-(or x86 x86-64)
+               (declare (ignore data-width))
+               #!-(or x86 x86-64)
+               `(* (+ (sb!c:sc-offset-offset sc-offset) ,offset)
+                   sb!vm:n-word-bytes)))

     (ecase (sb!c:sc-offset-scn sc-offset)
       ((#.sb!vm:any-reg-sc-number
     (ecase (sb!c:sc-offset-scn sc-offset)
       ((#.sb!vm:any-reg-sc-number

-       #.sb!vm:descriptor-reg-sc-number
-       #!+rt #.sb!vm:word-pointer-reg-sc-number)
+        #.sb!vm:descriptor-reg-sc-number
+        #!+rt #.sb!vm:word-pointer-reg-sc-number)

        (without-gcing
        (without-gcing

-       (set-escaped-value
-         (get-lisp-obj-address value))))
-      (#.sb!vm:base-char-reg-sc-number
+        (set-escaped-value
+          (get-lisp-obj-address value))))
+      (#.sb!vm:character-reg-sc-number

        (set-escaped-value (char-code value)))
       (#.sb!vm:sap-reg-sc-number
        (set-escaped-value (sap-int value)))
       (#.sb!vm:signed-reg-sc-number
        (set-escaped-value (char-code value)))
       (#.sb!vm:sap-reg-sc-number
        (set-escaped-value (sap-int value)))
       (#.sb!vm:signed-reg-sc-number

-       (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
+       (set-escaped-value (logand value (1- (ash 1 sb!vm:n-word-bits)))))

       (#.sb!vm:unsigned-reg-sc-number
        (set-escaped-value value))
       (#.sb!vm:unsigned-reg-sc-number
        (set-escaped-value value))

+      #!-(or x86 x86-64)

       (#.sb!vm:non-descriptor-reg-sc-number
        (error "Local non-descriptor register access?"))
       (#.sb!vm:non-descriptor-reg-sc-number
        (error "Local non-descriptor register access?"))

+      #!-(or x86 x86-64)

       (#.sb!vm:interior-reg-sc-number
        (error "Local interior register access?"))
       (#.sb!vm:single-reg-sc-number
       (#.sb!vm:interior-reg-sc-number
        (error "Local interior register access?"))
       (#.sb!vm:single-reg-sc-number

+       #!-(or x86 x86-64) ;; don't have escaped floats.

        (set-escaped-float-value single-float value))
       (#.sb!vm:double-reg-sc-number
        (set-escaped-float-value single-float value))
       (#.sb!vm:double-reg-sc-number

+       #!-(or x86 x86-64) ;; don't have escaped floats -- still in npx?

        (set-escaped-float-value double-float value))
       #!+long-float
       (#.sb!vm:long-reg-sc-number
        (set-escaped-float-value double-float value))
       #!+long-float
       (#.sb!vm:long-reg-sc-number

+       #!-(or x86 x86-64) ;; don't have escaped floats -- still in npx?

        (set-escaped-float-value long-float value))
        (set-escaped-float-value long-float value))

+      #!-(or x86 x86-64)

       (#.sb!vm:complex-single-reg-sc-number
       (#.sb!vm:complex-single-reg-sc-number

-       (when escaped
-        (setf (sb!vm:context-float-register escaped
-                                            (sb!c:sc-offset-offset sc-offset)
-                                            'single-float)
-              (realpart value))
-        (setf (sb!vm:context-float-register
-               escaped (1+ (sb!c:sc-offset-offset sc-offset))
-               'single-float)
-              (imagpart value)))
-       value)
+       (set-escaped-complex-float-value single-float 1 value))
+      #!-(or x86 x86-64)

       (#.sb!vm:complex-double-reg-sc-number
       (#.sb!vm:complex-double-reg-sc-number

-       (when escaped
-        (setf (sb!vm:context-float-register
-               escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
-              (realpart value))
-        (setf (sb!vm:context-float-register
-               escaped
-               (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
-               'double-float)
-              (imagpart value)))
-       value)
-      #!+long-float
+       (set-escaped-complex-float-value double-float #!+sparc 2 #!-sparc 1 value))
+      #!+(and long-float (not (or x86 x86-64)))

       (#.sb!vm:complex-long-reg-sc-number
       (#.sb!vm:complex-long-reg-sc-number

-       (when escaped
-        (setf (sb!vm:context-float-register
-               escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
-              (realpart value))
-        (setf (sb!vm:context-float-register
-               escaped
-               (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
-               'long-float)
-              (imagpart value)))
-       value)
+       (set-escaped-complex-float-value long-float #!+sparc 4 #!-sparc 0 value))

       (#.sb!vm:single-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:single-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
-                                     sb!vm:word-bytes))
-              (the single-float value))))
+         (setf (sap-ref-single nfp (stack-frame-offset 1 0))
+               (the single-float value))))

       (#.sb!vm:double-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:double-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
-                                     sb!vm:word-bytes))
-              (the double-float value))))
+         (setf (sap-ref-double nfp (stack-frame-offset 2 0))
+               (the double-float value))))

       #!+long-float
       (#.sb!vm:long-stack-sc-number
        (with-nfp (nfp)
       #!+long-float
       (#.sb!vm:long-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
-                                   sb!vm:word-bytes))
-              (the long-float value))))
+         (setf (sap-ref-long nfp (stack-frame-offset 3 0))
+               (the long-float value))))

       (#.sb!vm:complex-single-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:complex-single-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-single
-               nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
-              (the single-float (realpart value)))
-        (setf (sap-ref-single
-               nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
-                      sb!vm:word-bytes))
-              (the single-float (realpart value)))))
+         (setf (sap-ref-single
+                nfp (stack-frame-offset 1 0))
+               #!+(or x86 x86-64)
+               (realpart (the (complex single-float) value))
+               #!-(or x86 x86-64)
+               (the single-float (realpart value)))
+         (setf (sap-ref-single
+                nfp (stack-frame-offset 1 1))
+               #!+(or x86 x86-64)
+               (imagpart (the (complex single-float) value))
+               #!-(or x86 x86-64)
+               (the single-float (realpart value)))))

       (#.sb!vm:complex-double-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:complex-double-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-double
-               nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
-              (the double-float (realpart value)))
-        (setf (sap-ref-double
-               nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                      sb!vm:word-bytes))
-              (the double-float (realpart value)))))
+         (setf (sap-ref-double
+                nfp (stack-frame-offset 2 0))
+               #!+(or x86 x86-64)
+               (realpart (the (complex double-float) value))
+               #!-(or x86 x86-64)
+               (the double-float (realpart value)))
+         (setf (sap-ref-double
+                nfp (stack-frame-offset 2 2))
+               #!+(or x86 x86-64)
+               (imagpart (the (complex double-float) value))
+               #!-(or x86 x86-64)
+               (the double-float (realpart value)))))

       #!+long-float
       (#.sb!vm:complex-long-stack-sc-number
        (with-nfp (nfp)
       #!+long-float
       (#.sb!vm:complex-long-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-long
-               nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
-              (the long-float (realpart value)))
-        (setf (sap-ref-long
-               nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
-                      sb!vm:word-bytes))
-              (the long-float (realpart value)))))
+         (setf (sap-ref-long
+                nfp (stack-frame-offset 3 0))
+               #!+(or x86 x86-64)
+               (realpart (the (complex long-float) value))
+               #!-(or x86 x86-64)
+               (the long-float (realpart value)))
+         (setf (sap-ref-long
+                nfp (stack-frame-offset 3 #!+sparc 4
+                                        #!+(or x86 x86-64) 3
+                                        #!-(or sparc x86 x86-64) 0))
+               #!+(or x86 x86-64)
+               (imagpart (the (complex long-float) value))
+               #!-(or x86 x86-64)
+               (the long-float (realpart value)))))

       (#.sb!vm:control-stack-sc-number
        (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
       (#.sb!vm:control-stack-sc-number
        (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))

-      (#.sb!vm:base-char-stack-sc-number
+      (#.sb!vm:character-stack-sc-number

        (with-nfp (nfp)
        (with-nfp (nfp)

-        (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
-                                        sb!vm:word-bytes))
-              (char-code (the character value)))))
+         (setf (sap-ref-word nfp (stack-frame-offset 1 0))
+               (char-code (the character value)))))

       (#.sb!vm:unsigned-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:unsigned-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
-                                 sb!vm:word-bytes))
-              (the (unsigned-byte 32) value))))
+         (setf (sap-ref-word nfp (stack-frame-offset 1 0))
+               (the (unsigned-byte 32) value))))

       (#.sb!vm:signed-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:signed-stack-sc-number
        (with-nfp (nfp)

-        (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
-                                        sb!vm:word-bytes))
-              (the (signed-byte 32) value))))
+         (setf (signed-sap-ref-word nfp (stack-frame-offset 1 0))
+               (the (signed-byte 32) value))))

       (#.sb!vm:sap-stack-sc-number
        (with-nfp (nfp)
       (#.sb!vm:sap-stack-sc-number
        (with-nfp (nfp)

-        (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
-                                  sb!vm:word-bytes))
-              (the system-area-pointer value)))))))
-
-#!+x86
-(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
-  (macrolet ((set-escaped-value (val)
-              `(if escaped
-                   (setf (sb!vm:context-register
-                          escaped
-                          (sb!c:sc-offset-offset sc-offset))
-                         ,val)
-                   value)))
-    (ecase (sb!c:sc-offset-scn sc-offset)
-      ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
-       (without-gcing
-       (set-escaped-value
-         (get-lisp-obj-address value))))
-      (#.sb!vm:base-char-reg-sc-number
-       (set-escaped-value (char-code value)))
-      (#.sb!vm:sap-reg-sc-number
-       (set-escaped-value (sap-int value)))
-      (#.sb!vm:signed-reg-sc-number
-       (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
-      (#.sb!vm:unsigned-reg-sc-number
-       (set-escaped-value value))
-      (#.sb!vm:single-reg-sc-number
-       #+nil ;; don't have escaped floats.
-       (set-escaped-float-value single-float value))
-      (#.sb!vm:double-reg-sc-number
-       #+nil ;;  don't have escaped floats -- still in npx?
-       (set-escaped-float-value double-float value))
-      #!+long-float
-      (#.sb!vm:long-reg-sc-number
-       #+nil ;;  don't have escaped floats -- still in npx?
-       (set-escaped-float-value long-float value))
-      (#.sb!vm:single-stack-sc-number
-       (setf (sap-ref-single
-             fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                      sb!vm:word-bytes)))
-            (the single-float value)))
-      (#.sb!vm:double-stack-sc-number
-       (setf (sap-ref-double
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                      sb!vm:word-bytes)))
-            (the double-float value)))
-      #!+long-float
-      (#.sb!vm:long-stack-sc-number
-       (setf (sap-ref-long
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
-                      sb!vm:word-bytes)))
-            (the long-float value)))
-      (#.sb!vm:complex-single-stack-sc-number
-       (setf (sap-ref-single
-             fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                      sb!vm:word-bytes)))
-            (realpart (the (complex single-float) value)))
-       (setf (sap-ref-single
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                      sb!vm:word-bytes)))
-            (imagpart (the (complex single-float) value))))
-      (#.sb!vm:complex-double-stack-sc-number
-       (setf (sap-ref-double
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
-                      sb!vm:word-bytes)))
-            (realpart (the (complex double-float) value)))
-       (setf (sap-ref-double
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
-                      sb!vm:word-bytes)))
-            (imagpart (the (complex double-float) value))))
-      #!+long-float
-      (#.sb!vm:complex-long-stack-sc-number
-       (setf (sap-ref-long
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
-                      sb!vm:word-bytes)))
-            (realpart (the (complex long-float) value)))
-       (setf (sap-ref-long
-             fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
-                      sb!vm:word-bytes)))
-            (imagpart (the (complex long-float) value))))
-      (#.sb!vm:control-stack-sc-number
-       (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
-      (#.sb!vm:base-char-stack-sc-number
-       (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                        sb!vm:word-bytes)))
-            (char-code (the character value))))
-      (#.sb!vm:unsigned-stack-sc-number
-       (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                        sb!vm:word-bytes)))
-            (the (unsigned-byte 32) value)))
-      (#.sb!vm:signed-stack-sc-number
-       (setf (signed-sap-ref-32
-             fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))
-            (the (signed-byte 32) value)))
-      (#.sb!vm:sap-stack-sc-number
-       (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
-                                         sb!vm:word-bytes)))
-            (the system-area-pointer value))))))
+         (setf (sap-ref-sap nfp (stack-frame-offset 1 0))
+               (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)
 
 ;;; 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 (= (get-lowtag x) sb!vm:other-pointer-type)
-       (= (get-type x) sb!vm:value-cell-header-type)))
-
+  (and (= (lowtag-of x) sb!vm:other-pointer-lowtag)
+       (= (widetag-of x) sb!vm:value-cell-header-widetag)))
+
+;;; Return three values reflecting the validity of DEBUG-VAR's value
+;;; at BASIC-CODE-LOCATION:
+;;;   :VALID    The value is known to be available.
+;;;   :INVALID  The value is known to be unavailable.
+;;;   :UNKNOWN  The value's availability is unknown.
+;;;

 ;;; If the variable is always alive, then it is valid. If the
 ;;; code-location is unknown, then the variable's validity is
 ;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
 ;;; live-set information has been cached in the code-location.
 (defun debug-var-validity (debug-var basic-code-location)
 ;;; 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)

-  #!+sb-doc
-  "Returns 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."
-  (etypecase debug-var
-    (compiled-debug-var
-     (compiled-debug-var-validity debug-var basic-code-location))
-    (interpreted-debug-var
-     (check-type basic-code-location interpreted-code-location)
-     (let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var)
-                          (sb!c::lexenv-variables
-                           (sb!c::node-lexenv
-                            (interpreted-code-location-ir1-node
-                             basic-code-location))))))
-       (if validp :valid :invalid)))))
+  (compiled-debug-var-validity debug-var basic-code-location))
+
+(defun debug-var-info (debug-var)
+  (compiled-debug-var-info debug-var))

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

-  (check-type basic-code-location compiled-code-location)
+  (declare (type compiled-code-location basic-code-location))

   (cond ((debug-var-alive-p debug-var)
   (cond ((debug-var-alive-p debug-var)

-        (let ((debug-fun (code-location-debug-function basic-code-location)))
-          (if (>= (compiled-code-location-pc basic-code-location)
-                  (sb!c::compiled-debug-function-start-pc
-                   (compiled-debug-function-compiler-debug-fun debug-fun)))
-              :valid
-              :invalid)))
-       ((code-location-unknown-p basic-code-location) :unknown)
-       (t
-        (let ((pos (position debug-var
-                             (debug-function-debug-vars
-                              (code-location-debug-function basic-code-location)))))
-          (unless pos
-            (error 'unknown-debug-var
-                   :debug-var debug-var
-                   :debug-function
-                   (code-location-debug-function basic-code-location)))
-          ;; There must be live-set info since basic-code-location is known.
-          (if (zerop (sbit (compiled-code-location-live-set basic-code-location)
-                           pos))
-              :invalid
-              :valid)))))
+         (let ((debug-fun (code-location-debug-fun basic-code-location)))
+           (if (>= (compiled-code-location-pc basic-code-location)
+                   (sb!c::compiled-debug-fun-start-pc
+                    (compiled-debug-fun-compiler-debug-fun debug-fun)))
+               :valid
+               :invalid)))
+        ((code-location-unknown-p basic-code-location) :unknown)
+        (t
+         (let ((pos (position debug-var
+                              (debug-fun-debug-vars
+                               (code-location-debug-fun
+                                basic-code-location)))))
+           (unless pos
+             (error 'unknown-debug-var
+                    :debug-var debug-var
+                    :debug-fun
+                    (code-location-debug-fun basic-code-location)))
+           ;; There must be live-set info since basic-code-location is known.
+           (if (zerop (sbit (compiled-code-location-live-set
+                             basic-code-location)
+                            pos))
+               :invalid
+               :valid)))))

 \f
 ;;;; sources
 
 ;;; This code produces and uses what we call source-paths. A
 ;;; source-path is a list whose first element is a form number as
 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
 \f
 ;;;; sources
 
 ;;; This code produces and uses what we call source-paths. A
 ;;; source-path is a list whose first element is a form number as
 ;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a

-;;; top-level-form number as returned by
-;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to
+;;; 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)))
 ;;; the first, exclusively, are the numbered subforms into which to
 ;;; descend. For example:
 ;;;    (defun foo (x)
 ;;;      (let ((a (aref x 3)))

-;;;    (cons a 3)))
+;;;     (cons a 3)))

 ;;; The call to AREF in this example is form number 5. Assuming this
 ;;; 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
+;;; 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.
 
 ;;; call is as follows:
 ;;;    (5 1 0 1 3 11)
 ;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
 ;;; gets the first binding, and 1 gets the AREF form.
 

-;;; Temporary buffer used to build form-number => source-path translation in
-;;; FORM-NUMBER-TRANSLATIONS.
-(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-
-;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
-(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
-
+;;; This returns a table mapping form numbers to source-paths. A
+;;; source-path indicates a descent into the TOPLEVEL-FORM form,
+;;; going directly to the subform corressponding to the form number.
+;;;

 ;;; The vector elements are in the same format as the compiler's
 ;;; The vector elements are in the same format as the compiler's

-;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
-;;; is the top-level-form number.
+;;; NODE-SOURCE-PATH; that is, the first element is the form number and
+;;; the last is the TOPLEVEL-FORM number.

 (defun form-number-translations (form tlf-number)
 (defun form-number-translations (form tlf-number)

-  #!+sb-doc
-  "This returns a table mapping form numbers to source-paths. A source-path
-   indicates a descent into the top-level-form form, going directly to the
-   subform corressponding to the form number."
-  (clrhash *form-number-circularity-table*)
-  (setf (fill-pointer *form-number-temp*) 0)
-  (sub-translate-form-numbers form (list tlf-number))
-  (coerce *form-number-temp* 'simple-vector))
-(defun sub-translate-form-numbers (form path)
-  (unless (gethash form *form-number-circularity-table*)
-    (setf (gethash form *form-number-circularity-table*) t)
-    (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
-                       *form-number-temp*)
-    (let ((pos 0)
-         (subform form)
-         (trail form))
-      (declare (fixnum pos))
-      (macrolet ((frob ()
-                  '(progn
-                     (when (atom subform) (return))
-                     (let ((fm (car subform)))
-                       (when (consp fm)
-                         (sub-translate-form-numbers fm (cons pos path)))
-                       (incf pos))
-                     (setq subform (cdr subform))
-                     (when (eq subform trail) (return)))))
-       (loop
-         (frob)
-         (frob)
-         (setq trail (cdr trail)))))))
-
+  (let ((seen nil)
+        (translations (make-array 12 :fill-pointer 0 :adjustable t)))
+    (labels ((translate1 (form path)
+               (unless (member form seen)
+                 (push form seen)
+                 (vector-push-extend (cons (fill-pointer translations) path)
+                                     translations)
+                 (let ((pos 0)
+                       (subform form)
+                       (trail form))
+                   (declare (fixnum pos))
+                   (macrolet ((frob ()
+                                '(progn
+                                  (when (atom subform) (return))
+                                  (let ((fm (car subform)))
+                                    (when (consp fm)
+                                      (translate1 fm (cons pos path)))
+                                    (incf pos))
+                                  (setq subform (cdr subform))
+                                  (when (eq subform trail) (return)))))
+                     (loop
+                       (frob)
+                       (frob)
+                       (setq trail (cdr trail))))))))
+      (translate1 form (list tlf-number)))
+    (coerce translations 'simple-vector)))
+
+;;; FORM is a top level form, and path is a source-path into it. This
+;;; returns the form indicated by the source-path. Context is the
+;;; 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)
 (defun source-path-context (form path context)

-  #!+sb-doc
-  "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."

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

@@ -3051,76 +2531,161 @@
     ;; marker, and this gets spliced into the resulting list structure
     ;; on the way back up.
     (labels ((frob (form path level)
     ;; 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))))))))
+               (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))))
       (frob form path context))))

+
+;;; Given a code location, return the associated form-number
+;;; translations and the actual top level form.
+(defun get-toplevel-form (location)
+  (let ((d-source (code-location-debug-source location)))
+    (let* ((offset (code-location-toplevel-form-offset location))
+           (res
+             (cond ((debug-source-form d-source)
+                    (debug-source-form d-source))
+                   ((debug-source-namestring d-source)
+                    (get-file-toplevel-form location))
+                   (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+                               a namestring or a form.")))))
+      (values (form-number-translations res offset) res))))
+
+;;; To suppress the read-time evaluation #. macro during source read,
+;;; *READTABLE* is modified.
+;;;
+;;; FIXME: This breaks #+#.(cl:if ...) Maybe we need a SAFE-READ-EVAL, which
+;;; this code can use for side- effect free #. calls?
+;;;
+;;; FIXME: This also knows nothing of custom readtables. The assumption
+;;; is that the current readtable is a decent approximation for what
+;;; we want, but that's lossy.
+(defun safe-readtable ()
+  (let ((rt (copy-readtable)))
+    (set-dispatch-macro-character
+     #\# #\. (lambda (stream sub-char &rest rest)
+               (declare (ignore rest sub-char))
+               (let ((token (read stream t nil t)))
+                 (format nil "#.~S" token)))
+     rt)
+    rt))
+
+;;; Locate the source file (if it still exists) and grab the top level
+;;; form. If the file is modified, we use the top level form offset
+;;; instead of the recorded character offset.
+(defun get-file-toplevel-form (location)
+  (let* ((d-source (code-location-debug-source location))
+         (tlf-offset (code-location-toplevel-form-offset location))
+         (local-tlf-offset (- tlf-offset
+                              (debug-source-root-number d-source)))
+         (char-offset
+          (aref (or (sb!di:debug-source-start-positions d-source)
+                    (error "no start positions map"))
+                local-tlf-offset))
+         (namestring (debug-source-namestring d-source)))
+    ;; FIXME: External format?
+    (with-open-file (f namestring :if-does-not-exist nil)
+      (unless f
+        (error "The source file no longer exists:~%  ~A" namestring))
+      (format *debug-io* "~%; file: ~A~%" namestring)
+      (let ((*readtable* (safe-readtable)))
+        (cond ((eql (debug-source-created d-source) (file-write-date f))
+               (file-position f char-offset))
+              (t
+               (format *debug-io*
+                       "~%; File has been modified since compilation:~%;   ~A~@
+                          ; Using form offset instead of character position.~%"
+                       namestring)
+               (let ((*read-suppress* t))
+                 (loop repeat local-tlf-offset
+                       do (read f)))))
+        (read f)))))

 \f
 \f

-;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME
+;;;; PREPROCESS-FOR-EVAL

 
 

-;;; Create a SYMBOL-MACROLET for each variable valid at the location which
-;;; accesses that variable from the frame argument.
+;;; 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)
 (defun preprocess-for-eval (form loc)

-  #!+sb-doc
-  "Return a function of one argument that evaluates form in the lexical
-   context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a
-   no-debug-vars condition when the loc's debug-function 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 signals the following conditions: invalid-value,
-   ambiguous-variable-name, and frame-function-mismatch"

   (declare (type code-location loc))
   (let ((n-frame (gensym))
   (declare (type code-location loc))
   (let ((n-frame (gensym))

-       (fun (code-location-debug-function loc)))
+        (fun (code-location-debug-fun loc))
+        (more-context nil)
+        (more-count nil))

     (unless (debug-var-info-available fun)
     (unless (debug-var-info-available fun)

-      (debug-signal 'no-debug-vars :debug-function fun))
+      (debug-signal 'no-debug-vars :debug-fun fun))

     (sb!int:collect ((binds)
     (sb!int:collect ((binds)

-                    (specs))
-      (do-debug-function-variables (var fun)
-       (let ((validity (debug-var-validity var loc)))
-         (unless (eq validity :invalid)
-           (let* ((sym (debug-var-symbol var))
-                  (found (assoc sym (binds))))
-             (if found
-                 (setf (second found) :ambiguous)
-                 (binds (list sym validity var)))))))
+                     (specs))
+      (do-debug-fun-vars (var fun)
+        (let ((validity (debug-var-validity var loc)))
+          (unless (eq validity :invalid)
+            (case (debug-var-info var)
+              (:more-context
+               (setf more-context var))
+              (:more-count
+               (setf more-count var)))
+            (let* ((sym (debug-var-symbol var))
+                   (found (assoc sym (binds))))
+              (if found
+                  (setf (second found) :ambiguous)
+                  (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))
       (dolist (bind (binds))

-       (let ((name (first bind))
-             (var (third bind)))
-         (ecase (second bind)
-           (:valid
-            (specs `(,name (debug-var-value ',var ,n-frame))))
-           (:unknown
-            (specs `(,name (debug-signal 'invalid-value :debug-var ',var
-                                         :frame ,n-frame))))
-           (:ambiguous
-            (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
-                                         :frame ,n-frame)))))))
+        (let ((name (first bind))
+              (var (third bind)))
+          (ecase (second bind)
+            (:valid
+             (specs `(,name (debug-var-value ',var ,n-frame))))
+            (: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)))))))

       (let ((res (coerce `(lambda (,n-frame)
       (let ((res (coerce `(lambda (,n-frame)

-                           (declare (ignorable ,n-frame))
-                           (symbol-macrolet ,(specs) ,form))
-                        'function)))
-       #'(lambda (frame)
-           ;; This prevents these functions from being used in any
-           ;; location other than a function return location, so
-           ;; maybe this should only check whether frame's
-           ;; debug-function is the same as loc's.
-           (unless (code-location= (frame-code-location frame) loc)
-             (debug-signal 'frame-function-mismatch
-                           :code-location loc :form form :frame frame))
-           (funcall res frame))))))
+                            (declare (ignorable ,n-frame))
+                            (symbol-macrolet ,(specs) ,form))
+                         'function)))
+        (lambda (frame)
+          ;; This prevents these functions from being used in any
+          ;; location other than a function return location, so maybe
+          ;; this should only check whether FRAME's DEBUG-FUN is the
+          ;; same as LOC's.
+          (unless (code-location= (frame-code-location frame) loc)
+            (debug-signal 'frame-fun-mismatch
+                          :code-location loc :form form :frame frame))
+          (funcall res frame))))))
+
+;;; EVAL-IN-FRAME

 
 (defun eval-in-frame (frame form)
   (declare (type frame frame))
   #!+sb-doc
 
 (defun eval-in-frame (frame form)
   (declare (type frame frame))
   #!+sb-doc

-  "Evaluate Form in the lexical context of Frame's current code location,
+  "Evaluate FORM in the lexical context of FRAME's current code location,

    returning the results of the evaluation."
   (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
 \f
    returning the results of the evaluation."
   (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
 \f

@@ -3128,197 +2693,199 @@
 
 ;;;; user-visible interface
 
 
 ;;;; user-visible interface
 

-(defun make-breakpoint (hook-function what
-                       &key (kind :code-location) info function-end-cookie)
-  #!+sb-doc
-  "This creates and returns a breakpoint. When program execution encounters
-   the breakpoint, the system calls hook-function. Hook-function 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-function. What is either a code-location or a debug-function. Kind is
-   one of :code-location, :function-start, or :function-end. Since the starts
-   and ends of functions may not have code-locations representing them,
-   designate these places by supplying what as a debug-function and kind
-   indicating the :function-start or :function-end. When what is a
-   debug-function and kind is :function-end, then hook-function must take two
-   additional arguments, a list of values returned by the function and a
-   function-end-cookie.
-      Info is information supplied by and used by the user.
-      Function-end-cookie is a function. To implement :function-end breakpoints,
-   the system uses starter breakpoints to establish the :function-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 :function-end breakpoint hook on the
-   same cookie. The user may save the cookie for comparison in the hook
-   function.
-      This signals an error if what is an unknown code-location."
+;;; 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"
   (etypecase what
     (code-location
      (when (code-location-unknown-p what)
        (error "cannot make a breakpoint at an unknown code location: ~S"

-             what))
-     (assert (eq kind :code-location))
-     (let ((bpt (%make-breakpoint hook-function what kind info)))
+              what))
+     (aver (eq kind :code-location))
+     (let ((bpt (%make-breakpoint hook-fun what kind info)))

        (etypecase what
        (etypecase what

-        (interpreted-code-location
-         (error "Breakpoints in interpreted code are currently unsupported."))
-        (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-function what
-                                              :unknown-return-partner
-                                              info)))
-             (setf (breakpoint-unknown-return-partner bpt) other-bpt)
-             (setf (breakpoint-unknown-return-partner other-bpt) bpt)))))
+         (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))
        bpt))

-    (compiled-debug-function
+    (compiled-debug-fun

      (ecase kind
      (ecase kind

-       (:function-start
-       (%make-breakpoint hook-function what kind info))
-       (:function-end
-       (unless (eq (sb!c::compiled-debug-function-returns
-                    (compiled-debug-function-compiler-debug-fun what))
-                   :standard)
-         (error ":FUNCTION-END breakpoints are currently unsupported ~
-                 for the known return convention."))
-
-       (let* ((bpt (%make-breakpoint hook-function what kind info))
-              (starter (compiled-debug-function-end-starter what)))
-         (unless starter
-           (setf starter (%make-breakpoint #'list what :function-start nil))
-           (setf (breakpoint-hook-function starter)
-                 (function-end-starter-hook starter what))
-           (setf (compiled-debug-function-end-starter what) starter))
-         (setf (breakpoint-start-helper bpt) starter)
-         (push bpt (breakpoint-%info starter))
-         (setf (breakpoint-cookie-fun bpt) function-end-cookie)
-         bpt))))
-    (interpreted-debug-function
-     (error ":function-end breakpoints are currently unsupported ~
-            for interpreted-debug-functions."))))
+       (:fun-start
+        (%make-breakpoint hook-fun what kind info))
+       (:fun-end
+        (unless (eq (sb!c::compiled-debug-fun-returns
+                     (compiled-debug-fun-compiler-debug-fun what))
+                    :standard)
+          (error ":FUN-END breakpoints are currently unsupported ~
+                  for the known return convention."))
+
+        (let* ((bpt (%make-breakpoint hook-fun what kind info))
+               (starter (compiled-debug-fun-end-starter what)))
+          (unless starter
+            (setf starter (%make-breakpoint #'list what :fun-start nil))
+            (setf (breakpoint-hook-fun starter)
+                  (fun-end-starter-hook starter what))
+            (setf (compiled-debug-fun-end-starter what) starter))
+          (setf (breakpoint-start-helper bpt) starter)
+          (push bpt (breakpoint-%info starter))
+          (setf (breakpoint-cookie-fun bpt) fun-end-cookie)
+          bpt))))))

 
 ;;; These are unique objects created upon entry into a function by a
 
 ;;; These are unique objects created upon entry into a function by a

-;;; :FUNCTION-END breakpoint's starter hook. These are only created
-;;; when users supply :FUNCTION-END-COOKIE to MAKE-BREAKPOINT. Also,
-;;; the :FUNCTION-END breakpoint's hook is called on the same cookie
+;;; :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.
 ;;; when it is created.

-(defstruct (function-end-cookie
-           (:print-object (lambda (obj str)
-                            (print-unreadable-object (obj str :type t))))
-           (:constructor make-function-end-cookie (bogus-lra debug-fun)))
-  ;; This is a pointer to the bogus-lra created for :function-end bpts.
+(defstruct (fun-end-cookie
+            (:print-object (lambda (obj str)
+                             (print-unreadable-object (obj str :type t))))
+            (:constructor make-fun-end-cookie (bogus-lra debug-fun))
+            (:copier nil))
+  ;; a pointer to the bogus-lra created for :FUN-END breakpoints

   bogus-lra
   bogus-lra

-  ;; This is the debug-function associated with the cookie.
+  ;; the DEBUG-FUN associated with this cookie

   debug-fun)
 
   debug-fun)
 

-;;; This maps bogus-lra-components to cookies, so
-;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
+;;; This maps bogus-lra-components to cookies, so that
+;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the

 ;;; breakpoint hook.
 ;;; breakpoint hook.

-(defvar *function-end-cookies* (make-hash-table :test 'eq))
+(defvar *fun-end-cookies* (make-hash-table :test 'eq :synchronized t))

 
 ;;; This returns a hook function for the start helper breakpoint
 
 ;;; This returns a hook function for the start helper breakpoint

-;;; associated with a :FUNCTION-END breakpoint. The returned function
+;;; 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.
 ;;; 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 function-end-starter-hook (starter-bpt debug-fun)
+(defun fun-end-starter-hook (starter-bpt debug-fun)

   (declare (type breakpoint starter-bpt)
   (declare (type breakpoint starter-bpt)

-          (type compiled-debug-function debug-fun))
-  #'(lambda (frame breakpoint)
-      (declare (ignore breakpoint)
-              (type frame frame))
-      (let ((lra-sc-offset
-            (sb!c::compiled-debug-function-return-pc
-             (compiled-debug-function-compiler-debug-fun debug-fun))))
-       (multiple-value-bind (lra component offset)
-           (make-bogus-lra
-            (get-context-value frame
-                               #!-gengc sb!vm::lra-save-offset
-                               #!+gengc sb!vm::ra-save-offset
-                               lra-sc-offset))
-         (setf (get-context-value frame
-                                  #!-gengc sb!vm::lra-save-offset
-                                  #!+gengc sb!vm::ra-save-offset
-                                  lra-sc-offset)
-               lra)
-         (let ((end-bpts (breakpoint-%info starter-bpt)))
-           (let ((data (breakpoint-data component offset)))
-             (setf (breakpoint-data-breakpoints data) end-bpts)
-             (dolist (bpt end-bpts)
-               (setf (breakpoint-internal-data bpt) data)))
-           (let ((cookie (make-function-end-cookie lra debug-fun)))
-             (setf (gethash component *function-end-cookies*) cookie)
-             (dolist (bpt end-bpts)
-               (let ((fun (breakpoint-cookie-fun bpt)))
-                 (when fun (funcall fun frame cookie))))))))))
-
-(defun function-end-cookie-valid-p (frame cookie)
-  #!+sb-doc
-  "This takes a function-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 :function-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."
-  (let ((lra (function-end-cookie-bogus-lra cookie))
-       (lra-sc-offset (sb!c::compiled-debug-function-return-pc
-                       (compiled-debug-function-compiler-debug-fun
-                        (function-end-cookie-debug-fun cookie)))))
+           (type compiled-debug-fun debug-fun))
+  (lambda (frame breakpoint)
+    (declare (ignore breakpoint)
+             (type frame frame))
+    (let ((lra-sc-offset
+           (sb!c::compiled-debug-fun-return-pc
+            (compiled-debug-fun-compiler-debug-fun debug-fun))))
+      (multiple-value-bind (lra component offset)
+          (make-bogus-lra
+           (get-context-value frame
+                              lra-save-offset
+                              lra-sc-offset))
+        (setf (get-context-value frame
+                                 lra-save-offset
+                                 lra-sc-offset)
+              lra)
+        (let ((end-bpts (breakpoint-%info starter-bpt)))
+          (let ((data (breakpoint-data component offset)))
+            (setf (breakpoint-data-breakpoints data) end-bpts)
+            (dolist (bpt end-bpts)
+              (setf (breakpoint-internal-data bpt) data)))
+          (let ((cookie (make-fun-end-cookie lra debug-fun)))
+            (setf (gethash component *fun-end-cookies*) cookie)
+            (dolist (bpt end-bpts)
+              (let ((fun (breakpoint-cookie-fun bpt)))
+                (when fun (funcall fun frame cookie))))))))))
+
+;;; This takes a FUN-END-COOKIE and a frame, and it returns
+;;; whether the cookie is still valid. A cookie becomes invalid when
+;;; the frame that established the cookie has exited. Sometimes cookie
+;;; holders are unaware of cookie invalidation because their
+;;; :FUN-END breakpoint hooks didn't run due to THROW'ing.
+;;;
+;;; This takes a frame as an efficiency hack since the user probably
+;;; has a frame object in hand when using this routine, and it saves
+;;; repeated parsing of the stack and consing when asking whether a
+;;; series of cookies is valid.
+(defun fun-end-cookie-valid-p (frame cookie)
+  (let ((lra (fun-end-cookie-bogus-lra cookie))
+        (lra-sc-offset (sb!c::compiled-debug-fun-return-pc
+                        (compiled-debug-fun-compiler-debug-fun
+                         (fun-end-cookie-debug-fun cookie)))))

     (do ((frame frame (frame-down frame)))
     (do ((frame frame (frame-down frame)))

-       ((not frame) nil)
+        ((not frame) nil)

       (when (and (compiled-frame-p frame)
       (when (and (compiled-frame-p frame)

-                (eq lra
-                    (get-context-value frame
-                                       #!-gengc sb!vm::lra-save-offset
-                                       #!+gengc sb!vm::ra-save-offset
-                                       lra-sc-offset)))
-       (return t)))))
-
+                 (#!-(or x86 x86-64) eq #!+(or x86 x86-64) sap=
+                  lra
+                  (get-context-value frame lra-save-offset lra-sc-offset)))
+        (return t)))))
+\f

 ;;;; ACTIVATE-BREAKPOINT
 
 ;;;; 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)
 (defun activate-breakpoint (breakpoint)

-  #!+sb-doc
-  "This causes 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."

   (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)))
   (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
-          (interpreted-code-location
-           (error "Breakpoints in interpreted code are currently unsupported."))
-          (compiled-code-location
-           (activate-compiled-code-location-breakpoint breakpoint)
-           (let ((other (breakpoint-unknown-return-partner breakpoint)))
-             (when other
-               (activate-compiled-code-location-breakpoint other)))))))
-      (:function-start
+         (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)
        (etypecase (breakpoint-what breakpoint)

-        (compiled-debug-function
-         (activate-compiled-function-start-breakpoint breakpoint))
-        (interpreted-debug-function
-         (error "I don't know how you made this, but they're unsupported: ~S"
-                (breakpoint-what breakpoint)))))
-      (:function-end
+         (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)
        (etypecase (breakpoint-what breakpoint)

-        (compiled-debug-function
-         (let ((starter (breakpoint-start-helper breakpoint)))
-           (unless (eq (breakpoint-status starter) :active)
-             ;; May already be active by some other :function-end breakpoint.
-             (activate-compiled-function-start-breakpoint starter)))
-         (setf (breakpoint-status breakpoint) :active))
-        (interpreted-debug-function
-         (error "I don't know how you made this, but they're unsupported: ~S"
-                (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)
   breakpoint)
 
 (defun activate-compiled-code-location-breakpoint (breakpoint)

@@ -3327,220 +2894,216 @@
     (declare (type compiled-code-location loc))
     (sub-activate-breakpoint
      breakpoint
     (declare (type compiled-code-location loc))
     (sub-activate-breakpoint
      breakpoint

-     (breakpoint-data (compiled-debug-function-component
-                      (code-location-debug-function loc))
-                     (+ (compiled-code-location-pc loc)
-                        (if (or (eq (breakpoint-kind breakpoint)
-                                    :unknown-return-partner)
-                                (eq (compiled-code-location-kind loc)
-                                    :single-value-return))
-                            sb!vm:single-value-return-byte-offset
-                            0))))))
-
-(defun activate-compiled-function-start-breakpoint (breakpoint)
+     (breakpoint-data (compiled-debug-fun-component
+                       (code-location-debug-fun loc))
+                      (+ (compiled-code-location-pc loc)
+                         (if (or (eq (breakpoint-kind breakpoint)
+                                     :unknown-return-partner)
+                                 (eq (compiled-code-location-kind loc)
+                                     :single-value-return))
+                             sb!vm:single-value-return-byte-offset
+                             0))))))
+
+(defun activate-compiled-fun-start-breakpoint (breakpoint)

   (declare (type breakpoint breakpoint))
   (let ((debug-fun (breakpoint-what breakpoint)))
     (sub-activate-breakpoint
      breakpoint
   (declare (type breakpoint breakpoint))
   (let ((debug-fun (breakpoint-what breakpoint)))
     (sub-activate-breakpoint
      breakpoint

-     (breakpoint-data (compiled-debug-function-component debug-fun)
-                     (sb!c::compiled-debug-function-start-pc
-                      (compiled-debug-function-compiler-debug-fun
-                       debug-fun))))))
+     (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)
 
 (defun sub-activate-breakpoint (breakpoint data)
   (declare (type breakpoint breakpoint)

-          (type breakpoint-data data))
+           (type breakpoint-data data))

   (setf (breakpoint-status breakpoint) :active)
   (without-interrupts
    (unless (breakpoint-data-breakpoints data)
      (setf (breakpoint-data-instruction data)
   (setf (breakpoint-status breakpoint) :active)
   (without-interrupts
    (unless (breakpoint-data-breakpoints data)
      (setf (breakpoint-data-instruction data)

-          (without-gcing
-           (breakpoint-install (get-lisp-obj-address
-                                (breakpoint-data-component data))
-                               (breakpoint-data-offset data)))))
+           (without-gcing
+            (breakpoint-install (get-lisp-obj-address
+                                 (breakpoint-data-component data))
+                                (breakpoint-data-offset data)))))

    (setf (breakpoint-data-breakpoints data)
    (setf (breakpoint-data-breakpoints data)

-        (append (breakpoint-data-breakpoints data) (list breakpoint)))
+         (append (breakpoint-data-breakpoints data) (list breakpoint)))

    (setf (breakpoint-internal-data breakpoint) data)))
    (setf (breakpoint-internal-data breakpoint) data)))

-
+\f

 ;;;; DEACTIVATE-BREAKPOINT
 
 ;;;; DEACTIVATE-BREAKPOINT
 

+;;; Stop the system from invoking the breakpoint's hook function.

 (defun deactivate-breakpoint (breakpoint)
 (defun deactivate-breakpoint (breakpoint)

-  #!+sb-doc
-  "This stops the system from invoking the breakpoint's hook-function."

   (when (eq (breakpoint-status breakpoint) :active)
     (without-interrupts
      (let ((loc (breakpoint-what breakpoint)))
        (etypecase loc
   (when (eq (breakpoint-status breakpoint) :active)
     (without-interrupts
      (let ((loc (breakpoint-what breakpoint)))
        (etypecase loc

-        ((or interpreted-code-location interpreted-debug-function)
-         (error
-          "Breakpoints in interpreted code are currently unsupported."))
-        ((or compiled-code-location compiled-debug-function)
-         (deactivate-compiled-breakpoint breakpoint)
-         (let ((other (breakpoint-unknown-return-partner breakpoint)))
-           (when other
-             (deactivate-compiled-breakpoint other))))))))
+         ((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)
   breakpoint)
 
 (defun deactivate-compiled-breakpoint (breakpoint)

-  (if (eq (breakpoint-kind breakpoint) :function-end)
+  (if (eq (breakpoint-kind breakpoint) :fun-end)

       (let ((starter (breakpoint-start-helper breakpoint)))
       (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)))
+        (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))
       (let* ((data (breakpoint-internal-data breakpoint))

-            (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
-       (setf (breakpoint-internal-data breakpoint) nil)
-       (setf (breakpoint-data-breakpoints data) bpts)
-       (unless bpts
-         (without-gcing
-          (breakpoint-remove (get-lisp-obj-address
-                              (breakpoint-data-component data))
-                             (breakpoint-data-offset data)
-                             (breakpoint-data-instruction data)))
-         (delete-breakpoint-data data))))
+             (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
+        (setf (breakpoint-internal-data breakpoint) nil)
+        (setf (breakpoint-data-breakpoints data) bpts)
+        (unless bpts
+          (without-gcing
+           (breakpoint-remove (get-lisp-obj-address
+                               (breakpoint-data-component data))
+                              (breakpoint-data-offset data)
+                              (breakpoint-data-instruction data)))
+          (delete-breakpoint-data data))))

   (setf (breakpoint-status breakpoint) :inactive)
   breakpoint)
   (setf (breakpoint-status breakpoint) :inactive)
   breakpoint)

-
+\f

 ;;;; BREAKPOINT-INFO
 
 ;;;; BREAKPOINT-INFO
 

+;;; Return the user-maintained info associated with breakpoint. This
+;;; is SETF'able.

 (defun breakpoint-info (breakpoint)
 (defun breakpoint-info (breakpoint)

-  #!+sb-doc
-  "This returns the user-maintained info associated with breakpoint. This
-   is SETF'able."

   (breakpoint-%info breakpoint))
 (defun %set-breakpoint-info (breakpoint value)
   (setf (breakpoint-%info breakpoint) value)
   (let ((other (breakpoint-unknown-return-partner breakpoint)))
     (when other
       (setf (breakpoint-%info other) value))))
   (breakpoint-%info breakpoint))
 (defun %set-breakpoint-info (breakpoint value)
   (setf (breakpoint-%info breakpoint) value)
   (let ((other (breakpoint-unknown-return-partner breakpoint)))
     (when other
       (setf (breakpoint-%info other) value))))

-
+\f

 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
 
 (defun breakpoint-active-p (breakpoint)
 ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
 
 (defun breakpoint-active-p (breakpoint)

-  #!+sb-doc
-  "This returns whether breakpoint is currently active."

   (ecase (breakpoint-status breakpoint)
     (:active t)
     ((:inactive :deleted) nil)))
 
   (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)
 (defun delete-breakpoint (breakpoint)

-  #!+sb-doc
-  "This frees system storage and removes computational overhead associated with
-   breakpoint. After calling this, breakpoint is completely impotent and can
-   never become active again."

   (let ((status (breakpoint-status breakpoint)))
     (unless (eq status :deleted)
       (when (eq status :active)
   (let ((status (breakpoint-status breakpoint)))
     (unless (eq status :deleted)
       (when (eq status :active)

-       (deactivate-breakpoint breakpoint))
+        (deactivate-breakpoint breakpoint))

       (setf (breakpoint-status breakpoint) :deleted)
       (let ((other (breakpoint-unknown-return-partner 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) :function-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-function-end-starter
-                  (breakpoint-what breakpoint))
-                 nil))))))
+        (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)
   breakpoint)

-
+\f

 ;;;; C call out stubs
 
 ;;; This actually installs the break instruction in the component. It
 ;;; returns the overwritten bits. You must call this in a context in
 ;;; which GC is disabled, so that Lisp doesn't move objects around
 ;;; that C is pointing to.
 ;;;; 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:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
-  (code-obj sb!c-call:unsigned-long)
-  (pc-offset sb!c-call:int))
+(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.
 
 ;;; 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:def-alien-routine "breakpoint_remove" sb!c-call:void
-  (code-obj sb!c-call:unsigned-long)
-  (pc-offset sb!c-call:int)
-  (old-inst sb!c-call:unsigned-long))
+(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:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
+(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void

   (scp (* os-context-t))
   (scp (* os-context-t))

-  (orig-inst sb!c-call:unsigned-long))
+  (orig-inst sb!alien:unsigned-int))

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

-;;; This maps components to a mapping of offsets to breakpoint-datas.
-(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
+;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs.
+(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq :synchronized t))

 
 

-;;; This returns the breakpoint-data associated with component cross
+;;; This returns the BREAKPOINT-DATA object associated with component cross

 ;;; offset. If none exists, this makes one, installs it, and returns it.
 (defun breakpoint-data (component offset &optional (create t))
   (flet ((install-breakpoint-data ()
 ;;; offset. If none exists, this makes one, installs it, and returns it.
 (defun breakpoint-data (component offset &optional (create t))
   (flet ((install-breakpoint-data ()

-          (when create
-            (let ((data (make-breakpoint-data component offset)))
-              (push (cons offset data)
-                    (gethash component *component-breakpoint-offsets*))
-              data))))
+           (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 ((offsets (gethash component *component-breakpoint-offsets*)))
       (if offsets

-         (let ((data (assoc offset offsets)))
-           (if data
-               (cdr data)
-               (install-breakpoint-data)))
-         (install-breakpoint-data)))))
+          (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
 
 ;;; We use this when there are no longer any active breakpoints

-;;; corresponding to data.
+;;; corresponding to DATA.

 (defun delete-breakpoint-data (data)
 (defun delete-breakpoint-data (data)

+  ;; Again, this looks brittle. Is there no danger of being interrupted
+  ;; here?

   (let* ((component (breakpoint-data-component data))
   (let* ((component (breakpoint-data-component data))

-        (offsets (delete (breakpoint-data-offset data)
-                         (gethash component *component-breakpoint-offsets*)
-                         :key #'car)))
+         (offsets (delete (breakpoint-data-offset data)
+                          (gethash component *component-breakpoint-offsets*)
+                          :key #'car)))

     (if offsets
     (if offsets

-       (setf (gethash component *component-breakpoint-offsets*) offsets)
-       (remhash component *component-breakpoint-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
   (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.
+;;; 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)
 (defun handle-breakpoint (offset component signal-context)

-  (/show0 "entering HANDLE-BREAKPOINT")

   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"

-             (debug-function-name (debug-function-from-pc component offset))
-             offset))
+              (debug-fun-name (debug-fun-from-pc component offset))
+              offset))

     (let ((breakpoints (breakpoint-data-breakpoints data)))
       (if (or (null breakpoints)
     (let ((breakpoints (breakpoint-data-breakpoints data)))
       (if (or (null breakpoints)

-             (eq (breakpoint-kind (car breakpoints)) :function-end))
-         (handle-function-end-breakpoint-aux breakpoints data signal-context)
-         (handle-breakpoint-aux breakpoints data
-                                offset component signal-context)))))
+              (eq (breakpoint-kind (car breakpoints)) :fun-end))
+          (handle-fun-end-breakpoint-aux breakpoints data signal-context)
+          (handle-breakpoint-aux breakpoints data
+                                 offset component signal-context)))))

 
 ;;; 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
 
 ;;; 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. Function-end breakpoints
+;;; 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)
 
 ;;; must work differently since the breakpoint-data is unique for each
 ;;; invocation.
 (defvar *executing-breakpoint-hooks* nil)
 

-;;; This handles code-location and debug-function :FUNCTION-START
+;;; This handles code-location and DEBUG-FUN :FUN-START

 ;;; breakpoints.
 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)
 ;;; breakpoints.
 (defun handle-breakpoint-aux (breakpoints data offset component signal-context)

-  (/show0 "entering HANDLE-BREAKPOINT-AUX")

   (unless breakpoints
   (unless breakpoints

-    (error "internal error: breakpoint that nobody wants"))
+    (bug "breakpoint that nobody wants"))

   (unless (member data *executing-breakpoint-hooks*)
     (let ((*executing-breakpoint-hooks* (cons data
   (unless (member data *executing-breakpoint-hooks*)
     (let ((*executing-breakpoint-hooks* (cons data

-                                             *executing-breakpoint-hooks*)))
-      (invoke-breakpoint-hooks breakpoints component offset)))
+                                              *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
   ;; 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

@@ -3549,179 +3112,298 @@
   ;; no more breakpoints active at this location, then the normal
   ;; instruction has been put back, and we do not need to
   ;; DO-DISPLACED-INST.
   ;; no more breakpoints active at this location, then the normal
   ;; instruction has been put back, and we do not need to
   ;; DO-DISPLACED-INST.

-  (let ((data (breakpoint-data component offset nil)))
-    (when (and data (breakpoint-data-breakpoints data))
-      ;; The breakpoint is still active, so we need to execute the
-      ;; displaced instruction and leave the breakpoint instruction
-      ;; behind. The best way to do this is different on each machine,
-      ;; so we just leave it up to the C code.
-      (breakpoint-do-displaced-inst signal-context
-                                   (breakpoint-data-instruction data))
-      ; Under HPUX we can't sigreturn so bp-do-disp-i has to return.
-      #!-(or hpux irix x86)
-      (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
-
-(defun invoke-breakpoint-hooks (breakpoints component offset)
-  (let* ((debug-fun (debug-function-from-pc component offset))
-        (frame (do ((f (top-frame) (frame-down f)))
-                   ((eq debug-fun (frame-debug-function f)) f))))
+  (setf data (breakpoint-data component offset nil))
+  (when (and data (breakpoint-data-breakpoints data))
+    ;; The breakpoint is still active, so we need to execute the
+    ;; displaced instruction and leave the breakpoint instruction
+    ;; behind. The best way to do this is different on each machine,
+    ;; so we just leave it up to the C code.
+    (breakpoint-do-displaced-inst signal-context
+                                  (breakpoint-data-instruction data))
+    ;; Some platforms have no usable sigreturn() call.  If your
+    ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
+    ;; it's polite to warn here
+    #!+(and sparc solaris)
+    (error "BREAKPOINT-DO-DISPLACED-INST returned?")))
+
+(defun invoke-breakpoint-hooks (breakpoints signal-context)
+  (let* ((frame (signal-context-frame signal-context)))

     (dolist (bpt breakpoints)
     (dolist (bpt breakpoints)

-      (funcall (breakpoint-hook-function bpt)
-              frame
-              ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
-              ;; hook function the original breakpoint, so that users
-              ;; aren't forced to confront the fact that some
-              ;; breakpoints really are two.
-              (if (eq (breakpoint-kind bpt) :unknown-return-partner)
-                  (breakpoint-unknown-return-partner bpt)
-                  bpt)))))
-
-(defun handle-function-end-breakpoint (offset component context)
-  (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT")
+      (funcall (breakpoint-hook-fun bpt)
+               frame
+               ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
+               ;; hook function the original breakpoint, so that users
+               ;; aren't forced to confront the fact that some
+               ;; breakpoints really are two.
+               (if (eq (breakpoint-kind bpt) :unknown-return-partner)
+                   (breakpoint-unknown-return-partner bpt)
+                   bpt)))))
+
+(defun signal-context-frame (signal-context)
+  (let* ((scp
+          (locally
+            (declare (optimize (inhibit-warnings 3)))
+            (sb!alien:sap-alien signal-context (* os-context-t))))
+         (cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset))))
+    (compute-calling-frame cfp
+                           ;; KLUDGE: This argument is ignored on
+                           ;; x86oids in this scenario, but is
+                           ;; declared to be a SAP.
+                           #!+(or x86 x86-64) (sb!vm:context-pc scp)
+                           #!-(or x86 x86-64) nil
+                           nil)))
+
+(defun handle-fun-end-breakpoint (offset component context)

   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"
   (let ((data (breakpoint-data component offset nil)))
     (unless data
       (error "unknown breakpoint in ~S at offset ~S"

-             (debug-function-name (debug-function-from-pc component offset))
-             offset))
+              (debug-fun-name (debug-fun-from-pc component offset))
+              offset))

     (let ((breakpoints (breakpoint-data-breakpoints data)))
       (when breakpoints
     (let ((breakpoints (breakpoint-data-breakpoints data)))
       (when breakpoints

-       (assert (eq (breakpoint-kind (car breakpoints)) :function-end))
-       (handle-function-end-breakpoint-aux breakpoints data context)))))
+        (aver (eq (breakpoint-kind (car breakpoints)) :fun-end))
+        (handle-fun-end-breakpoint-aux breakpoints data context)))))

 
 

-;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints
-;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly
+;;; Either HANDLE-BREAKPOINT calls this for :FUN-END breakpoints
+;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly

 ;;; [new C code].
 ;;; [new C code].

-(defun handle-function-end-breakpoint-aux (breakpoints data signal-context)
-  (/show0 "entering HANDLE-FUNCTION-END-BREAKPOINT-AUX")
+(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
   (delete-breakpoint-data data)
   (let* ((scp

-         (locally
-           (declare (optimize (inhibit-warnings 3)))
-           (sb!alien:sap-alien signal-context (* os-context-t))))
-        (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
-                    (f (top-frame) (frame-down f)))
-                   ((= cfp (sap-int (frame-pointer f))) f)
-                 (declare (type (unsigned-byte #.sb!vm:word-bits) cfp))))
-        (component (breakpoint-data-component data))
-        (cookie (gethash component *function-end-cookies*)))
-    (remhash component *function-end-cookies*)
+          (locally
+            (declare (optimize (inhibit-warnings 3)))
+            (sb!alien:sap-alien signal-context (* os-context-t))))
+         (frame (signal-context-frame signal-context))
+         (component (breakpoint-data-component data))
+         (cookie (gethash component *fun-end-cookies*)))
+    (remhash component *fun-end-cookies*)

     (dolist (bpt breakpoints)
     (dolist (bpt breakpoints)

-      (funcall (breakpoint-hook-function bpt)
-              frame bpt
-              (get-function-end-breakpoint-values scp)
-              cookie))))
+      (funcall (breakpoint-hook-fun bpt)
+               frame bpt
+               (get-fun-end-breakpoint-values scp)
+               cookie))))

 
 

-(defun get-function-end-breakpoint-values (scp)
+(defun get-fun-end-breakpoint-values (scp)

   (let ((ocfp (int-sap (sb!vm:context-register
   (let ((ocfp (int-sap (sb!vm:context-register

-                       scp
-                       #!-x86 sb!vm::ocfp-offset
-                       #!+x86 sb!vm::ebx-offset)))
-       (nargs (make-lisp-obj
-               (sb!vm:context-register scp sb!vm::nargs-offset)))
-       (reg-arg-offsets '#.sb!vm::register-arg-offsets)
-       (results nil))
+                        scp
+                        #!-(or x86 x86-64) sb!vm::ocfp-offset
+                        #!+(or x86 x86-64) sb!vm::ebx-offset)))
+        (nargs (make-lisp-obj
+                (sb!vm:context-register scp sb!vm::nargs-offset)))
+        (reg-arg-offsets '#.sb!vm::*register-arg-offsets*)
+        (results nil))

     (without-gcing
      (dotimes (arg-num nargs)
        (push (if reg-arg-offsets
     (without-gcing
      (dotimes (arg-num nargs)
        (push (if reg-arg-offsets

-                (make-lisp-obj
-                 (sb!vm:context-register scp (pop reg-arg-offsets)))
-              (stack-ref ocfp arg-num))
-            results)))
+                 (make-lisp-obj
+                  (sb!vm:context-register scp (pop reg-arg-offsets)))
+               (stack-ref ocfp arg-num))
+             results)))

     (nreverse results)))
     (nreverse results)))

-
-;;;; MAKE-BOGUS-LRA (used for :FUNCTION-END breakpoints)
-
-(defconstant
-  bogus-lra-constants
-  #!-x86 2 #!+x86 3)
-(defconstant
-  known-return-p-slot
-  (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
-
-;;; FIXME: This is also defined in debug-vm.lisp. Which definition
-;;; takes precedence? (One definition uses ALLOCATE-CODE-OBJECT, and
-;;; the other has been hacked for X86 GENCGC to use
-;;; ALLOCATE-DYNAMIC-CODE-OBJECT..)
+\f
+;;;; MAKE-BOGUS-LRA (used for :FUN-END breakpoints)
+
+(defconstant bogus-lra-constants
+  #!-(or x86 x86-64) 2 #!+(or x86 x86-64) 3)
+(defconstant known-return-p-slot
+  (+ sb!vm:code-constants-offset #!-(or x86 x86-64) 1 #!+(or x86 x86-64) 2))
+
+;;; Make a bogus LRA object that signals a breakpoint trap when
+;;; returned to. If the breakpoint trap handler returns, REAL-LRA is
+;;; returned to. Three values are returned: the bogus LRA object, the
+;;; code component it is part of, and the PC offset for the trap
+;;; instruction.

 (defun make-bogus-lra (real-lra &optional known-return-p)
 (defun make-bogus-lra (real-lra &optional known-return-p)

-  #!+sb-doc
-  "Make a bogus LRA object that signals a breakpoint trap when returned to. If
-   the breakpoint trap handler returns, REAL-LRA is returned to. Three values
-   are returned: the bogus LRA object, the code component it is part of, and
-   the PC offset for the trap instruction."

   (without-gcing
   (without-gcing

-   (let* ((src-start (foreign-symbol-address "function_end_breakpoint_guts"))
-         (src-end (foreign-symbol-address "function_end_breakpoint_end"))
-         (trap-loc (foreign-symbol-address "function_end_breakpoint_trap"))
-         (length (sap- src-end src-start))
-         (code-object
-          (%primitive
-           #!-(and x86 gencgc) sb!c:allocate-code-object
-           #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object
-           (1+ bogus-lra-constants)
-           length))
-         (dst-start (code-instructions code-object)))
+   ;; These are really code labels, not variables: but this way we get
+   ;; their addresses.
+   (let* ((src-start (true-foreign-symbol-sap "fun_end_breakpoint_guts"))
+          (src-end (true-foreign-symbol-sap "fun_end_breakpoint_end"))
+          (trap-loc (true-foreign-symbol-sap "fun_end_breakpoint_trap"))
+          (length (sap- src-end src-start))
+          (code-object
+           (sb!c:allocate-code-object (1+ bogus-lra-constants) length))
+          (dst-start (code-instructions code-object)))

      (declare (type system-area-pointer
      (declare (type system-area-pointer

-                   src-start src-end dst-start trap-loc)
-             (type index length))
+                    src-start src-end dst-start trap-loc)
+              (type index length))

      (setf (%code-debug-info code-object) :bogus-lra)
      (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
      (setf (%code-debug-info code-object) :bogus-lra)
      (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)

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

      (setf (code-header-ref code-object real-lra-slot) real-lra)
      (setf (code-header-ref code-object real-lra-slot) real-lra)

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

      (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
        (setf (code-header-ref code-object real-lra-slot) code)
        (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
      (setf (code-header-ref code-object known-return-p-slot)
      (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
        (setf (code-header-ref code-object real-lra-slot) code)
        (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
      (setf (code-header-ref code-object known-return-p-slot)

-          known-return-p)
-     (system-area-copy src-start 0 dst-start 0 (* length sb!vm:byte-bits))
+           known-return-p)
+     (system-area-ub8-copy src-start 0 dst-start 0 length)

      (sb!vm:sanctify-for-execution code-object)
      (sb!vm:sanctify-for-execution code-object)

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

      (values dst-start code-object (sap- trap-loc src-start))
      (values dst-start code-object (sap- trap-loc src-start))

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

      (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
      (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)

-                                     sb!vm:other-pointer-type))))
-       (set-header-data
-       new-lra
-       (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
-                 1))
-       (sb!vm:sanctify-for-execution code-object)
+                                      sb!vm:other-pointer-lowtag))))
+       ;; We used to set the header value of the LRA here to the
+       ;; offset from the enclosing component to the LRA header, but
+       ;; MAKE-LISP-OBJ actually checks the value before we get a
+       ;; chance to set it, so it's now done in arch-assem.S.

        (values new-lra code-object (sap- trap-loc src-start))))))
 \f
 ;;;; miscellaneous
 
        (values new-lra code-object (sap- trap-loc src-start))))))
 \f
 ;;;; miscellaneous
 

-;;; This appears here because it cannot go with the debug-function
+;;; This appears here because it cannot go with the DEBUG-FUN

 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
 ;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after

-;;; the debug-function routines.
+;;; the DEBUG-FUN routines.

 
 

-(defun debug-function-start-location (debug-fun)
-  #!+sb-doc
-  "This returns a code-location before the body of a function and after all
-   the arguments are in place. If this cannot determine that location due to
-   a lack of debug information, it returns nil."
+;;; 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
   (etypecase debug-fun

-    (compiled-debug-function
+    (compiled-debug-fun

      (code-location-from-pc debug-fun
      (code-location-from-pc debug-fun

-                           (sb!c::compiled-debug-function-start-pc
-                            (compiled-debug-function-compiler-debug-fun
-                             debug-fun))
-                           nil))
-    (interpreted-debug-function
-     ;; Return the first location if there are any, otherwise NIL.
-     (handler-case (do-debug-function-blocks (block debug-fun nil)
-                    (do-debug-block-locations (loc block nil)
-                      (return-from debug-function-start-location loc)))
-       (no-debug-blocks (condx)
-        (declare (ignore condx))
-        nil)))))
-
-(defun print-code-locations (function)
-  (let ((debug-fun (function-debug-function function)))
-    (do-debug-function-blocks (block debug-fun)
-      (do-debug-block-locations (loc block)
-       (fill-in-code-location loc)
-       (format t "~S code location at ~D"
-               (compiled-code-location-kind loc)
-               (compiled-code-location-pc loc))
-       (sb!debug::print-code-location-source-form loc 0)
-       (terpri)))))
+                            (sb!c::compiled-debug-fun-start-pc
+                             (compiled-debug-fun-compiler-debug-fun
+                              debug-fun))
+                            nil))
+    ;; (There used to be more cases back before sbcl-0.7.0, when
+    ;; we did special tricks to debug the IR1 interpreter.)
+    ))
+
+\f
+;;;; Single-stepping
+
+;;; The single-stepper works by inserting conditional trap instructions
+;;; into the generated code (see src/compiler/*/call.lisp), currently:
+;;;
+;;;   1) Before the code generated for a function call that was
+;;;      translated to a VOP
+;;;   2) Just before the call instruction for a full call
+;;;
+;;; In both cases, the trap will only be executed if stepping has been
+;;; enabled, in which case it'll ultimately be handled by
+;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition,
+;;; or replace the function that's about to be called with a wrapper
+;;; which will signal the condition.
+
+(defun handle-single-step-trap (kind callee-register-offset)
+  (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*))))
+    ;; The following calls must get tail-call eliminated for
+    ;; *STEP-FRAME* to get set correctly on non-x86.
+    (if (= kind single-step-before-trap)
+        (handle-single-step-before-trap context)
+        (handle-single-step-around-trap context callee-register-offset))))
+
+(defvar *step-frame* nil)
+
+(defun handle-single-step-before-trap (context)
+  (let ((step-info (single-step-info-from-context context)))
+    ;; If there was not enough debug information available, there's no
+    ;; sense in signaling the condition.
+    (when step-info
+      (let ((*step-frame*
+             #!+(or x86 x86-64)
+             (signal-context-frame (sb!alien::alien-sap context))
+             #!-(or x86 x86-64)
+             ;; KLUDGE: Use the first non-foreign frame as the
+             ;; *STACK-TOP-HINT*. Getting the frame from the signal
+             ;; context as on x86 would be cleaner, but
+             ;; SIGNAL-CONTEXT-FRAME doesn't seem seem to work at all
+             ;; on non-x86.
+             (loop with frame = (frame-down (top-frame))
+                   while frame
+                   for dfun = (frame-debug-fun frame)
+                   do (when (typep dfun 'compiled-debug-fun)
+                        (return frame))
+                   do (setf frame (frame-down frame)))))
+        (sb!impl::step-form step-info
+                            ;; We could theoretically store information in
+                            ;; the debug-info about to determine the
+                            ;; arguments here, but for now let's just pass
+                            ;; on it.
+                            :unknown)))))
+
+;;; This function will replace the fdefn / function that was in the
+;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To
+;;; ensure that the full call will use the wrapper instead of the
+;;; original, conditional trap must be emitted before the fdefn /
+;;; function is converted into a raw address.
+(defun handle-single-step-around-trap (context callee-register-offset)
+  ;; Fetch the function / fdefn we're about to call from the
+  ;; appropriate register.
+  (let* ((callee (make-lisp-obj
+                  (context-register context callee-register-offset)))
+         (step-info (single-step-info-from-context context)))
+    ;; If there was not enough debug information available, there's no
+    ;; sense in signaling the condition.
+    (unless step-info
+      (return-from handle-single-step-around-trap))
+    (let* ((fun (lambda (&rest args)
+                  (flet ((call ()
+                           (apply (typecase callee
+                                    (fdefn (fdefn-fun callee))
+                                    (function callee))
+                                  args)))
+                    ;; Signal a step condition
+                    (let* ((step-in
+                            (let ((*step-frame* (frame-down (top-frame))))
+                              (sb!impl::step-form step-info args))))
+                      ;; And proceed based on its return value.
+                      (if step-in
+                          ;; STEP-INTO was selected. Use *STEP-OUT* to
+                          ;; let the stepper know that selecting the
+                          ;; STEP-OUT restart is valid inside this
+                          (let ((sb!impl::*step-out* :maybe))
+                            ;; Pass the return values of the call to
+                            ;; STEP-VALUES, which will signal a
+                            ;; condition with them in the VALUES slot.
+                            (unwind-protect
+                                 (multiple-value-call #'sb!impl::step-values
+                                   step-info
+                                   (call))
+                              ;; If the user selected the STEP-OUT
+                              ;; restart during the call, resume
+                              ;; stepping
+                              (when (eq sb!impl::*step-out* t)
+                                (sb!impl::enable-stepping))))
+                          ;; STEP-NEXT / CONTINUE / OUT selected:
+                          ;; Disable the stepper for the duration of
+                          ;; the call.
+                          (sb!impl::with-stepping-disabled
+                            (call)))))))
+           (new-callee (etypecase callee
+                         (fdefn
+                          (let ((fdefn (make-fdefn (gensym))))
+                            (setf (fdefn-fun fdefn) fun)
+                            fdefn))
+                         (function fun))))
+      ;; And then store the wrapper in the same place.
+      (setf (context-register context callee-register-offset)
+            (get-lisp-obj-address new-callee)))))
+
+;;; Given a signal context, fetch the step-info that's been stored in
+;;; the debug info at the trap point.
+(defun single-step-info-from-context (context)
+  (multiple-value-bind (pc-offset code)
+      (compute-lra-data-from-pc (context-pc context))
+    (let* ((debug-fun (debug-fun-from-pc code pc-offset))
+           (location (code-location-from-pc debug-fun
+                                            pc-offset
+                                            nil)))
+      (handler-case
+          (progn
+            (fill-in-code-location location)
+            (code-location-debug-source location)
+            (compiled-code-location-step-info location))
+        (debug-condition ()
+          nil)))))
+
+;;; Return the frame that triggered a single-step condition. Used to
+;;; provide a *STACK-TOP-HINT*.
+(defun find-stepped-frame ()
+  (or *step-frame*
+      (top-frame)))