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 (file)
--- 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/ir1tran")
  ("src/compiler/ir1tran-lambda")
  ("src/compiler/ir1-translators")

+ ("src/compiler/ir1-step")

  ("src/compiler/ir1util")
  ("src/compiler/ir1report")
  ("src/compiler/ir1opt")
  ("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 (file)
--- 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")
 (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*"
   (: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
      (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)
        (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 (file)
--- 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::            
 * Exiting Commands::            
 * Information Commands::        
 * Function Tracing::            

+* Single Stepping::             

 @end menu
 
 @node  Starting the Debugger
 @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).
 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
 @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.
 
 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
 @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
 
 @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 @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 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
 @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.
 
 @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 (file)
--- 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)
               (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)
                (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 (file)
--- 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
 ./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!")
        ;; 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 (file)
--- 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"
                "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"
                "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"
               "*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
             
               ;; 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*"
               ;; 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"
               "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 (file)
--- 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) ())
               (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
 
 \f
 ;;;; 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."))
 
     "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")
 
 (/show0 "condition.lisp end of file")
 

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index dd34fc4..a818d2b 100644 (file)
--- 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.
 
   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)
 
 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.)")
 \f
     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
 
 ;;; 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))
 \f
               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)
 ;;;; BACKTRACE
 
 (defun backtrace (&optional (count most-positive-fixnum)

@@ -1597,210 +1292,16 @@ reset to ~S."
                                        (svref translations form-num)
                                        context)))))
 \f
                                        (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" ()
 (!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
          (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" ()
 ;;; miscellaneous commands
 
 (!def-debug-command "DESCRIBE" ()

diff --git a/src/code/step.lisp b/src/code/step.lisp
new file mode 100644 (file)
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 => ~:[#<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)))

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index d1d5daa..b8cc3a7 100644 (file)
--- 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*)
 ;;; 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
 
 \f
 ;;;; 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
       ;; 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)
 
 ;;; 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
 (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 ()
 \f
 ;;; 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 (file)
--- 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;INSPECT"
                "SRC;CODE;PROFILE"
                "SRC;CODE;NTRACE"

+                "SRC;CODE;STEP"

                "SRC;CODE;RUN-PROGRAM"
 
                ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT
                "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 (file)
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 (file)
--- 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)))
                     (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*)
                                   ,@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 (file)
--- 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*))))
     (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))
        (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)
                                               :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
     (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 (file)
--- 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 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 (file)
--- 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".)
 ;;; 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"