("src/compiler/ir1tran")
("src/compiler/ir1tran-lambda")
("src/compiler/ir1-translators")
+ ("src/compiler/ir1-step")
("src/compiler/ir1util")
("src/compiler/ir1report")
("src/compiler/ir1opt")
(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*"
(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)
* Exiting Commands::
* Information Commands::
* Function Tracing::
+* Single Stepping::
@end menu
@node Starting the Debugger
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
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
@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
@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
@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
(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)
./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!")
"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"
"*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
;; 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"
(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."))
+
\f
;;;; restart definitions
"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")
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)
useful when the debugger was invoked to handle an error in
deeply nested input syntax, and now the reader is confused.)")
\f
-;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
-(define-condition step-condition (simple-condition) ())
-\f
-;;;; 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*))
-\f
-;;;; 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
loc)))
loc))
\f
-;;;; 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))))))
-\f
-;;;; 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"))))))
-\f
-;;; 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*))))))))
-\f
-;;;; 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))
-\f
;;;; BACKTRACE
(defun backtrace (&optional (count most-positive-fixnum)
(svref translations form-num)
context)))))
\f
-;;; 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")
-\f
;;; miscellaneous commands
(!def-debug-command "DESCRIBE" ()
--- /dev/null
+;;;; 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 => ~:[#<no value>~;~{~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)))
;;; 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.")
\f
;;;; miscellaneous utilities for working with with TOPLEVEL
;; 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
- "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
- (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 "~@<Reduce debugger level (leaving debugger, ~
+ returning to toplevel).~@:>")
+ (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)
(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))))
\f
;;; a convenient way to get into the assembly-level debugger
(defun %halt ()
"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
--- /dev/null
+;;;; 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))))))))
(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*)
(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))
: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
(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"))
;;; 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"
projects / sbcl.git / commitdiff