From 79304ca6f8cbe454a7d5ad2345ea9f7e3f132d42 Mon Sep 17 00:00:00 2001
From: chiles <chiles>
Date: Sat, 12 Oct 1991 20:52:04 +0000
Subject: [PATCH] The latest alpha test breakpoint interface is available as
 described in the Debugging Tools Programmer's Interface.  Also, support for
 setting breakpoints from the editor has been changed to use the "WIRE"
 package directly.  There is a new interface for deleting breakpoints set by
 the editor.  This is all alpha test code.

---
 code/debug-int.lisp | 1336 +++++++++++++++++++++++++++++++++++++------
 1 file changed, 1154 insertions(+), 182 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index 4feb0fd3e..4596eb3aa 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.26 1991/05/16 14:58:22 chiles Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.27 1991/10/12 20:52:04 chiles Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -68,6 +68,9 @@
 	  unknown-code-location unknown-debug-variable invalid-value
 	  ambiguous-variable-name frame-function-mismatch
 
+	  set-breakpoint-for-editor set-location-breakpoint-for-editor
+	  delete-breakpoint-for-editor
+
 	  *debugging-interpreter*))
 
 
@@ -161,9 +164,9 @@
 
 ;;;; Errors and DEBUG-SIGNAL.
 
-;;; The debug internals code tries to signal all programmer errors as
-;;; subtypes of debug-error.  There are calls to ERROR signalling simple-errors,
-;;; but these dummy checks in the code and shouldn't come up.
+;;; The debug-internals code tries to signal all programmer errors as subtypes
+;;; of debug-error.  There are calls to ERROR signalling simple-errors, but
+;;; these dummy checks in the code and shouldn't come up.
 ;;;
 ;;; While under development, this code also signals errors in code branches
 ;;; that remain unimplemented.
@@ -180,13 +183,6 @@
 	     (format stream "~&Unhandled debug-condition:~%~A"
 		     (unhandled-condition-condition condition)))))
 
-(define-condition invalid-control-stack-pointer (debug-error)
-  ()
-  (:report (lambda (condition stream)
-	     (declare (ignore condition))
-	     (fresh-line stream)
-	     (write-string "Invalid control stack pointer." stream))))
-
 (define-condition unknown-code-location (debug-error)
   ((code-location))
   (:report (lambda (condition stream)
@@ -201,6 +197,13 @@
 		     (unknown-debug-variable-debug-variable condition)
 		     (unknown-debug-variable-debug-function condition)))))
 
+(define-condition invalid-control-stack-pointer (debug-error)
+  ()
+  (:report (lambda (condition stream)
+	     (declare (ignore condition))
+	     (fresh-line stream)
+	     (write-string "Invalid control stack pointer." stream))))
+
 (define-condition frame-function-mismatch (debug-error)
   ((code-location)
    (frame)
@@ -221,7 +224,8 @@
 ;;; ??? Get SIGNAL in the right package!
 ;;;
 (defmacro debug-signal (datum &rest arguments)
-  `(let ((condition (ext:signal ,datum ,@arguments)))
+  `(let ((condition (make-condition ,datum ,@arguments)))
+     (signal condition)
      (error 'unhandled-condition :condition condition)))
 
 
@@ -606,7 +610,8 @@
   ;; 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 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.
@@ -628,6 +633,20 @@
   ;; sure we only invoke the hook-functions once.
   (unknown-return-partner nil :type (or null breakpoint))
   ;;
+  ;; :function-end breakpoints use a breakpoint at the :function-start to
+  ;; establish the end breakpoint upon function entry.  We do this by frobbing
+  ;; the LRA to jump to a special piece of code that breaks and provides the
+  ;; return values for the returnee.  This slot points to the start breakpoint,
+  ;; so we can activate, deactivate, and delete it.
+  (start-helper nil :type (or null breakpoint))
+  ;;
+  ;; This is a hook users supply to get a dynamically unique cookie for
+  ;; identifying :function-end breakpoint executions.  That is, if there is one
+  ;; :function-end breakpoint, but there may be multiple pending calls of its
+  ;; function on the stack.  This function takes the cookie, and the
+  ;; hook-function takes the cookie too.
+  (cookie-fun nil :type (or null function))
+  ;;
   ;; This slot users can set with whatever information they find useful.
   %info)
 ;;;
@@ -746,8 +765,8 @@
   (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
   ;;
   ;; (unexported)
-  (kind :unparsed :type (member :unparsed :unknown-return :known-return
-				:internal-error :non-local-exit :block-start)))
+  ;; To see c::location-kind, do "(kernel:type-expand 'c::location-kind)".
+  (kind :unparsed :type (or (member :unparsed) c::location-kind)))
 
 (defstruct (interpreted-code-location
 	    (:include code-location
@@ -807,6 +826,14 @@
 
 ;;;; 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 real component to continue
+;;; executing, as opposed to the bogus component which appeared in some frame's
+;;; LRA location.
+;;;
+(defconstant real-lra-slot vm:code-constants-offset)
+
 ;;; These are magically converted by the compiler.
 ;;;
 (defun current-sp () (current-sp))
@@ -835,19 +862,6 @@
 (def-c-variable "lisp_interrupt_contexts" interrupt-array)
 
 
-;;; These are the names of all the functions that the system could have called
-;;; while interpreting.  We need to detect these when parsing the stack and
-;;; make frames representing the code the intepreter is evaluating.
-
-;;; FRAME-REAL-FRAME  --  Internal
-;;;
-;;;    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))))
-
 ;;; TOP-FRAME -- Public.
 ;;;
 (defun top-frame ()
@@ -860,26 +874,9 @@
 			    pc nil)
      nil)))
 
-
-;;; GET-CONTEXT-VALUE  --  Internal
-;;;
-;;;    Get the old FP or return PC out of Frame.  Stack-Slot is offset the
-;;; standard save location on the stack.  Loc the the saved SC-Offset
-;;; describing the main location.
-;;;
-(defun get-context-value (frame stack-slot loc)
-  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
-	   (type 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))))
-
-  
 ;;; FRAME-DOWN -- Public.
 ;;;
-;;;    We have to access the old-fp and return-pc out of Frame and pass them to
+;;; We have to access the old-fp and return-pc out of frame and pass them to
 ;;; COMPUTE-CALLING-FRAME.
 ;;;
 (defun frame-down (frame)
@@ -915,80 +912,31 @@
 					    frame))))))
 	down)))
 
-;;; CODE-OBJECT-FROM-BITS  --  internal.
+
+;;; GET-CONTEXT-VALUE  --  Internal.
 ;;;
-;;; Find the code object corresponding to the object represented by bits and
-;;; return it.  We assume bogus functions correspond to the
-;;; undefined-function.
-;;; 
-(defun code-object-from-bits (bits)
-  (declare (type (unsigned-byte 32) bits))
-  (let ((object (make-lisp-obj bits)))
-    (if (functionp object)
-	(or (function-code-header object)
-	    :undefined-function)
-	(let ((lowtag (get-lowtag object)))
-	  (if (= lowtag vm:other-pointer-type)
-	      (let ((type (get-type object)))
-		(cond ((= type vm:code-header-type)
-		       object)
-		      ((= type vm:return-pc-header-type)
-		       (lra-code-header object))
-		      (t
-		       nil))))))))
+;;; Get the old FP or return PC out of frame.  Stack-slot is the standard save
+;;; location offset on the stack.  Loc is the saved sc-offset describing the
+;;; main location.
+;;;
+(defun get-context-value (frame stack-slot loc)
+  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+	   (type 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))))
+;;;
+(defun (setf get-context-value) (value frame stack-slot loc)
+  (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+	   (type 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))))
 
