From: Nikodemus Siivola Date: Mon, 13 Sep 2004 07:14:35 +0000 (+0000) Subject: 0.8.14.13: Step SBCL, step! X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8a8a8922802460741d6f8f6c11d71b1f414cf3a7;p=sbcl.git 0.8.14.13: Step SBCL, step! * Merge the new intrumentation based single stepper, excise stale breakpoint code for STEP; TRACE breakpoints should be unaffected. * A dash of documentation. --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 3d7eb1e..441e757 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -476,6 +476,7 @@ ("src/compiler/ir1tran") ("src/compiler/ir1tran-lambda") ("src/compiler/ir1-translators") + ("src/compiler/ir1-step") ("src/compiler/ir1util") ("src/compiler/ir1report") ("src/compiler/ir1opt") diff --git a/contrib/sb-aclrepl/toplevel.lisp b/contrib/sb-aclrepl/toplevel.lisp index 36c36da..316c8fb 100644 --- a/contrib/sb-aclrepl/toplevel.lisp +++ b/contrib/sb-aclrepl/toplevel.lisp @@ -1,7 +1,7 @@ (cl:defpackage :sb-aclrepl (:use "COMMON-LISP" "SB-EXT") (:shadowing-import-from "SB-IMPL" "SCRUB-CONTROL-STACK") - (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*") + (:shadowing-import-from "SB-INT" "*REPL-PROMPT-FUN*" "*REPL-READ-FORM-FUN*" "*STEP*" "*STEPPING*") (:export ;; user-level customization of UI "*PROMPT*" "*EXIT-ON-EOF*" "*MAX-HISTORY*" @@ -38,7 +38,11 @@ (multiple-value-bind (reason reason-param) (catch 'repl-catcher (loop - (rep-one))) + (unwind-protect + (rep-one) + ;; reset toplevel step-condition handler + (setf *step* nil + *stepping* nil)))) (declare (ignore reason-param)) (cond ((and (eq reason :inspect) diff --git a/doc/manual/debugger.texinfo b/doc/manual/debugger.texinfo index 8f6cdf5..3e639d4 100644 --- a/doc/manual/debugger.texinfo +++ b/doc/manual/debugger.texinfo @@ -35,6 +35,7 @@ indistinguishable from interpreted code debugging. * Exiting Commands:: * Information Commands:: * Function Tracing:: +* Single Stepping:: @end menu @node Starting the Debugger @@ -900,7 +901,7 @@ Level @code{1} plus all interned local variables, source location information, and lifetime information that tells the debugger when arguments are available (even when @code{speed} is @code{3} or the argument is set). - + @item > 2 Any level greater than @code{2} gives level @code{2} and in addition disables tail-call optimization, so that the backtrace will contain @@ -918,6 +919,10 @@ If @code{debug} is greater than both @code{speed} and @code{space}, the command @command{return} can be used to continue execution by returning a value from the current stack frame. +If @code{debug} is also at least 2, then the code is @emph{partially +steppable}. If @code{debug} is 3, the code is @emph{fully steppable}. +@xref{Single Stepping} for details. + @end table As you can see, if the @code{speed} quality is @code{3}, debugger performance is @@ -1006,16 +1011,15 @@ Displays all the frames from the current to the bottom. Only shows @var{n} frames if specified. The printing is controlled by @code{*debug-print-variable-alist*}. @end deffn -@comment FIXME (rudi 2004-03-31): sbcl doesn't support breakpoints -@comment and stepping as of version 0.8.9. The `list-locations' -@comment command works, but executing a function leads to an error -@comment when a breakpoint is hit. When stepping works, the -@comment commented-out section below should be reinstated and the -@comment example output updated to correspont to sbcl's behaviour. +@deffn {Debugger Command} step +Selects the @code{continue} restart if one exists and starts single stepping. +@xref{Single Stepping}. +@end deffn + +@c The new instrumentation based single stepper doesn't support +@c the following commands, but BREAKPOINT at least should be +@c resurrectable via (TRACE FOO :BREAK T). -@c @node Breakpoint Commands, , Information Commands, The Debugger -@c @comment node-name, next, previous, up -@c @section Breakpoint Commands @c @cindex Breakpoints @c SBCL supports setting of breakpoints inside compiled functions and @@ -1064,12 +1068,6 @@ Displays all the frames from the current to the bottom. Only shows @c is specified, delete all breakpoints. @c @end deffn -@c @deffn {Debugger Command} step -@c Step to the next possible breakpoint location in the current function. -@c This always steps over function calls, instead of stepping into them. -@c @end deffn - - @c @menu @c * Breakpoint Example:: @c @end menu @@ -1180,5 +1178,34 @@ function entry or exit. @comment 0.8.9) in a state of flux. When it's sorted out, revive the @comment cmucl documentation. +@node Single Stepping +@comment node-name, next, previous, up +@section Single Stepping +@cindex Stepper +@cindex Single Stepping + +SBCL includes an instrumentation based single-stepper for compiled +code, that can be invoked via the @code{step} macro, or from within +the debugger. @xref{Debugger Policy Control} for details on enabling +stepping for compiled code. + +Compiled code can be unsteppable, partially steppable, or fully steppable. + +@table @strong +@item Unsteppable +Single stepping is not possible. + +@item Partially steppable +Single stepping is possible at sequential function call granularity: +nested function calls cannot be stepped into, and no intermediate +values are available. + +@item Fully steppable +Single stepping is possible at individual function call argument +granularity, nested calls can be stepped into, and intermediate values +are available. + +@end table +@include macro-common-lisp-step.texinfo diff --git a/make-host-2.sh b/make-host-2.sh index 6f7faef..cbbfabe 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -71,6 +71,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (safety 2) (space 1) (speed 2) + (sb!c:insert-step-conditions 0) (sb!c::stack-allocate-dynamic-extent 3))))) (compile 'proclaim-target-optimization) (defun in-target-cross-compilation-mode (fun) diff --git a/make-target-2.sh b/make-target-2.sh index 6b3cd21..fc8aa53 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -28,7 +28,6 @@ echo //doing warm init ./src/runtime/sbcl \ --core output/cold-sbcl.core \ --sysinit /dev/null --userinit /dev/null <<-'EOF' || exit 1 - ;; Now that we use the compiler for macros, interpreted ;; /SHOW doesn't work until later in init. #+sb-show (print "/hello, world!") diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2bbeed6..484b83a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -258,6 +258,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "GET-VECTOR-SUBTYPE" "HALT" "IF-EQ" "INLINE-SYNTACTIC-CLOSURE-LAMBDA" + "INSERT-STEP-CONDITIONS" "INSTANCE-REF" "INSTANCE-SET" "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" "IR2-PHYSENV-NUMBER-STACK-P" @@ -688,6 +689,14 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "*ED-FUNCTIONS*" "*MODULE-PROVIDER-FUNCTIONS*" "WITH-TIMEOUT" "TIMEOUT" + + ;; stepping interface + "STEP-CONDITION" "STEP-FORM-CONDITION" + "STEP-VALUES-CONDITION" "STEP-VARIABLE-CONDITION" + "STEP-CONDITION-FORM" "STEP-CONDITION-SOURCE-PATH" + "STEP-CONDITION-PATHNAME" "STEP-CONDITION-RESULT" + "STEP-CONTINUE" "STEP-NEXT" "STEP-INTO" + "*STEPPER-HOOK*" ;; RUN-PROGRAM is not only useful for users, but also ;; useful to implement parts of SBCL itself, so we're @@ -746,6 +755,9 @@ retained, possibly temporariliy, because it might be used internally." ;; INFO stuff doesn't belong in a user-visible package, we ;; should be able to change it without apology. "*INFO-ENVIRONMENT*" + + ;; stepping control + "*STEPPING*" "*STEP*" "CLEAR-INFO" "COMPACT-INFO-ENVIRONMENT" "DEFINE-INFO-CLASS" "DEFINE-INFO-TYPE" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 1ade61d..1511705 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -1075,6 +1075,64 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) (reader-impossible-number-error-error condition)))))) (define-condition timeout (serious-condition) ()) + +;;; Single stepping conditions + +(define-condition step-condition () + ((form :initarg :form :reader step-condition-form)) + #!+sb-doc + (:documentation "Common base class of single-stepping conditions. +STEP-CONDITION-FORM holds a string representation of the form being +stepped.")) + +#!+sb-doc +(setf (fdocumentation 'step-condition-form 'function) + "Form associated with the STEP-CONDITION.") + +(define-condition step-form-condition (step-condition) + ((source-path :initarg :source-path :reader step-condition-source-path) + (pathname :initarg :pathname :reader step-condition-pathname)) + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information when about to execute a form. +STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the +pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH +holds the source-path to the original form within that file or NIL. +Associated with this condition are always the restarts STEP-INTO, +STEP-NEXT, and STEP-CONTINUE.")) + +#!+sb-doc +(setf (fdocumentation 'step-condition-source-path 'function) + "Source-path of the original form associated with the +STEP-FORM-CONDITION or NIL." + (fdocumentation 'step-condition-pathname 'function) + "Pathname of the original source-file associated with the +STEP-FORM-CONDITION or NIL.") + +(define-condition step-result-condition (step-condition) + ((result :initarg :result :reader step-condition-result))) + +#!+sb-doc +(setf (fdocumentation 'step-condition-result 'function) + "Return values associated with STEP-VALUES-CONDITION as a list, +or the variable value associated with STEP-VARIABLE-CONDITION.") + +(define-condition step-values-condition (step-result-condition) + () + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information after executing a form. +STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds +the values returned by the form as a list. No associated restarts.")) + +(define-condition step-variable-condition (step-result-condition) + () + #!+sb-doc + (:documentation "Condition signalled by code compiled with +single-stepping information when referencing a variable. +STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds +the value of the variable. No associated restarts.")) + ;;;; restart definitions @@ -1116,5 +1174,26 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if none exists.")) +;;; single-stepping restarts + +(macrolet ((def (name doc) + #!-sb-doc (declare (ignore doc)) + `(defun ,name (condition) + #!+sb-doc ,doc + (invoke-restart (find-restart-or-control-error ',name condition))))) + (def step-continue + "Transfers control to the STEP-CONTINUE restart associated with +the condition, continuing execution without stepping. Signals a +CONTROL-ERROR if the restart does not exist.") + (def step-next + "Transfers control to the STEP-NEXT restart associated with the +condition, executing the current form without stepping and continuing +stepping with the next form. Signals CONTROL-ERROR is the restart does +not exists.") + (def step-into + "Transfers control to the STEP-INTO restart associated with the +condition, stepping into the current form. Signals a CONTROL-ERROR is +the restart does not exist.")) + (/show0 "condition.lisp end of file") diff --git a/src/code/debug.lisp b/src/code/debug.lisp index dd34fc4..a818d2b 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -121,19 +121,11 @@ Inspecting frames: PRINT, P displays current function call. SOURCE [n] displays frame's source form with n levels of enclosing forms. -Breakpoints and steps: - LIST-LOCATIONS [{function | :C}] List the locations for breakpoints. - Specify :C for the current frame. - Abbreviation: LL - LIST-BREAKPOINTS List the active breakpoints. - Abbreviations: LB, LBP - DELETE-BREAKPOINT [n] Remove breakpoint n or all breakpoints. - Abbreviations: DEL, DBP - BREAKPOINT {n | :end | :start} [:break form] [:function function] - [{:print form}*] [:condition form] - Set a breakpoint. - Abbreviations: BR, BP - STEP [n] Step to the next location or step n times. +Stepping: + STEP + [EXPERIMENTAL] Selects the CONTINUE restart if one exists and starts + single-stepping. Single stepping affects only code compiled with + under high DEBUG optimization quality. See User Manul for details. Function and macro commands: (SB-DEBUG:ARG n) @@ -151,119 +143,6 @@ Other commands: useful when the debugger was invoked to handle an error in deeply nested input syntax, and now the reader is confused.)") -;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint. -(define-condition step-condition (simple-condition) ()) - -;;;; breakpoint state - -(defvar *only-block-start-locations* nil - #!+sb-doc - "When true, the LIST-LOCATIONS command only displays block start locations. - Otherwise, all locations are displayed.") - -(defvar *print-location-kind* nil - #!+sb-doc - "When true, list the code location type in the LIST-LOCATIONS command.") - -;;; a list of the types of code-locations that should not be stepped -;;; to and should not be listed when listing breakpoints -(defvar *bad-code-location-types* '(:call-site :internal-error)) -(declaim (type list *bad-code-location-types*)) - -;;; code locations of the possible breakpoints -(defvar *possible-breakpoints*) -(declaim (type list *possible-breakpoints*)) - -;;; a list of the made and active breakpoints, each is a -;;; BREAKPOINT-INFO structure -(defvar *breakpoints* nil) -(declaim (type list *breakpoints*)) - -;;; a list of BREAKPOINT-INFO structures of the made and active step -;;; breakpoints -(defvar *step-breakpoints* nil) -(declaim (type list *step-breakpoints*)) - -;;; the number of times left to step -(defvar *number-of-steps* 1) -(declaim (type integer *number-of-steps*)) - -;;; This is used when listing and setting breakpoints. -(defvar *default-breakpoint-debug-fun* nil) -(declaim (type (or list sb!di:debug-fun) *default-breakpoint-debug-fun*)) - -;;;; code location utilities - -;;; Return the first code-location in the passed debug block. -(defun first-code-location (debug-block) - (let ((found nil) - (first-code-location nil)) - (sb!di:do-debug-block-locations (code-location debug-block) - (unless found - (setf first-code-location code-location) - (setf found t))) - first-code-location)) - -;;; Return a list of the next code-locations following the one passed. -;;; One of the *BAD-CODE-LOCATION-TYPES* will not be returned. -(defun next-code-locations (code-location) - (let ((debug-block (sb!di:code-location-debug-block code-location)) - (block-code-locations nil)) - (sb!di:do-debug-block-locations (block-code-location debug-block) - (unless (member (sb!di:code-location-kind block-code-location) - *bad-code-location-types*) - (push block-code-location block-code-locations))) - (setf block-code-locations (nreverse block-code-locations)) - (let* ((code-loc-list (rest (member code-location block-code-locations - :test #'sb!di:code-location=))) - (next-list (cond (code-loc-list - (list (first code-loc-list))) - ((map 'list #'first-code-location - (sb!di:debug-block-successors debug-block))) - (t nil)))) - (when (and (= (length next-list) 1) - (sb!di:code-location= (first next-list) code-location)) - (setf next-list (next-code-locations (first next-list)))) - next-list))) - -;;; Return a list of code-locations of the possible breakpoints of DEBUG-FUN. -(defun possible-breakpoints (debug-fun) - (let ((possible-breakpoints nil)) - (sb!di:do-debug-fun-blocks (debug-block debug-fun) - (unless (sb!di:debug-block-elsewhere-p debug-block) - (if *only-block-start-locations* - (push (first-code-location debug-block) possible-breakpoints) - (sb!di:do-debug-block-locations (code-location debug-block) - (when (not (member (sb!di:code-location-kind code-location) - *bad-code-location-types*)) - (push code-location possible-breakpoints)))))) - (nreverse possible-breakpoints))) - -;;; Search the info-list for the item passed (CODE-LOCATION, -;;; DEBUG-FUN, or BREAKPOINT-INFO). If the item passed is a debug -;;; function then kind will be compared if it was specified. The kind -;;; if also compared if a breakpoint-info is passed since it's in the -;;; breakpoint. The info structure is returned if found. -(defun location-in-list (place info-list &optional (kind nil)) - (when (breakpoint-info-p place) - (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place))) - (setf place (breakpoint-info-place place))) - (cond ((sb!di:code-location-p place) - (find place info-list - :key #'breakpoint-info-place - :test (lambda (x y) (and (sb!di:code-location-p y) - (sb!di:code-location= x y))))) - (t - (find place info-list - :test (lambda (x-debug-fun y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (sb!di:debug-fun-p y-place) - (eq x-debug-fun y-place) - (or (not kind) - (eq kind (sb!di:breakpoint-kind - y-breakpoint)))))))))) ;;; If LOC is an unknown location, then try to find the block start ;;; location. Used by source printing to some information instead of @@ -282,190 +161,6 @@ Other commands: loc))) loc)) -;;;; the BREAKPOINT-INFO structure - -;;; info about a made breakpoint -(defstruct (breakpoint-info (:copier nil) - (:constructor %make-breakpoint-info)) - ;; where we are going to stop - (place (missing-arg) - :type (or sb!di:code-location sb!di:debug-fun) - :read-only t) - ;; the breakpoint returned by SB!DI:MAKE-BREAKPOINT - (breakpoint (missing-arg) :type sb!di:breakpoint :read-only t) - ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is - ;; non-NIL, drop into the debugger. - (break #'identity :type function :read-only t) - ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is - ;; non-NIL, eval (each) print and print results. - (condition #'identity :type function :read-only t) - ;; the list of functions from SB!DI:PREPROCESS-FOR-EVAL to evaluate. - ;; Results are conditionally printed. CAR of each element is the - ;; function, CDR is the form it goes with. - (print nil :type list :read-only t) - ;; the number used when listing the possible breakpoints within a - ;; function; or could also be a symbol such as START or END - (code-location-selector (missing-arg) :type (or symbol integer) :read-only t) - ;; the number used when listing the active breakpoints, and when - ;; deleting breakpoints - (breakpoint-number (missing-arg) :type integer :read-only t)) - -(defun create-breakpoint-info (place breakpoint code-location-selector - &key (break #'identity) - (condition #'identity) (print nil)) - (setf *breakpoints* - (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) - (let ((breakpoint-number - (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints))) - ((or (> i (length *breakpoints*)) - (not (= i (breakpoint-info-breakpoint-number - (first breakpoints))))) - - i)))) - (%make-breakpoint-info :place place - :breakpoint breakpoint - :code-location-selector code-location-selector - :breakpoint-number breakpoint-number - :break break - :condition condition - :print print))) - -(defun print-breakpoint-info (breakpoint-info) - (let ((place (breakpoint-info-place breakpoint-info)) - (bp-number (breakpoint-info-breakpoint-number breakpoint-info))) - (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info)) - (:code-location - (print-code-location-source-form place 0) - (format t - "~&~S: ~S in ~S" - bp-number - (breakpoint-info-code-location-selector breakpoint-info) - (sb!di:debug-fun-name (sb!di:code-location-debug-fun place)))) - (:fun-start - (format t "~&~S: FUN-START in ~S" bp-number - (sb!di:debug-fun-name place))) - (:fun-end - (format t "~&~S: FUN-END in ~S" bp-number - (sb!di:debug-fun-name place)))))) - -;;;; MAIN-HOOK-FUN for steps and breakpoints - -;;; This must be passed as the hook function. It keeps track of where -;;; STEP breakpoints are. -(defun main-hook-fun (current-frame breakpoint &optional return-vals - fun-end-cookie) - (setf *default-breakpoint-debug-fun* - (sb!di:frame-debug-fun current-frame)) - (dolist (step-info *step-breakpoints*) - (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info)) - (let ((bp-info (location-in-list step-info *breakpoints*))) - (when bp-info - (sb!di:activate-breakpoint (breakpoint-info-breakpoint bp-info))))) - (let ((*stack-top-hint* current-frame) - (step-hit-info - (location-in-list (sb!di:breakpoint-what breakpoint) - *step-breakpoints* - (sb!di:breakpoint-kind breakpoint))) - (bp-hit-info - (location-in-list (sb!di:breakpoint-what breakpoint) - *breakpoints* - (sb!di:breakpoint-kind breakpoint))) - (break) - (condition) - (string "")) - (setf *step-breakpoints* nil) - (labels ((build-string (str) - (setf string (concatenate 'string string str))) - (print-common-info () - (build-string - (with-output-to-string (*standard-output*) - (when fun-end-cookie - (format t "~%Return values: ~S" return-vals)) - (when condition - (when (breakpoint-info-print bp-hit-info) - (format t "~%") - (print-frame-call current-frame)) - (dolist (print (breakpoint-info-print bp-hit-info)) - (format t "~& ~S = ~S" (rest print) - (funcall (first print) current-frame)))))))) - (when bp-hit-info - (setf break (funcall (breakpoint-info-break bp-hit-info) - current-frame)) - (setf condition (funcall (breakpoint-info-condition bp-hit-info) - current-frame))) - (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*)) - (build-string (format nil "~&*Step (to a breakpoint)*")) - (print-common-info) - (break string)) - ((and bp-hit-info step-hit-info break) - (build-string (format nil "~&*Step (to a breakpoint)*")) - (print-common-info) - (break string)) - ((and bp-hit-info step-hit-info) - (print-common-info) - (format t "~A" string) - (decf *number-of-steps*) - (set-step-breakpoint current-frame)) - ((and step-hit-info (= 1 *number-of-steps*)) - (build-string "*Step*") - (break (make-condition 'step-condition :format-control string))) - (step-hit-info - (decf *number-of-steps*) - (set-step-breakpoint current-frame)) - (bp-hit-info - (when break - (build-string (format nil "~&*Breakpoint hit*"))) - (print-common-info) - (if break - (break string) - (format t "~A" string))) - (t - (break "unknown breakpoint")))))) - -;;; Set breakpoints at the next possible code-locations. After calling -;;; this, either (CONTINUE) if in the debugger or just let program flow -;;; return if in a hook function. -(defun set-step-breakpoint (frame) - (cond - ((sb!di:debug-block-elsewhere-p (sb!di:code-location-debug-block - (sb!di:frame-code-location frame))) - ;; FIXME: FORMAT T is used for error output here and elsewhere in - ;; the debug code. - (format t "cannot step, in elsewhere code~%")) - (t - (let* ((code-location (sb!di:frame-code-location frame)) - (next-code-locations (next-code-locations code-location))) - (cond - (next-code-locations - (dolist (code-location next-code-locations) - (let ((bp-info (location-in-list code-location *breakpoints*))) - (when bp-info - (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint - bp-info)))) - (let ((bp (sb!di:make-breakpoint #'main-hook-fun code-location - :kind :code-location))) - (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info code-location bp 0) - *step-breakpoints*)))) - (t - (let* ((debug-fun (sb!di:frame-debug-fun *current-frame*)) - (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun - :kind :fun-end))) - (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info debug-fun bp 0) - *step-breakpoints*)))))))) - -;;;; STEP - -;;; ANSI specifies that this macro shall exist, even if only as a -;;; trivial placeholder like this. -(defmacro step (form) - "This is a trivial placeholder implementation of the CL:STEP macro required - by the ANSI spec, simply expanding to `(LET () ,FORM). A more featureful - version would be welcome, we just haven't written it." - `(let () - ,form)) - ;;;; BACKTRACE (defun backtrace (&optional (count most-positive-fixnum) @@ -1597,210 +1292,16 @@ reset to ~S." (svref translations form-num) context))))) -;;; breakpoint and step commands - -;;; Step to the next code-location. +;;; step to the next steppable form (!def-debug-command "STEP" () - (setf *number-of-steps* (read-if-available 1)) - (set-step-breakpoint *current-frame*) - (continue *debug-condition*) - (error "couldn't continue")) - -;;; List possible breakpoint locations, which ones are active, and -;;; where the CONTINUE restart will transfer control. Set -;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be -;;; used by sbreakpoint. -(!def-debug-command "LIST-LOCATIONS" () - (let ((df (read-if-available *default-breakpoint-debug-fun*))) - (cond ((consp df) - (setf df (sb!di:fun-debug-fun (eval df))) - (setf *default-breakpoint-debug-fun* df)) - ((or (eq ':c df) - (not *default-breakpoint-debug-fun*)) - (setf df (sb!di:frame-debug-fun *current-frame*)) - (setf *default-breakpoint-debug-fun* df))) - (setf *possible-breakpoints* (possible-breakpoints df))) - (let ((continue-at (sb!di:frame-code-location *current-frame*))) - (let ((active (location-in-list *default-breakpoint-debug-fun* - *breakpoints* :fun-start)) - (here (sb!di:code-location= - (sb!di:debug-fun-start-location - *default-breakpoint-debug-fun*) continue-at))) - (when (or active here) - (format t "::FUN-START ") - (when active (format t " *Active*")) - (when here (format t " *Continue here*")))) - - (let ((prev-location nil) - (prev-num 0) - (this-num 0)) - (flet ((flush () - (when prev-location - (let ((this-num (1- this-num))) - (if (= prev-num this-num) - (format t "~&~W: " prev-num) - (format t "~&~W-~W: " prev-num this-num))) - (print-code-location-source-form prev-location 0) - (when *print-location-kind* - (format t "~S " (sb!di:code-location-kind prev-location))) - (when (location-in-list prev-location *breakpoints*) - (format t " *Active*")) - (when (sb!di:code-location= prev-location continue-at) - (format t " *Continue here*"))))) - - (dolist (code-location *possible-breakpoints*) - (when (or *print-location-kind* - (location-in-list code-location *breakpoints*) - (sb!di:code-location= code-location continue-at) - (not prev-location) - (not (eq (sb!di:code-location-debug-source code-location) - (sb!di:code-location-debug-source prev-location))) - (not (eq (sb!di:code-location-toplevel-form-offset - code-location) - (sb!di:code-location-toplevel-form-offset - prev-location))) - (not (eq (sb!di:code-location-form-number code-location) - (sb!di:code-location-form-number prev-location)))) - (flush) - (setq prev-location code-location prev-num this-num)) - - (incf this-num)))) - - (when (location-in-list *default-breakpoint-debug-fun* - *breakpoints* - :fun-end) - (format t "~&::FUN-END *Active* ")))) - -(!def-debug-command-alias "LL" "LIST-LOCATIONS") - -;;; Set breakpoint at the given number. -(!def-debug-command "BREAKPOINT" () - (let ((index (read-prompting-maybe "location number, :START, or :END: ")) - (break t) - (condition t) - (print nil) - (print-functions nil) - (function nil) - (bp) - (place *default-breakpoint-debug-fun*)) - (flet ((get-command-line () - (let ((command-line nil) - (unique '(nil))) - (loop - (let ((next-input (read-if-available unique))) - (when (eq next-input unique) (return)) - (push next-input command-line))) - (nreverse command-line))) - (set-vars-from-command-line (command-line) - (do ((arg (pop command-line) (pop command-line))) - ((not arg)) - (ecase arg - (:condition (setf condition (pop command-line))) - (:print (push (pop command-line) print)) - (:break (setf break (pop command-line))) - (:function - (setf function (eval (pop command-line))) - (setf *default-breakpoint-debug-fun* - (sb!di:fun-debug-fun function)) - (setf place *default-breakpoint-debug-fun*) - (setf *possible-breakpoints* - (possible-breakpoints - *default-breakpoint-debug-fun*)))))) - (setup-fun-start () - (let ((code-loc (sb!di:debug-fun-start-location place))) - (setf bp (sb!di:make-breakpoint #'main-hook-fun - place - :kind :fun-start)) - (setf break (sb!di:preprocess-for-eval break code-loc)) - (setf condition (sb!di:preprocess-for-eval condition code-loc)) - (dolist (form print) - (push (cons (sb!di:preprocess-for-eval form code-loc) form) - print-functions)))) - (setup-fun-end () - (setf bp - (sb!di:make-breakpoint #'main-hook-fun - place - :kind :fun-end)) - (setf break - ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..) - ;; forms should be converted to shiny new (LAMBDA ..) forms. - ;; (Search the sources for "coerce.*\(lambda".) - (coerce `(lambda (dummy) - (declare (ignore dummy)) ,break) - 'function)) - (setf condition (coerce `(lambda (dummy) - (declare (ignore dummy)) ,condition) - 'function)) - (dolist (form print) - (push (cons - (coerce `(lambda (dummy) - (declare (ignore dummy)) ,form) 'function) - form) - print-functions))) - (setup-code-location () - (setf place (nth index *possible-breakpoints*)) - (setf bp (sb!di:make-breakpoint #'main-hook-fun place - :kind :code-location)) - (dolist (form print) - (push (cons - (sb!di:preprocess-for-eval form place) - form) - print-functions)) - (setf break (sb!di:preprocess-for-eval break place)) - (setf condition (sb!di:preprocess-for-eval condition place)))) - (set-vars-from-command-line (get-command-line)) - (cond - ((or (eq index :start) (eq index :s)) - (setup-fun-start)) - ((or (eq index :end) (eq index :e)) - (setup-fun-end)) - (t - (setup-code-location))) - (sb!di:activate-breakpoint bp) - (let* ((new-bp-info (create-breakpoint-info place bp index - :break break - :print print-functions - :condition condition)) - (old-bp-info (location-in-list new-bp-info *breakpoints*))) - (when old-bp-info - (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint - old-bp-info)) - (setf *breakpoints* (remove old-bp-info *breakpoints*)) - (format t "previous breakpoint removed~%")) - (push new-bp-info *breakpoints*)) - (print-breakpoint-info (first *breakpoints*)) - (format t "~&added")))) - -(!def-debug-command-alias "BP" "BREAKPOINT") - -;;; List all breakpoints which are set. -(!def-debug-command "LIST-BREAKPOINTS" () - (setf *breakpoints* - (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) - (dolist (info *breakpoints*) - (print-breakpoint-info info))) - -(!def-debug-command-alias "LB" "LIST-BREAKPOINTS") -(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS") - -;;; Remove breakpoint N, or remove all breakpoints if no N given. -(!def-debug-command "DELETE-BREAKPOINT" () - (let* ((index (read-if-available nil)) - (bp-info - (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) - (cond (bp-info - (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info)) - (setf *breakpoints* (remove bp-info *breakpoints*)) - (format t "breakpoint ~S removed~%" index)) - (index (format t "The breakpoint doesn't exist.")) + (let ((restart (find-restart 'continue *debug-condition*))) + (cond (restart + (setf *stepping* t + *step* t) + (invoke-restart restart)) (t - (dolist (ele *breakpoints*) - (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele))) - (setf *breakpoints* nil) - (format t "all breakpoints deleted~%"))))) + (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) -(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT") - ;;; miscellaneous commands (!def-debug-command "DESCRIBE" () diff --git a/src/code/step.lisp b/src/code/step.lisp new file mode 100644 index 0000000..4516e79 --- /dev/null +++ b/src/code/step.lisp @@ -0,0 +1,82 @@ +;;;; single stepper for SBCL + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +;;;; Single stepping works by having compiler insert STEP-CONDITION +;;;; signalling forms into code compiled at high debug settings, and +;;;; having a handler for them at the toplevel. + +(in-package "SB-IMPL") ; in warm SBCL + +(defvar *step-help* "The following commands are available at the single +stepper's prompt: + + S: Step into the current expression. + N: Evaluate the current expression without stepping. + C: Evaluate to finish without stepping. + Q: Abort evaluation. + ?: Display this message. +") + +(defgeneric single-step (condition)) + +(defmethod single-step ((condition step-variable-condition)) + (format *debug-io* "; ~A => ~S~%" + (step-condition-form condition) + (step-condition-result condition))) + +(defmethod single-step ((condition step-values-condition)) + (let ((values (step-condition-result condition))) + (format *debug-io* "; ~A => ~:[#~;~{~S~^, ~}~]~%" + (step-condition-form condition) + values values))) + +(defmethod single-step ((condition step-form-condition)) + (let ((form (step-condition-form condition))) + (loop + (format *debug-io* "; form ~A~%STEP] " form) + (finish-output *debug-io*) + (let ((line (read-line *debug-io*))) + (if (plusp (length line)) + (case (char-upcase (schar line 0)) + (#\Q + (abort condition)) + (#\C + (step-continue condition)) + (#\N + (step-next condition)) + (#\S + (step-into condition)) + (#\? + (write-line *step-help* *debug-io*)))))))) + +(defvar *stepper-hook* #'single-step + #+sb-doc "Customization hook for alternative single-steppers. +*STEPPER-HOOK* is bound to NIL prior to calling the bound function +with the STEP-CONDITION as argument.") + +(defun invoke-stepper (condition) + (when (and *stepping* *stepper-hook*) + (let ((hook *stepper-hook*) + (*stepper-hook* nil)) + (funcall hook condition)))) + +(defmacro step (form) + #+sb-doc + "The form is evaluated with single stepping enabled. Function calls +outside the lexical scope of the form can be stepped into only if the +functions in question have been compiled with sufficient DEBUG policy +to be at least partially steppable." + `(let ((*stepping* t) + (*step* t)) + (declare (optimize (sb-c:insert-step-conditions 0))) + (format t "Single stepping. Type ? for help.~%") + (locally (declare (optimize (sb-c:insert-step-conditions 3))) + ,form))) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index d1d5daa..b8cc3a7 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -38,6 +38,17 @@ ;;; counts of nested errors (with internal errors double-counted) (defvar *maximum-error-depth*) (defvar *current-error-depth*) + +;;;; stepping control +(defvar *step*) +(defvar *stepping*) +(defvar *step-form-stack* nil + "A place for single steppers to push information about +STEP-FORM-CONDITIONS avaiting the corresponding +STEP-VALUES-CONDITIONS. The system is guaranteed to empty the stack +when stepping terminates, so that it remains in sync, but doesn't +modify it in any other way: it is provided for implmentors of single +steppers to maintain contextual information.") ;;;; miscellaneous utilities for working with with TOPLEVEL @@ -526,36 +537,39 @@ ;; Each REPL in a multithreaded world should have bindings of ;; most CL specials (most critically *PACKAGE*). (with-rebound-io-syntax - ;; WITH-SIMPLE-RESTART doesn't actually restart its body as - ;; some (like WHN for an embarrassingly long time - ;; ca. 2001-12-07) might think, but instead drops control back - ;; out at the end. So when a TOPLEVEL or outermost-ABORT - ;; restart happens, we need this outer LOOP wrapper to grab - ;; control and start over again. (And it also wraps CATCH - ;; 'TOPLEVEL-CATCHER for similar reasons.) - (loop - (/show0 "about to set up restarts in TOPLEVEL-REPL") - ;; There should only be one TOPLEVEL restart, and it's here, - ;; so restarting at TOPLEVEL always bounces you all the way - ;; out here. - (with-simple-restart (toplevel - "Restart at toplevel READ/EVAL/PRINT loop.") - ;; We add a new ABORT restart for every debugger level, so - ;; restarting at ABORT in a nested debugger gets you out to - ;; the innermost enclosing debugger, and only when you're - ;; in the outermost, unnested debugger level does - ;; restarting at ABORT get you out to here. - (with-simple-restart - (abort - "~@") - (catch 'toplevel-catcher - (sb!unix::reset-signal-mask) - ;; In the event of a control-stack-exhausted-error, we - ;; should have unwound enough stack by the time we get - ;; here that this is now possible. - (sb!kernel::protect-control-stack-guard-page 1) - (funcall repl-fun noprint) - (critically-unreachable "after REPL"))))))))) + (handler-bind ((step-condition 'invoke-stepper)) + (let ((*stepping* nil) + (*step* nil)) + ;; WITH-SIMPLE-RESTART doesn't actually restart its body as + ;; some (like WHN for an embarrassingly long time + ;; ca. 2001-12-07) might think, but instead drops control back + ;; out at the end. So when a TOPLEVEL or outermost-ABORT + ;; restart happens, we need this outer LOOP wrapper to grab + ;; control and start over again. (And it also wraps CATCH + ;; 'TOPLEVEL-CATCHER for similar reasons.) + (loop + (/show0 "about to set up restarts in TOPLEVEL-REPL") + ;; There should only be one TOPLEVEL restart, and it's here, + ;; so restarting at TOPLEVEL always bounces you all the way + ;; out here. + (with-simple-restart (toplevel + "Restart at toplevel READ/EVAL/PRINT loop.") + ;; We add a new ABORT restart for every debugger level, so + ;; restarting at ABORT in a nested debugger gets you out to + ;; the innermost enclosing debugger, and only when you're + ;; in the outermost, unnested debugger level does + ;; restarting at ABORT get you out to here. + (with-simple-restart + (abort "~@") + (catch 'toplevel-catcher + (sb!unix::reset-signal-mask) + ;; In the event of a control-stack-exhausted-error, we + ;; should have unwound enough stack by the time we get + ;; here that this is now possible. + (sb!kernel::protect-control-stack-guard-page 1) + (funcall repl-fun noprint) + (critically-unreachable "after REPL"))))))))))) ;;; Our default REPL prompt is the minimal traditional one. (defun repl-prompt-fun (stream) @@ -575,26 +589,31 @@ (defun repl-fun (noprint) (/show0 "entering REPL") (loop - ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) - (scrub-control-stack) - (sb!thread::get-foreground) - (unless noprint - (funcall *repl-prompt-fun* *standard-output*) - ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own - ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to - ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems - ;; odd. But maybe there *is* a valid reason in some - ;; circumstances? perhaps some deadlock issue when being driven - ;; by another process or something...) - (force-output *standard-output*)) - (let* ((form (funcall *repl-read-form-fun* - *standard-input* - *standard-output*)) - (results (multiple-value-list (interactive-eval form)))) - (unless noprint - (dolist (result results) - (fresh-line) - (prin1 result)))))) + (unwind-protect + (progn + ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.) + (scrub-control-stack) + (sb!thread::get-foreground) + (unless noprint + (funcall *repl-prompt-fun* *standard-output*) + ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own + ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to + ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems + ;; odd. But maybe there *is* a valid reason in some + ;; circumstances? perhaps some deadlock issue when being driven + ;; by another process or something...) + (force-output *standard-output*)) + (let* ((form (funcall *repl-read-form-fun* + *standard-input* + *standard-output*)) + (results (multiple-value-list (interactive-eval form)))) + (unless noprint + (dolist (result results) + (fresh-line) + (prin1 result))))) + ;; If we started stepping in the debugger we want to stop now. + (setf *stepping* nil + *step* nil)))) ;;; a convenient way to get into the assembly-level debugger (defun %halt () diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 03bf05b..8ee9045 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -167,6 +167,7 @@ "SRC;CODE;INSPECT" "SRC;CODE;PROFILE" "SRC;CODE;NTRACE" + "SRC;CODE;STEP" "SRC;CODE;RUN-PROGRAM" ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT diff --git a/src/compiler/ir1-step.lisp b/src/compiler/ir1-step.lisp new file mode 100644 index 0000000..2ca4af6 --- /dev/null +++ b/src/compiler/ir1-step.lisp @@ -0,0 +1,105 @@ +;;;; compiler parts of the single stepper + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!C") + +;;; Local stepping control: STEP binds this to T, and when forms are +;;; being skipped this is bound to NIL down the stack to prevent +;;; signalling of STEP-CONDITIONs. +(defvar *step* nil) + +;;; Global stepping control: STEP binds this to T, and when the +;;; restart to continue without stepping is selected this is set to +;;; NIL to prevent the *STEPPER-HOOK* from being called. +(defvar *stepping* nil) + +(defun step-form (form source-path pathname) + (when *step* + (restart-case + (signal 'step-form-condition + :form form + :source-path source-path + :pathname pathname) + (step-continue () + (setf *stepping* nil)) + (step-next () + nil) + (step-into () + t)))) + +(defun step-variable (symbol value) + (when *step* + (signal 'step-variable-condition :form symbol :result value)) + value) + +(defun step-values (form values) + (when *step* + (signal 'step-values-condition :form form :result values)) + (values-list values)) + +(defun insert-step-conditions (form) + `(locally (declare + (optimize (insert-step-conditions + ,(policy *lexenv* insert-step-conditions)))) + ,form)) + +;;; Flag to control instrumentation function call arguments. +(defvar *step-arguments-p* nil) + +(defun ir1-convert-step (start next result form) + (let ((form-string (let ((*print-pretty* t) + (*print-readably* nil)) + (prin1-to-string form)))) + (etypecase form + (symbol + (ir1-convert start next result + `(locally (declare (optimize (insert-step-conditions 0))) + (step-variable ,form-string ,form)))) + (list + (let* ((*step-arguments-p* (policy *lexenv* (= insert-step-conditions 3))) + (step-form `(step-form ,form-string + ',(source-path-original-source *current-path*) + *compile-file-pathname*)) + (values-form `(,(car form) + ,@(if *step-arguments-p* + (mapcar #'insert-step-conditions (cdr form)) + (cdr form))))) + (ir1-convert start next result + `(locally (declare (optimize (insert-step-conditions 0))) + ,(if *step-arguments-p* + `(let ((*step* ,step-form)) + (step-values ,form-string (multiple-value-list ,values-form))) + `(progn ,step-form ,values-form))))))))) + +(defun step-form-p (form) + #+sb-xc-host (declare (ignore form)) + #-sb-xc-host + (flet ((step-symbol-p (symbol) + (not (member (symbol-package symbol) + (load-time-value + ;; KLUDGE: packages we're not interested in stepping. + (mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl))))))) + (let ((lexenv *lexenv*)) + (and (policy lexenv (>= insert-step-conditions 2)) + (cond ((consp form) + (let ((op (car form))) + (or (and (consp op) (eq 'lambda (car op))) + (and (symbolp op) + (not (special-operator-p op)) + (member (lexenv-find op funs) '(nil functional global-var)) + (not (eq :macro (info :function :kind op))) + (step-symbol-p op))))) + ((symbolp form) + (and *step-arguments-p* + (policy lexenv (= insert-step-conditions 3)) + (not (consp (lexenv-find form vars))) + (not (constantp form)) + (step-symbol-p form)))))))) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 651128d..632d189 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -865,7 +865,8 @@ (process-decls decls (append aux-vars vars) nil)) (forms (if (and *allow-debug-catch-tag* (policy *lexenv* (>= insert-debug-catch 2))) - `((catch (make-symbol "SB-DEBUG-CATCH-TAG") + `((catch (locally (declare (optimize (insert-step-conditions 0))) + (make-symbol "SB-DEBUG-CATCH-TAG")) ,@forms)) forms)) (forms (if (eq result-type *wild-type*) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6764c3a..16f919b 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -478,6 +478,8 @@ (ir1-error-bailout (start next result form) (let ((*current-path* (or (gethash form *source-paths*) (cons form *current-path*)))) + (if (step-form-p form) + (ir1-convert-step start next result form) (if (atom form) (cond ((and (symbolp form) (not (keywordp form))) (ir1-convert-var start next result form)) @@ -519,7 +521,7 @@ :debug-name (debug-namify "LAMBDA CAR " opname) - :allow-debug-catch-tag t)))))))) + :allow-debug-catch-tag t))))))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp index 14a0867..4680f71 100644 --- a/src/compiler/policies.lisp +++ b/src/compiler/policies.lisp @@ -60,3 +60,9 @@ (define-optimization-quality float-accuracy 3 ("degraded" "full" "full" "full")) + +(define-optimization-quality insert-step-conditions + (if (> debug (max speed space)) + debug + 0) + ("no" "no" "partial" "full")) diff --git a/version.lisp-expr b/version.lisp-expr index d028610..4930318 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.14.12" +"0.8.14.13"