X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=ea6149bdde346fad8c333769331294ff2ea5af2a;hb=95f5ac2fa70b3f14d052e20f4250166f219dcc39;hp=13e80e8ea1963f9a4f81679b1ca12b9acded1c53;hpb=4f64f131a7bca59d0dc8be9e74d05a7645f27e67;p=sbcl.git

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 13e80e8..ea6149b 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -47,7 +47,6 @@
   #!+sb-doc
   (:documentation "There is no usable debugging information available.")
   (:report (lambda (condition stream)
-	     (declare (ignore condition))
 	     (fresh-line stream)
 	     (format stream
 		     "no debug information available for ~S~%"
@@ -187,13 +186,14 @@
 ;;;; 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
 ;;; compiler debug-functions. Debug-functions store these.
-(defstruct (debug-var (:constructor nil))
+(defstruct (debug-var (:constructor nil)
+		      (:copier nil))
   ;; the name of the variable
   (symbol (required-argument) :type symbol)
   ;; a unique integer identification relative to other variables with the same
@@ -216,7 +216,8 @@
 (defstruct (compiled-debug-var
 	    (:include debug-var)
 	    (:constructor make-compiled-debug-var
-			  (symbol id alive-p sc-offset save-sc-offset)))
+			  (symbol id alive-p sc-offset save-sc-offset))
+	    (:copier nil))
   ;; Storage class and offset. (unexported).
   (sc-offset nil :type sb!c::sc-offset)
   ;; Storage class and offset when saved somewhere.
@@ -224,14 +225,16 @@
 
 (defstruct (interpreted-debug-var
 	    (:include debug-var (alive-p t))
-	    (:constructor make-interpreted-debug-var (symbol ir1-var)))
+	    (:constructor make-interpreted-debug-var (symbol ir1-var))
+	    (:copier nil))
   ;; This is the IR1 structure that holds information about interpreted vars.
   (ir1-var nil :type sb!c::lambda-var))
 
 ;;;; frames
 
 ;;; These represent call-frames on the stack.
-(defstruct (frame (:constructor nil))
+(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
@@ -273,7 +276,8 @@
 	    (:constructor make-compiled-frame
 			  (pointer up debug-function code-location number
 				   #!+gengc saved-state-chain
-				   &optional escaped)))
+				   &optional escaped))
+	    (:copier nil))
   ;; This indicates whether someone interrupted the frame.
   ;; (unexported). If escaped, this is a pointer to the state that was
   ;; saved when we were interrupted. On the non-gengc system, this is
@@ -296,7 +300,8 @@
 	    (:include frame)
 	    (:constructor make-interpreted-frame
 			  (pointer up debug-function code-location number
-			   real-frame closure)))
+			   real-frame closure))
+	    (:copier nil))
   ;; 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.
@@ -314,7 +319,7 @@
 ;;; 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
+(defstruct (debug-function (:copier nil))
   ;; Some representation of the function arguments. See
   ;; DEBUG-FUNCTION-LAMBDA-LIST.
   ;; NOTE: must parse vars before parsing arg list stuff.
@@ -334,7 +339,8 @@
 (defstruct (compiled-debug-function
 	    (:include debug-function)
 	    (:constructor %make-compiled-debug-function
-			  (compiler-debug-fun component)))
+			  (compiler-debug-fun component))
+	    (:copier nil))
   ;; Compiler's dumped debug-function information. (unexported).
   (compiler-debug-fun nil :type sb!c::compiled-debug-function)
   ;; Code object. (unexported).
@@ -360,7 +366,8 @@
 
 (defstruct (interpreted-debug-function
 	    (:include debug-function)
-	    (:constructor %make-interpreted-debug-function (ir1-lambda)))
+	    (:constructor %make-interpreted-debug-function (ir1-lambda))
+	    (:copier nil))
   ;; This is the IR1 lambda that this debug-function represents.
   (ir1-lambda nil :type sb!c::clambda))
 
@@ -368,7 +375,8 @@
 	    (:include debug-function)
 	    (:constructor make-bogus-debug-function
 			  (%name &aux (%lambda-list nil) (%debug-vars nil)
-				 (blocks nil) (%function nil))))
+				 (blocks nil) (%function nil)))
+	    (:copier nil))
   %name)
 
 (defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq))
@@ -382,8 +390,9 @@
 ;;;; 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)
   ;; This indicates whether the block is a special glob of code shared by