-(defun find-escaped-frame (frame-pointer)
-  (declare (type system-area-pointer frame-pointer))
-  (dotimes (index lisp::*free-interrupt-context-index*
-		  (values nil 0 nil))
-    (alien-bind ((scp (interrupt-array-ref
-		       (alien-value lisp_interrupt_contexts)
-		       index)
-		      (alien mach:sigcontext #.(c-sizeof 'mach:sigcontext))
-		      t)
-		 (sc (mach:indirect-*sigcontext scp)
-		     mach:sigcontext
-		     t)
-		 (regs (mach:sigcontext-regs (alien-value sc))
-		       mach:int-array
-		       t))
-      (when (= (sap-int frame-pointer)
-	       (alien-access
-		(mach:int-array-ref regs vm::cfp-offset)))
-	(system:without-gcing
-	 (let ((code (code-object-from-bits
-		      (alien-access
-		       (mach:int-array-ref regs vm::code-offset)))))
-	   (when (symbolp code)
-	     (return (values code 0 (alien-value sc))))
-	   (let* ((code-header-len (* (get-header-data code) vm:word-bytes))
-		  (pc-offset
-		   (- (sap-int
-		       (alien-access
-			(mach:sigcontext-pc (alien-value sc))))
-		      (- (get-lisp-obj-address code) vm:other-pointer-type)
-		      code-header-len)))
-	     ;; Check to see if we were executing in a branch delay slot.
-	     #+pmax  ; pmax only
-	     (when (logbitp 31 (alien-access
-				(mach:sigcontext-cause (alien-value sc))))
-	       (incf pc-offset vm:word-bytes))
-	     (unless (<= 0
-			 pc-offset
-			 (* (truly-the lisp::index
-				       (%primitive c::code-code-size code))
-			    vm:word-bytes))
-	       ;; We were in an assembly routine.  Therefore, use the LRA as
-	       ;; the pc.
-	       (setf pc-offset
-		     (- (escape-register (alien-value sc)
-					 vm::lra-offset)
-			(get-lisp-obj-address code)
-			code-header-len)))
-	     (return
-	      (values code
-		      pc-offset
-		      (alien-value sc))))))))))
 
 (defvar *debugging-interpreter* nil
   "When set, the debugger foregoes making interpreted-frames, so you can
@@ -1037,6 +985,7 @@
 		 (debug-variable-value closure-var frame)))
 	      frame)))))
 
+
 ;;; COMPUTE-CALLING-FRAME -- Internal.
 ;;;
 ;;; This returns a frame for the one existing in time immediately prior to the
@@ -1092,6 +1041,72 @@
 			     (if up-frame (1+ (frame-number up-frame)) 0)
 			     escaped)))))
 
+(defun find-escaped-frame (frame-pointer)
+  (declare (type system-area-pointer frame-pointer))
+  (dotimes (index lisp::*free-interrupt-context-index* (values nil 0 nil))
+    (alien-bind ((scp (interrupt-array-ref (alien-value lisp_interrupt_contexts)
+					   index)
+		      (alien mach:sigcontext #.(c-sizeof 'mach:sigcontext))
+		      t)
+		 (sc (mach:indirect-*sigcontext scp) mach:sigcontext t)
+		 (regs (mach:sigcontext-regs (alien-value sc)) mach:int-array t))
+      (when (= (sap-int frame-pointer)
+	       (alien-access (mach:int-array-ref regs vm::cfp-offset)))
+	(system:without-gcing
+	 (let ((code (code-object-from-bits
+		      (alien-access (mach:int-array-ref regs vm::code-offset)))))
+	   (when (symbolp code)
+	     (return (values code 0 (alien-value sc))))
+	   (let* ((code-header-len (* (get-header-data code) vm:word-bytes))
+		  (pc-offset
+		   (- (sap-int (alien-access
+				(mach:sigcontext-pc (alien-value sc))))
+		      (- (get-lisp-obj-address code) vm:other-pointer-type)
+		      code-header-len)))
+	     ;; Check to see if we were executing in a branch delay slot.
+	     #+pmax  ; pmax only
+	     (when (logbitp 31 (alien-access
+				(mach:sigcontext-cause (alien-value sc))))
+	       (incf pc-offset vm:word-bytes))
+	     (unless (<= 0 pc-offset
+			 (* (truly-the lisp::index
+				       (%primitive c::code-code-size code))
+			    vm:word-bytes))
+	       ;; We were in an assembly routine.  Therefore, use the LRA as
+	       ;; the pc.
+	       (setf pc-offset
+		     (- (escape-register (alien-value sc) vm::lra-offset)
+			(get-lisp-obj-address code)
+			code-header-len)))
+	     (return
+	      (if (eq (code-debug-info code) :bogus-lra)
+		  (let ((real-lra (kernel:code-header-ref code real-lra-slot)))
+		    (values (lra-code-header real-lra)
+			    (get-header-data real-lra)
+			    nil))
+		  (values code pc-offset (alien-value sc)))))))))))
+
+;;; CODE-OBJECT-FROM-BITS  --  internal.
+;;;
+;;; Find the code object corresponding to the object represented by bits and
+;;; return it.  We assume bogus functions correspond to the
+;;; undefined-function.
+;;; 
+(defun code-object-from-bits (bits)
+  (declare (type (unsigned-byte 32) bits))
+  (let ((object (make-lisp-obj bits)))
+    (if (functionp object)
+	(or (function-code-header object)
+	    :undefined-function)
+	(let ((lowtag (get-lowtag object)))
+	  (if (= lowtag vm:other-pointer-type)
+	      (let ((type (get-type object)))
+		(cond ((= type vm:code-header-type)
+		       object)
+		      ((= type vm:return-pc-header-type)
+		       (lra-code-header object))
+		      (t
+		       nil))))))))
 
 ;;;
 ;;; Frame utilities.
@@ -1151,32 +1166,32 @@
 ;;;
 (defun debug-function-from-pc (component pc)
   (let ((info (code-debug-info component)))
-    (unless info
+    (cond
+     ((not info)
       (debug-signal 'no-debug-info))
-    (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 (c::compiled-debug-function-elsewhere-pc
-			 (svref function-map 0)))))
-	    (declare (type c::index i))
-	    (loop
-	      (when (or (= i len)
-			(< pc (if elsewhere-p
-				  #+rt-target
-				  (1+ (c::compiled-debug-function-elsewhere-pc
-				       (svref function-map (1+ i))))
-				  #-rt-target
-				  (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)))))))
+     ((eq info :bogus-lra)
+      (make-bogus-debug-function "Function End Breakpoint"))
+     (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 (c::compiled-debug-function-elsewhere-pc
+			   (svref function-map 0)))))
+	      (declare (type c::index i))
+	      (loop
+		(when (or (= i len)
+			  (< pc (if elsewhere-p
+				    (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)))))))))
 
 ;;; CODE-LOCATION-FROM-PC -- Internal.
 ;;;
