Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/code early-step.lisp, NONE, 1.1 condition.lisp, 1.76, 1.77 debug-info.lisp, 1.21, 1.22 debug-int.lisp, 1.102, 1.103 debug-var-io.lisp, 1.6, 1.7 debug.lisp, 1.87, 1.88 step.lisp, 1.3, 1.4 target-thread.lisp, 1.59, 1.60 toplevel.lisp, 1.89, 1.90
|
From: Juho S. <js...@us...> - 2006-09-18 20:09:24
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv6222/src/code Modified Files: condition.lisp debug-info.lisp debug-int.lisp debug-var-io.lisp debug.lisp step.lisp target-thread.lisp toplevel.lisp Added Files: early-step.lisp Log Message: 0.9.16.38: Rewrite the single-stepper to solve the compilation/run-time performance and type-inference inaccuracy problems with the old approach. Also make some UI improvements to the stepper. * The IR1 stage no longer instruments the code. Instead it only detects function call forms which should (according to the policy) be steppable, and records a string representation of those forms in the matching combination nodes (to be stored in the debug-info). * Modify the function call vops to emit some instrumentation just before the actual call happens. This will check either the symbol-value of *STEPPING* (unithreaded) or the new STEPPING slot of threads (multithreaded) and trap if it's true. The trap handler will replace the closure / fdefn that was about to be called with a wrapper, which will signal a stepper condition and then call the original function. * Emit a similar bit of instrumentation before any call that got optimized to a simple VOP. The difference is that the only thing that the trap handler will do is to directly signal the condition. * The necessary VOP / runtime changes have only been done on x86, x86-64 and ppc so far. Alpha, Mips and Sparc should still compile, but the stepper won't work there. * Remove the old single-stepper REPL, and instead integrate the stepper into the debugger. * Add STEP-OUT functionality (stop stepping temporarily, resuming it once the current function returns). --- NEW FILE: early-step.lisp --- ;;;; 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") ;; Used for controlling whether the stepper is enabled / disabled when ;; building without SB-THREAD. With SB-THREAD, a slot in the thread ;; structure is used instead. (See EMIT-SINGLE-STEP-TEST in ;; src/compiler/x86/call.lisp). #!-sb-thread (defvar *stepping* nil) ;; Used for implementing the STEP-OUT restart. The step-wrapper will ;; bind this to :MAYBE, before calling the wrapped code. When ;; unwinding, the wrapper will check whether it's been set to T. If ;; so, it'll re-enable the stepper. This is a tri-state variable (NIL, ;; :MAYBE, T) so that the debugger can detect in advance whether the ;; OUT debugger command will actually have a wrapper to step out to. (defvar *step-out* nil) (symbol-macrolet ((place #!+sb-thread (sb!thread::thread-stepping) #!-sb-thread *stepping*)) (defun (setf stepping) (new-value) (setf place new-value)) (defun stepping-enabled-p () place)) (defun enable-stepping () (setf (stepping) t)) (defun disable-stepping () (setf (stepping) nil)) (defmacro with-stepping-enabled (&body body) (let ((orig (gensym))) `(let ((,orig (stepping-enabled-p))) (unwind-protect (progn (enable-stepping) ,@body) (setf (stepping) ,orig))))) (defmacro with-stepping-disabled (&body body) (let ((orig (gensym))) `(let ((,orig (stepping-enabled-p))) (unwind-protect (progn (disable-stepping) ,@body) (setf (stepping) ,orig))))) Index: condition.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v retrieving revision 1.76 retrieving revision 1.77 diff -u -d -r1.76 -r1.77 --- condition.lisp 1 Sep 2006 16:08:31 -0000 1.76 +++ condition.lisp 18 Sep 2006 20:09:13 -0000 1.77 @@ -1170,6 +1170,7 @@ (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 @@ -1180,8 +1181,18 @@ "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)) + ((args :initarg :args :reader step-condition-args)) + (:report + (lambda (condition stream) + (let ((*print-circle* t) + (*print-pretty* t) + (*print-readably* nil)) + (format stream + "Evaluating call:~%~< ~@;~A~:>~%~ + ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%" + (list (step-condition-form condition)) + (eq (step-condition-args condition) :unknown) + (step-condition-args condition))))) #!+sb-doc (:documentation "Condition signalled by code compiled with single-stepping information when about to execute a form. @@ -1215,14 +1226,6 @@ STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds the values returned by the form as a list. No associated restarts.")) -(define-condition step-variable-condition (step-result-condition) - () - #!+sb-doc - (:documentation "Condition signalled by code compiled with -single-stepping information when referencing a variable. -STEP-CONDITION-FORM hold the symbol, and STEP-CONDITION-RESULT holds -the value of the variable. No associated restarts.")) - ;;;; restart definitions Index: debug-info.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/debug-info.lisp,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- debug-info.lisp 14 Jul 2005 16:30:14 -0000 1.21 +++ debug-info.lisp 18 Sep 2006 20:09:13 -0000 1.22 @@ -60,10 +60,11 @@ (defconstant-eqx compiled-debug-block-nsucc-byte (byte 2 0) #'equalp) (def!constant compiled-debug-block-elsewhere-p #b00000100) -(defconstant-eqx compiled-code-location-kind-byte (byte 3 0) #'equalp) +(defconstant-eqx compiled-code-location-kind-byte (byte 4 0) #'equalp) (defparameter *compiled-code-location-kinds* #(:unknown-return :known-return :internal-error :non-local-exit - :block-start :call-site :single-value-return :non-local-entry)) + :block-start :call-site :single-value-return :non-local-entry + :step-before-vop)) ;;;; DEBUG-FUN objects Index: debug-int.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v retrieving revision 1.102 retrieving revision 1.103 diff -u -d -r1.102 -r1.103 --- debug-int.lisp 7 Apr 2006 12:49:59 -0000 1.102 +++ debug-int.lisp 18 Sep 2006 20:09:13 -0000 1.103 @@ -466,12 +466,12 @@ str))) (defstruct (compiled-code-location - (:include code-location) - (:constructor make-known-code-location - (pc debug-fun %tlf-offset %form-number - %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-fun)) - (:copier nil)) + (:include code-location) + (:constructor make-known-code-location + (pc debug-fun %tlf-offset %form-number + %live-set kind step-info &aux (%unknown-p nil))) + (:constructor make-compiled-code-location (pc debug-fun)) + (:copier nil)) ;; an index into DEBUG-FUN's component slot (pc nil :type index) ;; a bit-vector indexed by a variable's position in @@ -480,7 +480,8 @@ (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; (unexported) To see SB!C::LOCATION-KIND, do ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND). - (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))) + (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)) + (step-info :unparsed :type (or (member :unparsed :foo) simple-string))) ;;;; DEBUG-SOURCEs @@ -541,9 +542,6 @@ ;;;; (OR X86 X86-64) support -#!+(or x86 x86-64) -(progn - (defun compute-lra-data-from-pc (pc) (declare (type system-area-pointer pc)) (let ((component-ptr (component-ptr-from-pc pc))) @@ -557,6 +555,9 @@ ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) (values pc-offset code))))) +#!+(or x86 x86-64) +(progn + (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset) ;;; Check for a valid return address - it could be any valid C/Lisp @@ -1545,10 +1546,12 @@ (sb!c:read-var-integer blocks i))) (form-number (sb!c:read-var-integer blocks i)) (live-set (sb!c:read-packed-bit-vector - live-set-len blocks i))) + live-set-len blocks i)) + (step-info (sb!c:read-var-string blocks i))) (vector-push-extend (make-known-code-location pc debug-fun tlf-offset - form-number live-set kind) + form-number live-set kind + step-info) locations-buffer) (setf last-pc pc)))) (block (make-compiled-debug-block @@ -1866,6 +1869,8 @@ (compiled-code-location-%live-set loc)) (setf (compiled-code-location-kind code-location) (compiled-code-location-kind loc)) + (setf (compiled-code-location-step-info code-location) + (compiled-code-location-step-info loc)) (return-from fill-in-code-location t)))))))) ;;;; operations on DEBUG-BLOCKs @@ -3294,3 +3299,129 @@ ;; (There used to be more cases back before sbcl-0.7.0, when ;; we did special tricks to debug the IR1 interpreter.) )) + + +;;;; Single-stepping + +;;; The single-stepper works by inserting conditional trap instructions +;;; into the generated code (see src/compiler/*/call.lisp), currently: +;;; +;;; 1) Before the code generated for a function call that was +;;; translated to a VOP +;;; 2) Just before the call instruction for a full call +;;; +;;; In both cases, the trap will only be executed if stepping has been +;;; enabled, in which case it'll ultimately be handled by +;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition, +;;; or replace the function that's about to be called with a wrapper +;;; which will signal the condition. + +(defun handle-single-step-trap (context-sap kind callee-register-offset) + (let ((context (sb!alien:sap-alien context-sap + (* os-context-t)))) + ;; The following calls must get tail-call eliminated for + ;; *STEP-FRAME* to get set correctly. + (if (= kind single-step-before-trap) + (handle-single-step-before-trap context) + (handle-single-step-around-trap context callee-register-offset)))) + +(defvar *step-frame* nil) + +(defun handle-single-step-before-trap (context) + (let ((step-info (single-step-info-from-context context))) + ;; If there was not enough debug information available, there's no + ;; sense in signaling the condition. + (when step-info + (let ((*step-frame* (frame-down (top-frame)))) + ;; KLUDGE: Use the first non-foreign frame as the + ;; *STACK-TOP-HINT*. Getting the frame from the signal context + ;; would be cleaner, but SIGNAL-CONTEXT-FRAME doesn't seem + ;; seem to work very well currently. + (loop while *step-frame* + for dfun = (frame-debug-fun *step-frame*) + do (when (typep dfun 'compiled-debug-fun) + (return)) + do (setf *step-frame* (frame-down *step-frame*))) + (sb!impl::step-form step-info + ;; We could theoretically store information in + ;; the debug-info about to determine the + ;; arguments here, but for now let's just pass + ;; on it. + :unknown))))) + +;;; This function will replace the fdefn / function that was in the +;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To +;;; ensure that the full call will use the wrapper instead of the +;;; original, conditional trap must be emitted before the fdefn / +;;; function is converted into a raw address. +(defun handle-single-step-around-trap (context callee-register-offset) + ;; Fetch the function / fdefn we're about to call from the + ;; appropriate register. + (let* ((callee (sb!kernel::make-lisp-obj + (context-register context callee-register-offset))) + (step-info (single-step-info-from-context context))) + ;; If there was not enough debug information available, there's no + ;; sense in signaling the condition. + (unless step-info + (return-from handle-single-step-around-trap)) + (let* ((fun (lambda (&rest args) + (flet ((call () + (apply (typecase callee + (fdefn (fdefn-fun callee)) + (function callee)) + args))) + (let ((sb!impl::*step-out* :maybe)) + (unwind-protect + ;; Signal a step condition + (let* ((step-in + (let ((*step-frame* (frame-down (top-frame)))) + (sb!impl::step-form step-info args)))) + ;; And proceed based on its return value. + (if step-in + ;; If STEP-INTO was selected we pass + ;; the return values to STEP-VALUES which + ;; will show the return value. + (multiple-value-call #'sb!impl::step-values + step-info + (call)) + ;; If STEP-NEXT or STEP-CONTINUE was + ;; selected we disable the stepper for + ;; the duration of the call. + (sb!impl::with-stepping-disabled + (call)))) + ;; If the use selected the STEP-OUT restart + ;; somewhere during the call, resume stepping + (when (eq sb!impl::*step-out* t) + (sb!impl::enable-stepping))))))) + (new-callee (etypecase callee + (fdefn + (let ((fdefn (make-fdefn (gensym)))) + (setf (fdefn-fun fdefn) fun) + fdefn)) + (function fun)))) + ;; And then store the wrapper in the same place. + (setf (context-register context callee-register-offset) + (get-lisp-obj-address new-callee))))) + +;;; Given a signal context, fetch the step-info that's been stored in +;;; the debug info at the trap point. +(defun single-step-info-from-context (context) + (multiple-value-bind (pc-offset code) + (compute-lra-data-from-pc (context-pc context)) + (let* ((debug-fun (debug-fun-from-pc code pc-offset)) + (location (code-location-from-pc debug-fun + pc-offset + nil))) + (handler-case + (progn + (fill-in-code-location location) + (code-location-debug-source location) + (compiled-code-location-step-info location)) + (debug-condition () + nil))))) + +;;; Return the frame that triggered a single-step condition. Used to +;;; provide a *STACK-TOP-HINT*. +(defun find-stepped-frame () + (or *step-frame* + (top-frame))) Index: debug-var-io.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/debug-var-io.lisp,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- debug-var-io.lisp 14 Jul 2005 16:30:32 -0000 1.6 +++ debug-var-io.lisp 18 Sep 2006 20:09:13 -0000 1.7 @@ -70,7 +70,9 @@ (once-only ((len `(read-var-integer ,vec ,index))) (once-only ((res `(make-string ,len))) `(progn - (%byte-blt ,vec ,index ,res 0 ,len) + (loop for i from 0 below ,len + do (setf (aref ,res i) + (code-char (aref ,vec (+ ,index i))))) (incf ,index ,len) ,res)))) Index: debug.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/debug.lisp,v retrieving revision 1.87 retrieving revision 1.88 diff -u -d -r1.87 -r1.88 --- debug.lisp 22 Aug 2006 15:48:56 -0000 1.87 +++ debug.lisp 18 Sep 2006 20:09:13 -0000 1.88 @@ -120,9 +120,14 @@ SOURCE [n] displays frame's source form with n levels of enclosing forms. Stepping: - STEP Selects the CONTINUE restart if one exists and starts + START 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 Manual for details. + STEP Steps into the current form. + NEXT Steps over the current form. + OUT Stops stepping temporarily, but resumes it when the topmost frame that + was stepped into returns. + STOP Stops single-stepping. Function and macro commands: (SB-DEBUG:ARG n) @@ -512,7 +517,6 @@ (terpri stream)) (defun %invoke-debugger (condition) - (let ((*debug-condition* condition) (*debug-restarts* (compute-restarts condition)) (*nested-debug-condition* nil)) @@ -522,7 +526,8 @@ ;; when people redirect *ERROR-OUTPUT*, they could reasonably ;; expect to see error messages logged there, regardless of what ;; the debugger does afterwards.) - (%print-debugger-invocation-reason condition *error-output*) + (unless (typep condition 'step-condition) + (%print-debugger-invocation-reason condition *error-output*)) (error (condition) (setf *nested-debug-condition* condition) (let ((ndc-type (type-of *nested-debug-condition*))) @@ -697,6 +702,11 @@ (defvar *debug-loop-fun* #'debug-loop-fun "a function taking no parameters that starts the low-level debug loop") +;;; When the debugger is invoked due to a stepper condition, we don't +;;; want to print the current frame before the first prompt for aesthetic +;;; reasons. +(defvar *suppress-frame-print* nil) + ;;; This calls DEBUG-LOOP, performing some simple initializations ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies @@ -708,7 +718,8 @@ (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - (funcall *debug-loop-fun*))) + (let ((*suppress-frame-print* (typep *debug-condition* 'step-condition))) + (funcall *debug-loop-fun*)))) ;;;; DEBUG-LOOP @@ -738,8 +749,11 @@ (princ condition *debug-io*) (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") (throw 'debug-loop-catcher nil)))) - (terpri *debug-io*) - (print-frame-call *current-frame* *debug-io* :verbosity 2) + (cond (*suppress-frame-print* + (setf *suppress-frame-print* nil)) + (t + (terpri *debug-io*) + (print-frame-call *current-frame* *debug-io* :verbosity 2))) (loop (catch 'debug-loop-catcher (handler-bind ((error (lambda (condition) @@ -1311,15 +1325,41 @@ (svref translations form-num) context)))) -;;; step to the next steppable form -(!def-debug-command "STEP" () - (let ((restart (find-restart 'continue *debug-condition*))) - (cond (restart - (setf *stepping* t - *step* t) + +;;; start single-stepping +(!def-debug-command "START" () + (if (typep *debug-condition* 'step-condition) + (format *debug-io* "~&Already single-stepping.~%") + (let ((restart (find-restart 'continue *debug-condition*))) + (cond (restart + (sb!impl::enable-stepping) + (invoke-restart restart)) + (t + (format *debug-io* "~&Non-continuable error, cannot start stepping.~%")))))) + +(defmacro def-step-command (command-name restart-name) + `(!def-debug-command ,command-name () + (if (typep *debug-condition* 'step-condition) + (let ((restart (find-restart ',restart-name *debug-condition*))) + (aver restart) (invoke-restart restart)) - (t - (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))) + +(def-step-command "STEP" step-into) +(def-step-command "NEXT" step-next) +(def-step-command "STOP" step-continue) + +(!def-debug-command-alias "S" "STEP") +(!def-debug-command-alias "N" "NEXT") + +(!def-debug-command "OUT" () + (if (typep *debug-condition* 'step-condition) + (if sb!impl::*step-out* + (let ((restart (find-restart 'step-out *debug-condition*))) + (aver restart) + (invoke-restart restart)) + (format *debug-io* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%")) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))) ;;; miscellaneous commands Index: step.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/step.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- step.lisp 16 Aug 2006 19:05:46 -0000 1.3 +++ step.lisp 18 Sep 2006 20:09:13 -0000 1.4 @@ -15,6 +15,32 @@ (in-package "SB-IMPL") ; in warm SBCL +(defun step-form (form args) + (restart-case + (signal 'step-form-condition + :form form + :args args) + (step-continue () + :report "Resume normal execution" + (disable-stepping) + (setf *step-out* nil)) + (step-out () + :report "Resume stepping after returning from this function" + (disable-stepping) + (setf *step-out* t) + nil) + (step-next () + :report "Step over call" + nil) + (step-into () + :report "Step into call" + t))) + +(defun step-values (form &rest values) + (declare (dynamic-extent values)) + (signal 'step-values-condition :form form :result values) + (values-list values)) + (defvar *step-help* "The following commands are available at the single stepper's prompt: @@ -28,11 +54,6 @@ (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~^, ~}~]~%" @@ -40,25 +61,20 @@ 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)) - (#\B - (backtrace)) - (#\Q - (abort condition)) - (#\C - (step-continue condition)) - (#\N - (step-next condition)) - (#\S - (step-into condition)) - (#\? - (write-line *step-help* *debug-io*)))))))) + (let ((form (step-condition-form condition)) + (args (step-condition-args condition))) + (let ((*print-circle* t) + (*print-pretty* t) + (*print-readably* nil)) + (format *debug-io* + "; Evaluating call:~%~<; ~@; ~A~:>~%~ + ; ~:[With arguments:~%~<; ~@;~{ ~S~^~%~}~:>~;With unknown arguments~]~%" + (list form) + (eq args :unknown) + (list args))) + (finish-output *debug-io*) + (let ((*stack-top-hint* (sb-di::find-stepped-frame))) + (invoke-debugger condition)))) (defvar *stepper-hook* 'single-step #+sb-doc "Customization hook for alternative single-steppers. @@ -66,7 +82,8 @@ with the STEP-CONDITION as argument.") (defun invoke-stepper (condition) - (when (and *stepping* *stepper-hook*) + (when (and (stepping-enabled-p) + *stepper-hook*) (let ((hook *stepper-hook*) (*stepper-hook* nil)) (funcall hook condition)))) @@ -77,9 +94,10 @@ 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))) + `(locally + (declare (optimize (sb-c:insert-step-conditions 0))) + (format t "Single stepping. Type ? for help.~%") + (let ((*step-out* :maybe)) + (with-stepping-enabled + (locally (declare (optimize (sb-c:insert-step-conditions 3))) + ,form))))) Index: target-thread.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v retrieving revision 1.59 retrieving revision 1.60 diff -u -d -r1.59 -r1.60 --- target-thread.lisp 13 Sep 2006 15:59:33 -0000 1.59 +++ target-thread.lisp 18 Sep 2006 20:09:13 -0000 1.60 @@ -156,13 +156,18 @@ int (word unsigned-long) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts -#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) +#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) #!-sb-thread (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) +#!+sb-thread +(defun sb!vm::current-thread-offset-sap (n) + (declare (type (unsigned-byte 27) n)) + (sb!vm::current-thread-offset-sap n)) + ;;;; spinlocks (declaim (inline get-spinlock release-spinlock)) @@ -607,6 +612,7 @@ (sb!kernel::*restart-clusters* nil) (sb!kernel::*handler-clusters* nil) (sb!kernel::*condition-restarts* nil) + (sb!impl::*step-out* nil) ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) @@ -757,3 +763,15 @@ (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta)) + +;;; Stepping + +(defun thread-stepping () + (sb!kernel:make-lisp-obj + (sap-ref-word (current-thread-sap) + (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)))) + +(defun (setf thread-stepping) (value) + (setf (sap-ref-word (current-thread-sap) + (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes)) + (sb!kernel:get-lisp-obj-address value))) Index: toplevel.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v retrieving revision 1.89 retrieving revision 1.90 diff -u -d -r1.89 -r1.90 --- toplevel.lisp 13 Sep 2006 17:30:29 -0000 1.89 +++ toplevel.lisp 18 Sep 2006 20:09:13 -0000 1.90 @@ -65,17 +65,6 @@ returns NIL, no userinit file is used unless one has been specified on the command-line.") -;;;; stepping control -(defvar *step*) -(defvar *stepping*) -(defvar *step-form-stack* nil - #!+sb-doc - "A place for single steppers to push information about -STEP-FORM-CONDITIONS avaiting the corresponding -STEP-VALUES-CONDITIONS. The system is guaranteed to empty the stack -when stepping terminates, so that it remains in sync, but doesn't -modify it in any other way: it is provided for implmentors of single -steppers to maintain contextual information.") ;;;; miscellaneous utilities for working with with TOPLEVEL @@ -581,24 +570,22 @@ ;; most CL specials (most critically *PACKAGE*). (with-rebound-io-syntax (handler-bind ((step-condition 'invoke-stepper)) - (let ((*stepping* nil) - (*step* nil)) - (loop + (loop (/show0 "about to set up restarts in TOPLEVEL-REPL") - ;; CLHS recommends that there should always be an - ;; ABORT restart; we have this one here, and one per - ;; debugger level. - (with-simple-restart - (abort "~@<Exit debugger, returning to top level.~@:>") - (catch 'toplevel-catcher - #!-win32 (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. - #!-win32 - (sb!kernel::protect-control-stack-guard-page 1) - (funcall repl-fun noprint) - (critically-unreachable "after REPL")))))))))) + ;; CLHS recommends that there should always be an + ;; ABORT restart; we have this one here, and one per + ;; debugger level. + (with-simple-restart + (abort "~@<Exit debugger, returning to top level.~@:>") + (catch 'toplevel-catcher + #!-win32 (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. + #!-win32 + (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) @@ -642,8 +629,7 @@ (fresh-line) (prin1 result))))) ;; If we started stepping in the debugger we want to stop now. - (setf *stepping* nil - *step* nil)))) + (disable-stepping)))) ;;; a convenient way to get into the assembly-level debugger (defun %halt () |