@@ -408,14 +417,16 @@
 (defstruct (compiled-debug-block (:include debug-block)
 				 (:constructor
 				  make-compiled-debug-block
-				  (code-locations successors elsewhere-p)))
-  ;; Code-location information for the block.
+				  (code-locations successors elsewhere-p))
+				 (:copier nil))
+  ;; code-location information for the block
   (code-locations nil :type simple-vector))
 
 (defstruct (interpreted-debug-block (:include debug-block
 					      (elsewhere-p nil))
 				    (:constructor %make-interpreted-debug-block
-						  (ir1-block)))
+						  (ir1-block))
+				    (:copier nil))
   ;; This is the IR1 block this debug-block represents.
   (ir1-block nil :type sb!c::cblock)
   ;; Code-location information for the block.
@@ -434,7 +445,7 @@
 ;;; 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)
+  (declare (type sb!c::cblock ir1-block))
   (let ((res (gethash ir1-block *ir1-block-debug-block*)))
     (or res
 	(let ((lambda (sb!c::block-home-lambda ir1-block)))
@@ -466,7 +477,8 @@
 ;;; 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.
@@ -484,7 +496,8 @@
 	    (breakpoint-data-offset obj))))
 
 (defstruct (breakpoint (:constructor %make-breakpoint
-				     (hook-function what kind %info)))
+				     (hook-function what kind %info))
+		       (:copier nil))
   ;; This is the function invoked when execution encounters the
   ;; breakpoint. It takes a frame, the breakpoint, and optionally a
   ;; list of values. Values are supplied for :FUNCTION-END breakpoints
@@ -551,7 +564,8 @@
 
 ;;;; CODE-LOCATIONs
 
-(defstruct (code-location (:constructor nil))
+(defstruct (code-location (:constructor nil)
+			  (:copier nil))
   ;; This is the debug-function containing code-location.
   (debug-function nil :type debug-function)
   ;; This is initially :UNSURE. Upon first trying to access an
@@ -587,7 +601,8 @@
 	    (: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)))
+	    (:constructor make-compiled-code-location (pc debug-function))
+	    (:copier nil))
   ;; 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
@@ -602,7 +617,8 @@
 	    (:include code-location
 		      (%unknown-p nil))
 	    (:constructor make-interpreted-code-location
-			  (ir1-node debug-function)))
+			  (ir1-node debug-function))
+	    (:copier nil))
   ;; This is an index into debug-function's component slot.
   (ir1-node nil :type sb!c::node))
 
@@ -654,7 +670,7 @@
 
 ;;;; frames
 
-;;; This is used in FIND-ESCAPE-FRAME and with the bogus components
+;;; This is used in FIND-ESCAPED-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
 ;;; real component to continue executing, as opposed to the bogus
@@ -767,7 +783,8 @@
 	       (cond ((and lisp-path-fp c-path-fp)
                        ;; Both still seem valid - choose the lisp frame.
                        #+nil (when (zerop depth)
-                               (format t "debug: both still valid ~S ~S ~S ~S~%"
+                               (format t
+				       "debug: both still valid ~S ~S ~S ~S~%"
                                        lisp-ocfp lisp-ra c-ocfp c-ra))
 		      #+freebsd
 		      (if (sap> lisp-ocfp c-ocfp)
@@ -950,8 +967,10 @@
 ;;; 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))
+	  #!+sb-interpreter (not (eq (debug-function-name (frame-debug-function
+							   frame))
+				     'sb!eval::internal-apply-loop))
+	  #!-sb-interpreter t
 	  *debugging-interpreter*
 	  (compiled-frame-escaped frame))
       frame
@@ -1045,27 +1064,22 @@
 #!+x86
 (defun compute-calling-frame (caller ra up-frame)
   (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~%")
     ;; 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)))
+		 (aver code)))
 	      (t
-	       ;; Not escaped
+	       ;; 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
@@ -1089,24 +1103,17 @@
 			       (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
 (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))
+
+  ;; FIXME: These conditionals are a hack to get the system to
+  ;; bootstrap itself despite a byte interpreter/compiler bug. Without
+  ;; it, the byte interpreter blows up when trying to cross-compile
+  ;; this function, hitting #:UNINITIALIZED-EVAL-STACK-ELEMENT while
+  ;; executing (SB-XC:MACRO-FUNCTION 'SB!EXT:WITH-ALIEN).
+  #+sb-xc (values nil 0 nil) #-sb-xc ; REMOVEME
+  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
     (sb!alien:with-alien
 	((lisp-interrupt-contexts (array (* os-context-t) nil)
 				  :extern))
@@ -1139,6 +1146,50 @@
 	       (return
 		(values code pc-offset context))))))))))
 