@@ -1203,10 +1218,7 @@
    frame if someone threw to the corresponding tag."
   (let ((catch (int-sap (* lisp::*current-catch-block* vm:word-bytes)))
 	(res nil)
-	(fp (etypecase frame
-	      (compiled-frame (frame-pointer frame))
-	      (interpreted-frame (frame-pointer
-				  (interpreted-frame-real-frame frame))))))
+	(fp (frame-pointer (frame-real-frame frame))))
     (loop
       (when (eql catch 0) (return (nreverse res)))
       (when (eq fp (stack-ref catch vm:catch-block-current-cont-slot))
@@ -1219,6 +1231,15 @@
 		res)))
       (setf catch (stack-ref catch vm:catch-block-previous-catch-slot)))))
 
+;;; FRAME-REAL-FRAME -- Internal.
+;;;
+;;; 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))))
+
 
 
 ;;;; Debug-functions.
@@ -1304,11 +1325,26 @@
 	(make-interpreted-debug-function
 	 (or (eval::eval-function-definition eval-fun)
 	     (eval::convert-eval-fun eval-fun))))
-      (let ((code (function-code-header fun)))
-	(debug-function-from-pc
-	 code
-	 (* (- (function-word-offset fun) (get-header-data code))
-	    vm:word-bytes)))))
+      (let* ((name (%primitive c::function-name fun))
+	     (component (function-code-header fun))
+	     (res (find-if
+		   #'(lambda (x)
+		       (and (c::compiled-debug-function-p x)
+			    (eq (c::compiled-debug-function-name x) name)
+			    (eq (c::compiled-debug-function-kind x) nil)))
+		   (get-debug-info-function-map
+		    (code-debug-info component)))))
+	(if res
+	    (make-compiled-debug-function res component)
+	    ;; 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.
+	    (debug-function-from-pc component
+				    (* (- (function-word-offset fun)
+					  (get-header-data component))
+				       vm:word-bytes))))))
 
 
 ;;; DEBUG-FUNCTION-KIND -- Public.
@@ -1840,9 +1876,9 @@
     vars))
 
 
-;;; ASSIGN-MINIMAL-VAR-NAMES  --  Internal
+;;; ASSIGN-MINIMAL-VAR-NAMES -- Internal.
 ;;;
-;;;    Vars is the parsed variables for a minimal debug function.  We need to
+;;; 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.
 ;;;
@@ -1861,12 +1897,10 @@
 ;;; debug-function's c::compiled-debug-function.
 ;;;
 (defun parse-compiled-debug-variables (debug-function)
-  (let* ((debug-fun
-	  (compiled-debug-function-compiler-debug-fun debug-function))
+  (let* ((debug-fun (compiled-debug-function-compiler-debug-fun debug-function))
 	 (packed-vars (c::compiled-debug-function-variables debug-fun))
-	 (default-package
-	  (c::compiled-debug-info-package
-	   (compiled-debug-function-debug-info debug-function)))
+	 (default-package (c::compiled-debug-info-package
+			   (compiled-debug-function-debug-info debug-function)))
 	 (args-minimal (eq (c::compiled-debug-function-arguments debug-fun)
 			   :minimal)))
     (unless packed-vars
@@ -1917,11 +1951,14 @@
 	  res)))))
 
 
-;;;; Unpacking minimal debug functions:
+;;;; Unpacking minimal debug functions.
 
 (eval-when (compile eval)
+
+;;; MAKE-UNCOMPACTED-DEBUG-FUN -- Internal.
+;;;
+;;; Sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP.
 ;;;
-;;; Sleazoid "macro" to keep our indentation sane...
 (defmacro make-uncompacted-debug-fun ()
   '(c::make-compiled-debug-function
     :name
@@ -1970,7 +2007,7 @@
     :elsewhere-pc
     (setq elsewhere-pc (+ elsewhere-pc (c::read-var-integer map i)))))
 
-); eval-when (compile eval)
+) ;EVAL-WHEN (compile eval)
 
 ;;; UNCOMPACT-FUNCTION-MAP  --  Internal
 ;;;
@@ -2730,7 +2767,7 @@
   ;;
   ;; Get to the form indicated by path or the enclosing form indicated by
   ;; context and path.
-  (let ((path (nreverse (butlast (cdr path)))))
+  (let ((path (reverse (butlast (cdr path)))))
     (dotimes (i (- (length path) context))
       (setq form (elt form (first path)))
       (setq path (rest path)))
@@ -2760,15 +2797,18 @@
 ;;; accesses that variable from the frame argument.
 ;;;
 (defun preprocess-for-eval (form loc)
-  "Return a function of one argument that will evaluate Form in the lexical
-   context of the Basic-Code-Location Loc.  The function take the frame to get
-   values from as its argument, and returns the values of Form."
+  "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-variables condition when the loc's debug-function has no
+   debug-variable 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)))
     (unless (debug-variable-info-available fun)
       (debug-signal 'no-debug-variables :debug-function fun))
-
     (ext:collect ((binds)
 		  (specs))
       (do-debug-function-variables (var fun)
@@ -2779,7 +2819,6 @@
 	      (if found
 		  (setf (second found) :ambiguous)
 		  (binds (list sym validity var)))))))
