diff --git a/code/debug-int.lisp b/code/debug-int.lisp index 4feb0fd3e99558b0dde18164b20edd45b008fa3c..4596eb3aa66efb3d9e1915ca9d31b589f83738c5 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))