+#!-x86
+(defun find-escaped-frame (frame-pointer)
+  (declare (type system-area-pointer frame-pointer))
+  (dotimes (index *free-interrupt-context-index* (values nil 0 nil))
+    (sb!alien:with-alien
+     ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
+     (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
+       (when (= (sap-int frame-pointer)
+                (sb!vm:context-register scp sb!vm::cfp-offset))
+         (without-gcing
+          (let ((code (code-object-from-bits
+                       (sb!vm:context-register scp sb!vm::code-offset))))
+            (when (symbolp code)
+              (return (values code 0 scp)))
+            (let* ((code-header-len (* (get-header-data code)
+                                       sb!vm:word-bytes))
+                   (pc-offset
+                    (- (sap-int (sb!vm:context-pc scp))
+                       (- (get-lisp-obj-address code)
+                          sb!vm:other-pointer-type)
+                       code-header-len)))
+              ;; Check to see whether we were executing in a branch
+              ;; delay slot.
+              #!+(or pmax sgi) ; pmax only (and broken anyway)
+              (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
+                (incf pc-offset sb!vm:word-bytes))
+              (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.
+                (setf pc-offset
+                      (- (sb!vm:context-register scp sb!vm::lra-offset)
+                         (get-lisp-obj-address code)
+                         code-header-len)))
+               (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)))))))))))
+
 ;;; Find the code object corresponding to the object represented by
 ;;; bits and return it. We assume bogus functions correspond to the
 ;;; undefined-function.
@@ -1245,7 +1296,7 @@
    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 (descriptor-sap *current-catch-block*)
 	 #!+gengc (mutator-current-catch-block))
 	(res nil)
 	(fp (frame-pointer (frame-real-frame frame))))
@@ -1316,14 +1367,14 @@
 
 ;;;; operations on DEBUG-FUNCTIONs
 
+;;; Execute 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.
 (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."
   (let ((blocks (gensym))
 	(i (gensym)))
     `(let ((,blocks (debug-function-debug-blocks ,debug-function)))
@@ -1332,14 +1383,13 @@
 	 (let ((,block-var (svref ,blocks ,i)))
 	   ,@body)))))
 
+;;; Execute 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.
 (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 ((vars (gensym))
 	(i (gensym)))
     `(let ((,vars (debug-function-debug-vars ,debug-function)))
@@ -1350,11 +1400,10 @@
 	       ,@body))
 	   ,result))))
 
+;;; Return 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.
 (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)))
     (if (eq cached-value :unparsed)
 	(setf (debug-function-%function debug-function)
@@ -1381,10 +1430,9 @@
 		(bogus-debug-function nil)))
 	cached-value)))
 
+;;; Return the name of the function represented by debug-function. This may
+;;; be a string or a cons; do not assume it is a symbol.
 (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
@@ -1395,14 +1443,14 @@
     (bogus-debug-function
      (bogus-debug-function-%name debug-function))))
 
+;;; Return a debug-function that represents debug information for 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)
+     (cond #!+sb-interpreter
+	   ((sb!eval:interpreted-function-p fun)
 	    (make-interpreted-debug-function
 	     (or (sb!eval::interpreted-function-definition fun)
 		 (sb!eval::convert-interpreted-fun fun))))
@@ -1433,10 +1481,9 @@
 					  (get-header-data component))
 				       sb!vm:word-bytes)))))))
 
+;;; Return the kind of the function, which is one of :OPTIONAL,
+;;; :EXTERNAL, TOP-level, :CLEANUP, or NIL.
 (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."
   ;; FIXME: This "is one of" information should become part of the function
   ;; declamation, not just a doc string
   (etypecase debug-function
@@ -1449,19 +1496,17 @@
     (bogus-debug-function
      nil)))
 
+;;; Is there any variable information for DEBUG-FUNCTION?
 (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))))
 
+;;; Return 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.
 (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)))))
@@ -1474,11 +1519,12 @@
 		     (stringp (debug-var-package-name var))))
 	       vars)))
 
+;;; Return 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.
 (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."
   (declare (simple-string name-prefix-string))
   (let ((variables (debug-function-debug-vars debug-function)))
     (declare (type (or null simple-vector) variables))
@@ -1519,24 +1565,25 @@
 			       (string= x y :end1 name-len :end2 name-len))))
 	      :end (or end (length variables)))))
 