-
       (dolist (bind (binds))
 	(let ((name (first bind))
 	      (var (third bind)))
@@ -2787,26 +2826,22 @@
 	    (:valid
 	     (specs `(,name (debug-variable-value ',var ,n-frame))))
 	    (:unknown
-	     (specs `(,name
-		      (debug-signal 'invalid-value
-				    :debug-variable ',var
-				    :frame ,n-frame))))
+	     (specs `(,name (debug-signal 'invalid-value :debug-variable ',var
+					  :frame ,n-frame))))
 	    (:ambiguous
-	     (specs `(,name
-		      (debug-signal 'ambiguous-variable-name
-				    :name ',name
-				    :frame ,n-frame)))))))
-
+	     (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
+					  :frame ,n-frame)))))))
       (let ((res (coerce `(lambda (,n-frame)
 			    (declare (ext:ignorable ,n-frame))
-			    (symbol-macro-let ,(specs)
-			      ,form))
+			    (symbol-macro-let ,(specs) ,form))
 			 'function)))
 	#'(lambda (frame)
-	    (unless (code-location= (frame-code-location frame)
-				    loc)
+	    ;; This prevents these functions from use 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))
+			    :code-location loc :form form :frame frame))
 	    (funcall res frame))))))
 
 
@@ -2817,3 +2852,940 @@
   "Evaluate Form in the lexical context of Frame's current code location,
    returning the results of the evaluation."
   (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
+
+
+
+;;;; Breakpoints.
+
+;;;
+;;; User visible interface.
+;;;
+
+;;; This maps debug-functions, for which there are :function-end breakpoints,
+;;; to internal starter breakpoints that actually establish the :function-end
+;;; breakpoint upon entry to the routine.  We want these starter breakpoints to
+;;; be unique for every routine regardless of how many :function-end
+;;; breakpoints exist.  Otherwise, we can't support multiple :function-end
+;;; breakpoints.  These starter breakpoints' info slot points to a list of
+;;; :function-end breakpoints that use them, and upon deletion of the last such
+;;; breakpoint, we remove the starter from this table.
+;;;
+(defvar *function-end-debug-funs* (make-hash-table :test #'eq))
+
+(defun make-breakpoint (hook-function what
+			&key (kind :code-location) info function-end-cookie)
+  "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 an
+   additional argument, a list of values returned by the function.
+      Info is information supplied by and used by the user.
+      This signals an error if what is an unknown code-location."
+  (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)))
+       (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 kind info)))
+	      (setf (breakpoint-unknown-return-partner bpt) other-bpt)
+	      (setf (breakpoint-unknown-return-partner other-bpt) bpt)))))
+       bpt))
+    (compiled-debug-function
+     (ecase kind
+       (:function-start
+	(%make-breakpoint hook-function what kind info))
+       (:function-end
+	(let* ((bpt (%make-breakpoint hook-function what kind info))
+	       (starter (gethash what *function-end-debug-funs*)))
+	  (unless starter
+	    (setf starter (%make-breakpoint #'list what :function-start nil))
+	    (setf (breakpoint-hook-function starter)
+		  (function-end-starter-hook starter what))
+	    (setf (gethash what *function-end-debug-funs*) 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."))))
+
+;;; 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 when it is created.
+;;;
+(defstruct (function-end-cookie
+	    (:print-function (lambda (obj str n)
+			       (declare (ignore obj n))
+			       (write-string "#<Function-End-Cookie>" str)))))
+
+;;; This maps bogus-lra-components to cookies, so
+;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
+;;; breakpoint hook.
+;;;
+(defvar *function-end-cookies* (make-hash-table :test #'eq))
+
+;;; FUNCTION-END-STARTER-HOOK -- Internal.
+;;;
+;;; This returns a hook function for the start helper breakpoint associated
+;;; with a :function-end breakpoint.  The returned function makes a fake LRA
+;;; that all returns go through, and this piece of fake code actually breaks.
+;;; Upon return from the break, the code provides the returnee with any values.
+;;; Since the returned function effectively activates fun-end-bpt on each entry
+;;; to debug-fun's function, we must establish breakpoint-data about
+;;; fun-end-bpt.
+;;;
+(defun function-end-starter-hook (starter-bpt debug-fun)
+  (declare (type breakpoint starter-bpt)
+	   (type compiled-debug-function debug-fun))
+  #'(lambda (frame breakpoint)
+      (declare (ignore breakpoint)
+	       (type frame frame))
+      (let ((lra-sc-offset
+	     (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 vm::lra-save-offset
+						 lra-sc-offset))
+	  (setf (get-context-value frame vm::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-function-end-cookie)))
+	      (setf (gethash component *function-end-cookies*) cookie)
+	      (dolist (bpt end-bpts)
+		(let ((fun (breakpoint-cookie-fun bpt)))
+		  (when fun (funcall fun cookie))))))))))
+
+;;;
+;;; ACTIVATE-BREAKPOINT.
+;;;
+
+;;; ACTIVATE-BREAKPOINT -- Public.
+;;;
+(defun activate-breakpoint (breakpoint)
+  "This causes the system to invoke the breakpoint's hook-function until the
+   next call to DEACTIVATE-BREAKPOINT or DELETE-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 (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
+       (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)))))))
+  breakpoint)
+
+;;; ACTIVATE-COMPILED-CODE-LOCATION-BREAKPOINT -- Internal.
+;;;
+(defun activate-compiled-code-location-breakpoint (breakpoint)
+  (declare (type breakpoint breakpoint))
+  (let ((loc (breakpoint-what breakpoint)))
+    (sub-activate-breakpoint
+     breakpoint
+     (breakpoint-data (compiled-debug-function-component
+		       (code-location-debug-function loc))
+		      (compiled-code-location-pc loc)))))
+
+;;; ACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal.
+;;;
+(defun activate-compiled-function-start-breakpoint (breakpoint)
+  (declare (type breakpoint breakpoint))
+  (let ((debug-fun (breakpoint-what breakpoint)))
+    (sub-activate-breakpoint
+     breakpoint
+     (breakpoint-data (compiled-debug-function-component debug-fun)
+		      (c::compiled-debug-function-start-pc
+		       (compiled-debug-function-compiler-debug-fun
+			debug-fun))))))
+
+;;; SUB-ACTIVATE-BREAKPOINT -- Internal.
+;;;
+(defun sub-activate-breakpoint (breakpoint data)
+  (declare (type breakpoint breakpoint)
+	   (type breakpoint-data data))
+  (setf (breakpoint-status breakpoint) :active)
+  (system:without-interrupts
+   (unless (breakpoint-data-breakpoints data)
+     (setf (breakpoint-data-instruction data)
+	   (system:without-gcing
+	    (breakpoint_install (kernel:get-lisp-obj-address
+				 (breakpoint-data-component data))
+				(breakpoint-data-offset data)))))
+   (push breakpoint (breakpoint-data-breakpoints data))
+   (setf (breakpoint-internal-data breakpoint) data)))
+
+;;;
+;;; DEACTIVATE-BREAKPOINT.
+;;;
+
+;;; DEACTIVATE-BREAKPOINT -- Public.
+;;;
+(defun deactivate-breakpoint (breakpoint)
+  "This stops the system from invoking the breakpoint's hook-function."
+  (unless (eq (breakpoint-status breakpoint) :inactive)
+    (system:without-interrupts
+     (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
+	     (deactivate-compiled-code-location-breakpoint breakpoint)
+	     (let ((other (breakpoint-unknown-return-partner breakpoint)))
+	       (when other
+		 (deactivate-compiled-code-location-breakpoint other)))))))
+       (:function-start
+	(etypecase (breakpoint-what breakpoint)
+	  (compiled-debug-function
+	   (deactivate-compiled-function-start-breakpoint breakpoint))
+	  (interpreted-debug-function
+	   (error ":function-start breakpoints for interpreted-debug-functions ~
+		   are unsupported currently -- ~S."
+		  breakpoint))))
+       (:function-end
+	(etypecase (breakpoint-what breakpoint)
+	  (compiled-debug-function
+	   (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-function-start-breakpoint starter)))
+	   (setf (breakpoint-status breakpoint) :inactive))
+	  (interpreted-debug-function
+	   (error ":function-end breakpoints for interpreted-debug-functions ~
+		   are unsupported currently -- ~S."
+		  breakpoint)))))))
+  breakpoint)
+
+;;; DEACTIVATE-COMPILED-CODE-LOCATION-BREAKPOINT -- Internal.
+;;;
+(defun deactivate-compiled-code-location-breakpoint (breakpoint)
+  (declare (type breakpoint breakpoint))
+  (let* ((loc (breakpoint-what breakpoint))
+	 (component (compiled-debug-function-component
+		     (code-location-debug-function loc)))
+	 (offset (compiled-code-location-pc loc)))
+    (sub-deactivate-breakpoint breakpoint (breakpoint-data component offset)
+			       component offset)))
+
+;;; DEACTIVATE-COMPILED-FUNCTION-START-BREAKPOINT -- Internal.
+;;;
+(defun deactivate-compiled-function-start-breakpoint (breakpoint)
+  (declare (type breakpoint breakpoint))
+  (let* ((debug-fun (breakpoint-what breakpoint))
+	 (component (compiled-debug-function-component debug-fun))
+	 (offset (c::compiled-debug-function-start-pc
+		  (compiled-debug-function-compiler-debug-fun debug-fun))))
+    (sub-deactivate-breakpoint breakpoint (breakpoint-data component offset)
+			       component offset)))
+
+;;; SUB-DEACTIVATE-BREAKPOINT -- Internal.
+;;;
+(defun sub-deactivate-breakpoint (breakpoint data component offset)
+  (declare (type breakpoint breakpoint)
+	   (type breakpoint-data data)
+	   (type c::index offset))
+  (system:without-gcing
+   (breakpoint_remove (kernel:get-lisp-obj-address component)
+		      offset (breakpoint-data-instruction data)))
+  (setf (breakpoint-data-breakpoints data)
+	(delete breakpoint (breakpoint-data-breakpoints data)))
+  (setf (breakpoint-status breakpoint) :inactive))
+
+;;;
+;;; BREAKPOINT-INFO.
+;;;
+
+;;; BREAKPOINT-INFO -- Public.
+;;;
+(defun breakpoint-info (breakpoint)
+  "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))))
+;;;
+(defsetf breakpoint-info %set-breakpoint-info)
+
+;;;
+;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT.
+;;;
+
+;;; BREAKPOINT-ACTIVE-P -- Public.
+;;;
+(defun breakpoint-active-p (breakpoint)
+  "This returns whether breakpoint is currently active."
+  (ecase (breakpoint-status breakpoint)
+    (:active t)
+    ((:inactive :deleted) nil)))
+
+;;; DELETE-BREAKPOINT -- Public.
+;;;
+(defun delete-breakpoint (breakpoint)
+  "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)
+      (ecase status
+	(:active
+	 (setf (breakpoint-status breakpoint) :deleted)
+	 (deactivate-breakpoint breakpoint)
+	 (let ((other (breakpoint-unknown-return-partner breakpoint)))
+	   (when other
+	     (setf (breakpoint-status other) :deleted))))
+	(:inactive
+	 (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* ((debug-fun (breakpoint-what breakpoint))
+	       (starter (gethash debug-fun *function-end-debug-funs*)))
+	  (setf (breakpoint-info starter)
+		(delete breakpoint (the list (breakpoint-info starter))))
+	  (when (zerop (length (the list (breakpoint-%info starter))))
+	    (remhash debug-fun *function-end-debug-funs*))))))
+  breakpoint)
+
+;;;
+;;; C call out stubs.
+;;;
+
+;;; BREAKPOINT_INSTALL -- Internal.
+;;;
+;;; 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 Lisp doesn't move objects around that C is pointing to.
+;;;
+(ext:def-c-routine "breakpoint_install" (ext:unsigned-long)
+  (code-obj ext:unsigned-long)
+  (pc-offset ext:int))
+
+;;; BREAKPOINT_REMOVE -- Internal.
+;;;
+;;; 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.
+;;;
+(ext:def-c-routine "breakpoint_remove" (ext:void)
+  (code-obj ext:unsigned-long)
+  (pc-offset ext:int)
+  (old-inst ext:unsigned-long))
+
+;;; BREAKPOINT_AFTER_OFFSET -- Internal.
+;;;
+;;; This returns the offset of the next instruction following the break that
+;;; generated the signal context we supply as an argument to this routine.
+;;;
+(ext:def-c-routine "breakpoint_after_offset" (ext:int)
+  (scp system-area-pointer))
+
+;;;
+;;; 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))
+
+;;; BREAKPOINT-DATA -- Internal.
+;;;
+;;; This returns the breakpoint-data associated with component cross offset.
+;;; If none exists, this makes one, installs it, and returns it.
+;;;
+(defun breakpoint-data (component offset)
+  (flet ((install-breakpoint-data ()
+	   (let ((data (make-breakpoint-data component offset)))
+	     (push (cons offset data)
+		   (gethash component *component-breakpoint-offsets*))
+	     data)))
+    (let ((offsets (gethash component *component-breakpoint-offsets*)))
+      (if offsets
+	  (let ((data (assoc offset offsets)))
+	    (if data
+		(cdr data)
+		(install-breakpoint-data)))
+	  (install-breakpoint-data)))))
+
+;;; DELETE-BREAKPOINT-DATA -- Internal.
+;;;
+;;; We use this for :function-end breakpoints which use fake components that
+;;; exist only from the start of the function until we hit the end breakpoint.
+;;;
+(defun delete-breakpoint-data (data)
+  (setf (gethash (breakpoint-data-component data)
+		 *component-breakpoint-offsets*)
+	nil))
+
+;;; HANDLE-BREAKPOINT -- Internal Interface.
+;;;
+;;; The C handler for interrupts calls this when it has a debugging-tool break
+;;; instruction.  This does NOT handle all breaks; for example, it does not
+;;; handle breaks for internal errors.
+;;;
+(defun handle-breakpoint (offset component signal-context)
+  (let ((data (breakpoint-data component offset)))
+    (unless data
+      (error "Unknown breakpoint in ~S at offset ~S."
+	      (debug-function-name (debug-function-from-pc component offset))
+	      offset))
+    (let ((breakpoints (breakpoint-data-breakpoints data)))
+      (if (and breakpoints
+	       (eq (breakpoint-kind (car breakpoints)) :function-end))
+	  (handle-function-end-breakpoint breakpoints data signal-context)
+	  (handle-breakpoint-aux breakpoints data
+				 offset component signal-context)))))
+
+;;; HANDLE-BREAKPOINT-AUX -- Internal.
+;;;
+;;; This handles code-location and debug-function :function-start breakpoints.
+;;;
+(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
+  (let ((after (breakpoint-data-after-breakpoint data)))
+    (when after
+      (handle-after-breakpoint after breakpoints data offset component))
+    (when breakpoints
+      (invoke-breakpoint-hooks breakpoints component offset after)
+      ;; Restore instruction.  Do this before SET-AFTER-BREAKPOINTS which uses
+      ;; CALL-BREAKPOINT_AFTER_OFFSET.
+      (system:without-gcing
+       (breakpoint_remove (kernel:get-lisp-obj-address component) offset
+			  (breakpoint-data-instruction data)))
+      (set-after-breakpoints component data signal-context)
+      ;; Set the sigmask, to keep the system running until we can
+      ;; remove the after breakpoints and re-install the user breakpoints.
+      (setf (breakpoint-data-sigmask data)
+	    (mach:unix-sigblock (mach:sigmask :sigint :sigquit :sigtstp))))))
+
+(defun handle-after-breakpoint (after breakpoints data offset component)
+  (let ((previous-data (after-breakpoint-previous-data after)))
+    (unless (breakpoint-data-breakpoints previous-data)
+      (error "After-breakpoint found with no user breakpoints. -- ~s" after))
+    ;; If there are no user breakpoints at this after location, remove the
+    ;; break instruction.
+    (unless breakpoints
+      (system:without-gcing
+       (breakpoint_remove (kernel:get-lisp-obj-address component) offset
+			  (breakpoint-data-instruction data)))
+      (setf (breakpoint-data-after-breakpoint data) nil))
+    ;; Ditto for the partner of the after-breakpoint (if there were two).
+    (let ((partner (after-breakpoint-partner after)))
+      (when partner
+	(let ((partner-data (after-breakpoint-internal-data partner)))
+	  (unless (breakpoint-data-breakpoints partner-data)
+	    (system:without-gcing
+	     (breakpoint_remove (kernel:get-lisp-obj-address
+				 (breakpoint-data-component partner-data))
+				(breakpoint-data-offset partner-data)
+				(breakpoint-data-instruction partner-data)))
+	    (setf (breakpoint-data-after-breakpoint partner-data) nil)))))
+    ;; Put back previous's break instruction.
+    ;; We don't need to store the replaced instruction in the data since we
+    ;; have it from installing the break instruction before.
+    (system:without-gcing
+     (breakpoint_install (kernel:get-lisp-obj-address
+			  (breakpoint-data-component previous-data))
+			 (breakpoint-data-offset previous-data)))
+    ;; Restore sigmask that we saved before executing previous's inst.
+    (mach:unix-sigsetmask (breakpoint-data-sigmask previous-data))))
+
+(defun invoke-breakpoint-hooks (breakpoints component offset after)
+  (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)))) 
+    (if after
+	;; If there's an after-bpt here, and any breakpoint whose hook we
+	;; may invoke has an unknown-return-partner, then the after-bpt may
+	;; be for the unknown-return-partner.  This means we already ran
+	;; this breakpoint's hook when we hit its partner one instruction
+	;; previous.  don't invoke it twice for one virtual break.
+	(let ((previous-data (after-breakpoint-previous-data after)))
+	  (dolist (bpt breakpoints)
+	    (let ((partner (breakpoint-unknown-return-partner bpt)))
+	      (unless (and partner
+			   (eq (breakpoint-internal-data partner) previous-data))
+		(funcall (breakpoint-hook-function bpt) frame bpt)))))
+	(dolist (bpt breakpoints)
+	  (funcall (breakpoint-hook-function bpt) frame bpt)))))
+
+(defun set-after-breakpoints (component data signal-context)
+  (multiple-value-bind (after-1 after-2)
+		       (call-breakpoint_after_offset signal-context)
+    (let* ((after-data-1 (breakpoint-data component after-1))
+	   (after-data-2 (if (not (zerop after-2))
+			     (breakpoint-data component after-2)))
+	   (after-bpt-1 (make-after-breakpoint data after-data-1)))
+      (setf (breakpoint-data-after-breakpoint after-data-1) after-bpt-1)
+      (when after-data-2
+	;; Set after-bpt-1's partner to an after-breakpoint.
+	(setf (after-breakpoint-partner after-bpt-1)
+	      ;; While making it, store it in the appropriate data obj.
+	      (setf (breakpoint-data-after-breakpoint after-data-2)
+		    (make-after-breakpoint data after-data-2 after-bpt-1))))
+      (system:without-gcing
+       (unless (breakpoint-data-breakpoints after-data-1)
+	 (setf (breakpoint-data-instruction after-data-1)
+	       (breakpoint_install (kernel:get-lisp-obj-address component)
+				   after-1)))
+       (when (and after-data-2 (not (breakpoint-data-breakpoints after-data-2)))
+	 (setf (breakpoint-data-instruction after-data-2)
+	       (breakpoint_install (kernel:get-lisp-obj-address component)
+				   after-2)))))))
+
+;;; HANDLE-FUNCTION-END-BREAKPOINT -- Internal.
+;;;
+;;; HANDLE-BREAKPOINT calls this for :function-end breakpoints.
+;;;
+(defun handle-function-end-breakpoint (breakpoints data signal-context)
+  (delete-breakpoint-data data)
+  (system:alien-bind ((sc (system:make-alien 'mach:sigcontext
+					     #.(c-sizeof 'mach:sigcontext)
+					     signal-context)
+			  mach:sigcontext
+			  t))
+    (let* ((frame (do ((cfp (escape-register sc vm::cfp-offset))
+		       (f (top-frame) (frame-down f)))
+		      ((= cfp (system:sap-int (frame-pointer f))) f)
+		    (declare (type (unsigned-byte #.vm:word-bits) cfp))))
+	   (component (breakpoint-data-component data))
+	   (cookie (gethash component *function-end-cookies*)))
+      (remhash component *function-end-cookies*)
+      (dolist (bpt breakpoints)
+	(funcall (breakpoint-hook-function bpt)
+		 frame bpt
+		 (get-function-end-breakpoint-values (system:alien-value sc))
+		 cookie)))))
+
+(defun get-function-end-breakpoint-values (sc)
+  (system:alien-bind ((sc sc mach:sigcontext t))
+    (let ((ocfp (int-sap (escape-register sc vm::ocfp-offset)))
+	  (nargs (make-lisp-obj (escape-register sc vm::nargs-offset)))
+	  (reg-arg-offsets vm::register-arg-offsets)
+	  (results nil))
+      (without-gcing
+       (dotimes (arg-num nargs)
+	 (push (if reg-arg-offsets
+		   (make-lisp-obj (escape-register sc (pop reg-arg-offsets)))
+		   (stack-ref ocfp arg-num))
+	       results)))
+      (nreverse results))))
+
+
+;;; CALL-BREAKPOINT_AFTER_OFFSET -- Internal.
+;;;
+;;; This calls the C routine and massages its return values.  Originally the
+;;; breakpoint code was designed for the C code to return multiple offsets when
+;;; the break generating the argument signal-context had replaced a branch
+;;; instruction.  The Lisp code would then set after-breakpoints at each
+;;; location, cleaning up both when one was hit after continuing execution.
+;;; Later the C code decided it could determine which way the branch would go,
+;;; so BREAKPOINT_AFTER_OFFSET could just return one offset.  In case this
+;;; won't be possible on all platforms, the Lisp code will stay with its
+;;; support for multiple after-breakpoints.  Then we only need to change this
+;;; routine to return all values of BREAKPOINT_AFTER_OFFSET.
+;;;
+(defun call-breakpoint_after_offset (signal-context)
+  (values (breakpoint_after_offset signal-context) 0))
+
+;;;
+;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
+;;;
+
+(defconstant bogus-lra-constants 2)
+(defconstant known-return-p-slot (+ vm:code-constants-offset 1))
+
+;;; MAKE-BOGUS-LRA -- Interface.
+;;;
+(defun make-bogus-lra (real-lra &optional known-return-p)
+  "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."
+  (system:without-gcing
+   (let* ((src-start (ext:truly-the system-area-pointer
+				    (system:%primitive
+				     c:foreign-symbol-address
+				     "function_end_breakpoint_guts")))
+	  (src-end (ext:truly-the system-area-pointer
+				  (system:%primitive
+				   c:foreign-symbol-address
+				   "function_end_breakpoint_end")))
+	  (trap-loc (ext:truly-the system-area-pointer
+				   (system:%primitive
+				    c:foreign-symbol-address
+				    "function_end_breakpoint_trap")))
+	  (length (sap- src-end src-start))
+	  (code-object (system:%primitive c:allocate-code-object
+					  (1+ bogus-lra-constants)
+					  length))
+	  (dst-start (kernel:code-instructions code-object)))
+     (declare (type system-area-pointer src-start src-end dst-start trap-loc)
+	      (type kernel:index length))
+     (setf (kernel:code-header-ref code-object vm:code-debug-info-slot)
+	   :bogus-lra)
+     (setf (kernel:code-header-ref code-object vm:code-trace-table-offset-slot)
+	   length)
+     (setf (kernel:code-header-ref code-object real-lra-slot) real-lra)
+     (setf (kernel:code-header-ref code-object known-return-p-slot)
+	   known-return-p)
+     (kernel:system-area-copy src-start 0 dst-start 0 (* length vm:byte-bits))
+     (let ((new-lra (kernel:make-lisp-obj (+ (system:sap-int dst-start)
+					     vm:other-pointer-type))))
+       (kernel:set-header-data
+	new-lra
+	(logandc2 (+ vm:code-constants-offset bogus-lra-constants 1)
+		  1))
+       (values new-lra code-object (system:sap- trap-loc src-start))))))
+
+
+
+;;;; Editor support.
+
+;;; This holds breakpoints in the slave set on behalf of the editor.
+;;;
+;(defvar *editor-breakpoints* (make-hash-table :test #'equal))
+
+;;;
+;;; Setting breakpoints.
+;;;
+
+;;; SET-BREAKPOINT-FOR-EDITOR -- Internal Interface.
+;;;
+(defun set-breakpoint-for-editor (package name-str path)
+  "The editor calls this remotely in the slave to set breakpoints.  Package is
+   the string name of a package or nil, and name-str is a string representing a
+   function name (for example, \"foo\" or \"(setf foo)\").  After finding
+   package, this READs name-str with *package* bound appropriately.  Path is
+   either a modified source-path or a symbol (:function-start or
+   :function-end).  If it is a modified source-path, it has no top-level-form
+   offset or form-number component, and it is in descent order from the root of
+   the top-level form."
+  (let* ((name (let ((*package* (if package
+				    (lisp::package-or-lose package)
+				    *package*)))
+		 (read-from-string name-str)))
+	 (debug-fun (function-debug-function (fdefinition name))))
+    (etypecase path
+      (symbol
+       (let* ((bpt (di:make-breakpoint
+		    #'(lambda (frame bpt)
+			(declare (ignore frame bpt))
+			(break "Editor installed breakpoint."))
+		    debug-fun :kind path))
+	      (remote-bpt (wire:make-remote-object bpt)))
+	 (activate-breakpoint bpt)
+	 ;;(push remote-bpt (gethash name *editor-breakpoints*))
+	 remote-bpt))
+      (cons
+       (etypecase debug-fun
+	 (compiled-debug-function
+	  (compiled-debug-function-set-breakpoint-for-editor
+	   debug-fun #|name|# path))
+	 (interpreted-debug-function
+	  (error
+	   "We don't currently support breakpoints in interpreted code.")))))))
+
+(defun compiled-debug-function-set-breakpoint-for-editor (debug-fun #|name|# path)
+  (let* ((source-paths (generate-component-source-paths
+			(compiled-debug-function-component debug-fun)))
+	 (matches nil)
+	 (matching-length 0))
+    (declare (simple-vector source-paths)
+	     (list matches)
+	     (fixnum matching-length))
+    ;; Build a list of paths that match path up to matching-length
+    ;; elements.
+    (macrolet ((maybe-store-match (path matched-len)
+		 `(cond ((> ,matched-len matching-length)
+			 (setf matches (list ,path))
+			 (setf matching-length ,matched-len))
+			((= ,matched-len matching-length)
+			 (cons ,path matches)))))
+      (dotimes (i (length source-paths))
+	(declare (fixnum i))
+	(let ((sp (svref source-paths i)))
+	  ;; Remember, first element of sp is a code-location.
+	  (do ((path-ptr path (cdr path-ptr))
+	       (sp-ptr (cdr sp) (cdr sp-ptr))
+	       (count 0 (1+ count)))
+	      ((or (null path-ptr) (null sp-ptr))
+	       (when (null sp-ptr)
+		 (maybe-store-match sp count)))
+	    (declare (list sp-ptr path-ptr)
+		     (fixnum count))
+	    (unless (= (the fixnum (car path-ptr)) (the fixnum (car sp-ptr)))
+	      (maybe-store-match sp count))))))
+    ;; If there's just one, set it; otherwise, return the conflict set.
+    (cond ((and (= (length matches) 1) (equal path (cdar matches)))
+	   (let* ((bpt (make-breakpoint
+			#'(lambda (frame bpt)
+			    (declare (ignore frame bpt))
+			    (break "Editor installed breakpoint."))
+			(wire:remote-object-value (caar matches))))
+		  (remote-bpt (wire:make-remote-object bpt)))
+	     (activate-breakpoint bpt)
+	     ;;(push remote-bpt (gethash name *editor-breakpoints*))
+	     remote-bpt))
+	  (t matches))))
+
+;;; This maps components to vectors of modified source-paths.  We assume users
+;;; will set multiple breakpoints in a given function which entails computing
+;;; this data repeatedly.  Possibly the GC hook should free this cache.  The
+;;; source-paths are modified in the following ways:
+;;;    1] The form number element (first) is clobbered with the code-location
+;;;       corresponding to the source-path.
+;;;    2] The top-level-form offset element (last) is thrown away.
+;;;    3] Everything after the first element is reversed, so the modified
+;;;       source-path actually portrays a descent into the form.
+;;;
+(defvar *component-source-locations* (make-hash-table :test #'eq))
+
+;;; GENERATE-COMPONENT-SOURCE-PATHS -- Internal.
+;;;
+;;; This returns a vector of modified source-paths, one for every code-location
+;;; in component.  The source-paths are modified as described for
+;;; *component-source-locations*.
+;;;
+(defun generate-component-source-paths (component)
+  (or (gethash component *component-source-locations*)
+      (setf (gethash component *component-source-locations*)
+	    (sub-generate-component-source-paths component))))
+
+;;; This maps source-infos to hashtables that map top-level-form offsets to
+;;; modified form-number translations (as returned by
+;;; FORM-NUMBER-TRANSLATIONS).  These are modified as described for
+;;; *component-source-locations*.
+;;;
+(defvar *source-info-offset-translations* (make-hash-table :test #'eq))
+
+;;; This is a hacking space for SUB-GENERATE-COMPONENT-SOURCE-PATHS.  We use
+;;; this because we throw away many source-paths we accumulate in this buffer
+;;; since they are not associated with code-locations.
+;;;
+(defvar *source-paths-buffer* (make-array 50 :fill-pointer t :adjustable t))
+
+;;; SUB-GENERATE-COMPONENT-SOURCE-PATHS -- Internal.
+;;;
+;;; We iterate over the code-locations in component, fetching their
+;;; source-infos and using the *source-info-offset-translations* cache.  This
+;;; computation often repeatedly sees the same source-info/tlf-offset pair, so
+;;; we see many source-paths from one form-number-translation table.  Because
+;;; of this, when we add a form-number-translations table to this cache, we add
+;;; all the source-paths in it to the result immediately.  Then later if we see
+;;; the same (not EQ though) source-info/tlf-offset form-number-translations,
+;;; we can simply check if one of the source-paths is already in the result,
+;;; and if it is, then all of them already are.  We keep the cache around
+;;; between invocations since we expect multiple breakpoints to be set in the
+;;; same function, and this is why we must check if a form-number-translations
+;;; has been added to the result; just its presence in the cache does not mean
+;;; it is in the result vector.
+;;;
+(defun sub-generate-component-source-paths (component)
+  (let ((info (code-debug-info component)))
+    (unless info (debug-signal 'no-debug-info))
+    (let* ((function-map (get-debug-info-function-map info))
+	   (result *source-paths-buffer*))
+      (declare (simple-vector function-map)
+	       (vector result))
+      (setf (fill-pointer result) 0)
+      (flet ((copy-stuff (form-num-trans result)
+	       (declare (simple-vector form-num-trans)
+			(vector result))
+	       (dotimes (i (length form-num-trans))
+		 (declare (fixnum i))
+		 (vector-push-extend (svref form-num-trans i) result)))
+	     (convert-paths (form-num-trans)
+	       (declare (simple-vector form-num-trans))
+	       (dotimes (i (length form-num-trans) form-num-trans)
+		 (declare (fixnum i))
+		 (let* ((source-path (svref form-num-trans i)))
+		   (declare (list source-path))
+		   ;; Make the first cons point to the reversal of everything
+		   ;; else, but throw away what was the last element before the
+		   ;; reversal.
+		   (setf (cdr source-path)
+			 ;; Must copy the rest of the list, so REVERSE, but
+			 ;; the first cons cell of each list is unique.
+			 (cdr (reverse (cdr source-path))))))))
+	;; Get all possible source-paths, modifying any new additions to the
+	;; cache.
+	(do ((i 0 (+ i 2))
+	     (len (length function-map)))
+	    ((>= i len))
+	  (declare (type c::index i))
+	  (let ((d-fun (make-compiled-debug-function (svref function-map i)
+						     component)))
+	    (do-blocks (d-block d-fun)
+	      (do-debug-block-locations (loc d-block)
+		(let* ((d-source (code-location-debug-source loc))
+		       (translations (gethash d-source
+					      *source-info-offset-translations*))
+		       (tlf-offset (code-location-top-level-form-offset loc))
+		       (loc-num (code-location-form-number loc)))
+		  (cond
+		   (translations
+		    (let ((form-num-trans (gethash tlf-offset translations)))
+		      (declare (type (or simple-vector null) form-num-trans))
+		      (cond
+		       ((not form-num-trans)
+			(let ((form-num-trans (get-form-number-translations
+					       d-source tlf-offset)))
+			  (declare (simple-vector form-num-trans))
+			  (setf (gethash tlf-offset translations) form-num-trans)
+			  (copy-stuff (convert-paths form-num-trans) result)
+			  (setf (car (svref form-num-trans loc-num))
+				(wire:make-remote-object loc))))
+		       ;; If one of these source-paths is in our result, then
+		       ;; they all are.
+		       ((find (svref form-num-trans 0) result :test #'eq)
+			(setf (car (svref form-num-trans loc-num))
+			      (wire:make-remote-object loc)))
+		       ;; Otherwise, store these source-paths in the result.
+		       (t
+			(copy-stuff form-num-trans result)
+			(setf (car (svref form-num-trans loc-num))
+			      (wire:make-remote-object loc))))))
+		   (t
+		    (let ((translations (make-hash-table :test #'eq))
+			  (form-num-trans (get-form-number-translations
+					   d-source tlf-offset)))
+		      (declare (simple-vector form-num-trans))
+		      (setf (gethash d-source *source-info-offset-translations*)
+			    translations)
+		      (setf (gethash tlf-offset translations) form-num-trans)
+		      (copy-stuff (convert-paths form-num-trans) result)
+		      (setf (car (svref form-num-trans loc-num))
+			    (wire:make-remote-object loc)))))))))))
+      ;; Copy source-paths with code-locations from the result buffer to a
+      ;; real result vector.
+      (let* ((count (count-if #'(lambda (x) (wire:remote-object-p (car x)))
+			      result))
+	     (the-real-thing (make-array count))
+	     (i -1))
+	(declare (simple-vector the-real-thing)
+		 (fixnum i count))
+	(dotimes (j count)
+	  (loop (when (wire:remote-object-p (car (aref result (incf i))))
+		  (return)))
+	  (setf (svref the-real-thing j) (aref result i)))
+	the-real-thing))))
+
+;;; GET-FORM-NUMBER-TRANSLATIONS -- Internal.
+;;;
+;;; This returns a vector of form-number translations to source-paths for
+;;; d-source and the top-level-form indicated by the top-level-form offset.
+;;;
+(defun get-form-number-translations (d-source tlf-offset)
+  (let ((name (debug-source-name d-source)))
+    (ecase (debug-source-from d-source)
+      (:file
+       (cond
+	((not (probe-file name))
+	 (format t "~%Cannot set breakpoints for editor when source file no ~
+		    longer exists:~%  ~A."
+		 (namestring name)))
+	(t
+	 (let* ((local-tlf-offset (- tlf-offset
+				     (debug-source-root-number d-source)))
+		(char-offset
+		 (aref (or (debug-source-start-positions d-source)
+			   (error "Cannot set breakpoints for editor when ~
+				   there is no start positions map."))
+		       local-tlf-offset)))
+	   (with-open-file (f name)
+	     (cond
+	      ((= (debug-source-created d-source) (file-write-date name))
+	       (file-position f char-offset))
+	      (t
+	       (format t
+		       "~%While setting a breakpoint for the editor, noticed ~
+			source file has been modified since compilation:~%  ~A~@
+			Using form offset instead of character position.~%"
+		       (namestring name))
+	       (dotimes (i local-tlf-offset) (read f))))
+	     (form-number-translations (read f) tlf-offset))))))
+      ((:lisp :stream)
+       (form-number-translations (svref name tlf-offset) tlf-offset)))))
+
+;;; SET-LOCATION-BREAKPOINT-FOR-EDITOR -- Internal Interface.
+;;;
+(defun set-location-breakpoint-for-editor (remote-obj-loc)
+  "The editor calls this in the slave with a remote-object representing a
+   code-location to set a breakpoint."
+  (let ((loc (wire:remote-object-value remote-obj-loc)))
+    (etypecase loc
+      (interpreted-code-location
+       (error "Breakpoints in interpreted code are currently unsupported."))
+      (compiled-code-location
+       (let* ((bpt (make-breakpoint #'(lambda (frame bpt)
+					(declare (ignore frame bpt))
+					(break "Editor installed breakpoint."))
+				    loc))
+	      (remote-bpt (wire:make-remote-object bpt)))
+	 (activate-breakpoint bpt)
+	 ;;(push remote-bpt (gethash name *editor-breakpoints*))
+	 remote-bpt)))))
+
+;;;
+;;; Deleting breakpoints.
+;;;
+
+;;; DELETE-BREAKPOINT-FOR-EDITOR -- Internal Interface.
+;;;
+(defun delete-breakpoint-for-editor (remote-obj-bpt)
+  "The editor calls this remotely in the slave to delete a breakpoint."
+  (delete-breakpoint (wire:remote-object-value remote-obj-bpt))
+  (wire:forget-remote-translation remote-obj-bpt))
-- 
GitLab