+;;; Return 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 if
+;;; it is unreferenced in DEBUG-FUNCTION. This signals a
+;;; LAMBDA-LIST-UNAVAILABLE condition when there is no argument list
+;;; information.
 (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))
@@ -1581,7 +1628,7 @@
 				(push (frob final-arg debug-vars) res))
 			       (:keyword
 				(push (list :keyword
-					    (sb!c::arg-info-keyword info)
+					    (sb!c::arg-info-key info)
 					    (frob final-arg debug-vars))
 				      res))
 			       (:rest
@@ -1682,11 +1729,11 @@
 		       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
+		 ;; the &MORE arg context and count, and act like they
 		 ;; are regular arguments.
 		 nil)
 		(t
-		 ;; keyword arg
+		 ;; &KEY arg
 		 (push (list :keyword
 			     ele
 			     (compiled-debug-function-lambda-list-var
@@ -1976,7 +2023,7 @@
 			 0))
 		 (sc-offset (if deleted 0 (geti)))
 		 (save-sc-offset (if save (geti) nil)))
-	    (assert (not (and args-minimal (not minimal))))
+	    (aver (not (and args-minimal (not minimal))))
 	    (vector-push-extend (make-compiled-debug-var symbol
 							 id
 							 live
@@ -2419,13 +2466,14 @@
    invalid. This is SETF'able."
   (etypecase debug-var
     (compiled-debug-var
-     (check-type frame compiled-frame)
+     (aver (typep 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)))
+    #!+sb-interpreter
     (interpreted-debug-var
-     (check-type frame interpreted-frame)
+     (aver (typep 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)
@@ -2436,16 +2484,17 @@
 ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
 ;;; cell if the variable is both closed over and set.
 (defun access-compiled-debug-var-slot (debug-var frame)
+  (declare (optimize (speed 1)))
   (let ((escaped (compiled-frame-escaped frame)))
     (if escaped
-	(sub-access-debug-var-slot
-	 (frame-pointer frame)
-	 (compiled-debug-var-sc-offset debug-var)
-	 escaped)
-	(sub-access-debug-var-slot
-	 (frame-pointer frame)
-	 (or (compiled-debug-var-save-sc-offset debug-var)
-	     (compiled-debug-var-sc-offset debug-var))))))
+        (sub-access-debug-var-slot
+         (frame-pointer frame)
+         (compiled-debug-var-sc-offset debug-var)
+         escaped)
+      (sub-access-debug-var-slot
+       (frame-pointer frame)
+       (or (compiled-debug-var-save-sc-offset debug-var)
+           (compiled-debug-var-sc-offset debug-var))))))
 
 ;;; a helper function for working with possibly-invalid values:
 ;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
@@ -2455,7 +2504,7 @@
 ;;; 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))
+  #!+sb-show (/hexstr val)
   (if (or
        ;; fixnum
        (zerop (logand val 3))
@@ -2480,27 +2529,161 @@
       (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"))
+(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+  (macrolet ((with-escaped-value ((var) &body forms)
+               `(if escaped
+                    (let ((,var (sb!vm:context-register
+                                 escaped
+                                 (sb!c:sc-offset-offset sc-offset))))
+                      ,@forms)
+                    :invalid-value-for-unescaped-register-storage))
+             (escaped-float-value (format)
+               `(if escaped
+                    (sb!vm:context-float-register
+                     escaped
+                     (sb!c:sc-offset-offset sc-offset)
+                     ',format)
+                    :invalid-value-for-unescaped-register-storage))
+             (with-nfp ((var) &body body)
+               `(let ((,var (if escaped
+                                (sb!sys:int-sap
+                                 (sb!vm:context-register escaped
+                                                         sb!vm::nfp-offset))
+                                #!-alpha
+                                (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
+                                                          sb!vm:word-bytes))
+                                #!+alpha
+                                (sb!vm::make-number-stack-pointer
+                                 (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
+                                                          sb!vm:word-bytes))))))
+                  ,@body)))
+    (ecase (sb!c:sc-offset-scn sc-offset)
+      ((#.sb!vm:any-reg-sc-number
+        #.sb!vm:descriptor-reg-sc-number
+        #!+rt #.sb!vm:word-pointer-reg-sc-number)
+       (sb!sys:without-gcing
+        (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
+                            
+      (#.sb!vm:base-char-reg-sc-number
+       (with-escaped-value (val)
+         (code-char val)))
+      (#.sb!vm:sap-reg-sc-number
+       (with-escaped-value (val)
+         (sb!sys:int-sap val)))
+      (#.sb!vm:signed-reg-sc-number
+       (with-escaped-value (val)
+         (if (logbitp (1- sb!vm:word-bits) val)
+             (logior val (ash -1 sb!vm:word-bits))
+             val)))
+      (#.sb!vm:unsigned-reg-sc-number
+       (with-escaped-value (val)
+         val))
+      (#.sb!vm:non-descriptor-reg-sc-number
+       (error "Local non-descriptor register access?"))
+      (#.sb!vm:interior-reg-sc-number
+       (error "Local interior register access?"))
+      (#.sb!vm:single-reg-sc-number
+       (escaped-float-value single-float))
+      (#.sb!vm:double-reg-sc-number
+       (escaped-float-value double-float))
+      #!+long-float
+      (#.sb!vm:long-reg-sc-number
+       (escaped-float-value long-float))
+      (#.sb!vm:complex-single-reg-sc-number
+       (if escaped
+           (complex
+            (sb!vm:context-float-register
+             escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
+            (sb!vm:context-float-register
+             escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
+           :invalid-value-for-unescaped-register-storage))
+      (#.sb!vm:complex-double-reg-sc-number
+       (if escaped
+           (complex
+            (sb!vm:context-float-register
+             escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
+            (sb!vm:context-float-register
+             escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1)
+             'double-float))
+           :invalid-value-for-unescaped-register-storage))
+      #!+long-float
+      (#.sb!vm:complex-long-reg-sc-number
+       (if escaped
+           (complex
+            (sb!vm:context-float-register
+             escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
+            (sb!vm:context-float-register
+             escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
+             'long-float))
+           :invalid-value-for-unescaped-register-storage))
+      (#.sb!vm:single-stack-sc-number
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+                                       sb!vm:word-bytes))))
+      (#.sb!vm:double-stack-sc-number
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+                                       sb!vm:word-bytes))))
+      #!+long-float
+      (#.sb!vm:long-stack-sc-number
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+                                     sb!vm:word-bytes))))
+      (#.sb!vm:complex-single-stack-sc-number
+       (with-nfp (nfp)
+         (complex
+          (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+                                        sb!vm:word-bytes))
+          (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
+                                        sb!vm:word-bytes)))))
+      (#.sb!vm:complex-double-stack-sc-number
+       (with-nfp (nfp)
+         (complex
+          (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+                                        sb!vm:word-bytes))
+          (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+                                        sb!vm:word-bytes)))))
+      #!+long-float
+      (#.sb!vm:complex-long-stack-sc-number
+       (with-nfp (nfp)
+         (complex
+          (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+                                      sb!vm:word-bytes))
+          (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
+                                         #!+sparc 4)
+                                      sb!vm:word-bytes)))))
+      (#.sb!vm:control-stack-sc-number
+       (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
+      (#.sb!vm:base-char-stack-sc-number
+       (with-nfp (nfp)
+         (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+                                              sb!vm:word-bytes)))))
+      (#.sb!vm:unsigned-stack-sc-number
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+                                   sb!vm:word-bytes))))
+      (#.sb!vm:signed-stack-sc-number
+       (with-nfp (nfp)
+         (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+                                          sb!vm:word-bytes))))
+      (#.sb!vm:sap-stack-sc-number
+       (with-nfp (nfp)
+         (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
+                                    sb!vm:word-bytes)))))))
 
 #!+x86
 (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))
+  (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
   (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))
+		      (/hexstr ,var)
 		      ,@forms)
 		    :invalid-value-for-unescaped-register-storage))
 	     (escaped-float-value (format)
@@ -2522,7 +2705,7 @@
        (without-gcing
 	(with-escaped-value (val)
 	  (/show0 "VAL=..")
-	  #!+sb-show (%primitive print (sb!impl::hexstr val))
+	  (/hexstr val)
 	  (make-valid-lisp-obj val))))
       (#.sb!vm:base-char-reg-sc-number
        (/show0 "case of BASE-CHAR-REG-SC-NUMBER")
@@ -2627,13 +2810,14 @@
 (defun %set-debug-var-value (debug-var frame value)
   (etypecase debug-var
     (compiled-debug-var
-     (check-type frame compiled-frame)
+     (aver (typep 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))))
+    #!+sb-interpreter
     (interpreted-debug-var
-     (check-type frame interpreted-frame)
+     (aver (typep 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)
@@ -2682,13 +2866,13 @@
 							 sb!vm::nfp-offset))
 				#!-alpha
 				(sap-ref-sap fp
-						    (* sb!vm::nfp-save-offset
-						       sb!vm:word-bytes))
+					     (* sb!vm::nfp-save-offset
+						sb!vm:word-bytes))
 				#!+alpha
-				(%alpha::make-number-stack-pointer
+				(sb!vm::make-number-stack-pointer
 				 (sap-ref-32 fp
-						    (* sb!vm::nfp-save-offset
-						       sb!vm:word-bytes))))))
+					     (* sb!vm::nfp-save-offset
+						sb!vm:word-bytes))))))
 		  ,@body)))
     (ecase (sb!c:sc-offset-scn sc-offset)
       ((#.sb!vm:any-reg-sc-number
@@ -2934,7 +3118,7 @@
     (compiled-debug-var
      (compiled-debug-var-validity debug-var basic-code-location))
     (interpreted-debug-var
-     (check-type basic-code-location interpreted-code-location)
+     (aver (typep basic-code-location 'interpreted-code-location))
      (let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var)
 			   (sb!c::lexenv-variables
 			    (sb!c::node-lexenv
@@ -2945,7 +3129,7 @@
 ;;; 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)
 	 (let ((debug-fun (code-location-debug-function basic-code-location)))
 	   (if (>= (compiled-code-location-pc basic-code-location)
@@ -2957,14 +3141,16 @@
 	(t
 	 (let ((pos (position debug-var
 			      (debug-function-debug-vars
-			       (code-location-debug-function basic-code-location)))))
+			       (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)
+	   (if (zerop (sbit (compiled-code-location-live-set
+			     basic-code-location)
 			    pos))
 	       :invalid
 	       :valid)))))
@@ -2988,21 +3174,21 @@
 ;;; 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.
+;;; 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.
+;;; 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 top-level-form form, going directly to the
+;;; subform corressponding to the form number.
+;;;
 ;;; The vector elements are in the same format as the compiler's
-;;; NODE-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 top-level-form 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))
@@ -3030,13 +3216,13 @@
 	  (frob)
 	  (setq trail (cdr trail)))))))
 
+;;; FORM is a top-level form, and path is a source-path into it. This
+;;; returns the form indicated by the source-path. Context is the
+;;; number of enclosing forms to return instead of directly returning
+;;; the source-path form. When context is non-zero, the form returned
+;;; contains a marker, #:****HERE****, immediately before the form
+;;; indicated by path.
 (defun source-path-context (form path context)
-  #!+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.
@@ -3068,17 +3254,15 @@
 
 ;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME
 
-;;; 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.
+;;; 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.
 (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))
 	(fun (code-location-debug-function loc)))
@@ -3166,7 +3350,7 @@
      (when (code-location-unknown-p what)
        (error "cannot make a breakpoint at an unknown code location: ~S"
 	      what))
-     (assert (eq kind :code-location))
+     (aver (eq kind :code-location))
      (let ((bpt (%make-breakpoint hook-function what kind info)))
        (etypecase what
 	 (interpreted-code-location
@@ -3214,10 +3398,11 @@
 (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.
+	    (:constructor make-function-end-cookie (bogus-lra debug-fun))
+	    (:copier nil))
+  ;; a pointer to the bogus-lra created for :FUNCTION-END breakpoints
   bogus-lra
-  ;; This is the debug-function associated with the cookie.
+  ;; the debug-function associated with the cookie
   debug-fun)
 
 ;;; This maps bogus-lra-components to cookies, so that
@@ -3565,8 +3750,10 @@
       ;; 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)
+      ;; Some platforms have no usable sigreturn() call.  If your
+      ;; implementation of arch_do_displaced_inst() doesn't sigreturn(),
+      ;; add it to this list.
+      #!-(or hpux irix x86 alpha)
       (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
 
 (defun invoke-breakpoint-hooks (breakpoints component offset)
@@ -3593,7 +3780,7 @@
 	      offset))
     (let ((breakpoints (breakpoint-data-breakpoints data)))
       (when breakpoints
-	(assert (eq (breakpoint-kind (car breakpoints)) :function-end))
+	(aver (eq (breakpoint-kind (car breakpoints)) :function-end))
 	(handle-function-end-breakpoint-aux breakpoints data context)))))
 
 ;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints