following unused symbols: *GC-NOTIFY-AFTER*, *GC-NOTIFY-BEFORE*,
*GC-NOTIFY-STREAM*, *ERROR-PRINT-LENGTH*, *ERROR-PRINT-LEVEL*,
*ERROR-PRINT-LINES*
+ * incompatible change: the single-stepper is no longer available
+ on Alpha, Mips and Sparc platforms.
* minor incompatible change: the direct superclasses of
SB-MOP:FUNCALLABLE-STANDARD-OBJECT are (FUNCTION STANDARD-OBJECT),
not (STANDARD-OBJECT FUNCTION). This makes the
of the compiler. EVAL still uses the compiler by default, to switch it
to use the interpreter, set the value of the variable
SB-EXT:*EVALUATOR-MODE* to :INTERPRET.
+ * minor incompatible change: the single-stepper REPL has been merged
+ with the normal debugger (see the "Stepping" heading of the debugger help
+ for more details). The debugger command STEP will no longer switch
+ to the single-stepper REPL.
* bug fix: ENOUGH-NAMESTRING on pathnames with no name and a pattern
for a type now works.
* bug fix: loading of default sysinit file works. (thanks to Leonid
Gracin).
* bug fix: timers expiring in dead threads no longer cause a
type-error (reported by Paul "Nonny Mouse").
+ * bug fix: thanks to more lightweight single-stepper instrumentation,
+ code compiled with (DEBUG 3) will compile and execute significantly faster,
+ and will have more accurate type-inferencing than before
* improvements to the win32 port (thanks to Yaroslav Kavenchuk):
* bug fix: arguments to RUN-PROGRAM are escaped correctly
* replace dummy implementations of CL:MACHINE-INSTANCE and
("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/code/sharpm" :not-host) ; uses stuff from "code/reader"
("src/code/alloc" :not-host)
+ ("src/code/early-step") ; target-thread needs *STEP-OUT*
+
("src/code/target-thread" :not-host)
+
;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp
("src/code/gc" :not-host)
("src/code/purify" :not-host)
;; 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-CONDITION-FORM" "STEP-CONDITION-RESULT"
"STEP-CONTINUE" "STEP-NEXT" "STEP-INTO"
- "*STEPPER-HOOK*"
+ "STEP-CONDITION-ARGS" "*STEPPER-HOOK*" "STEP-OUT"
;; RUN-PROGRAM is not only useful for users, but also
;; useful to implement parts of SBCL itself, so we're
"SINGLE-FLOAT-WIDETAG" "SINGLE-FLOAT-VALUE-SLOT"
"SINGLE-INT-CARG-REG-SC-NUMBER"
"SINGLE-REG-SC-NUMBER" "SINGLE-STACK-SC-NUMBER"
- "SINGLE-STEP-BREAKPOINT-TRAP"
+ "SINGLE-STEP-AROUND-TRAP"
+ "SINGLE-STEP-BEFORE-TRAP"
"SINGLE-VALUE-RETURN-BYTE-OFFSET" "SLOT-DOCS"
"SLOT-LENGTH" "SLOT-NAME" "SLOT-OFFSET" "SLOT-OPTIONS"
"SLOT-REST-P" "*STATIC-FUNS*" "STATIC-FUN-OFFSET"
(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
"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.
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
(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))
\f
;;;; DEBUG-FUN objects
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
(%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)))
\f
;;;; DEBUG-SOURCEs
;;;; (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)))
; (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
(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
(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))))))))
\f
;;;; operations on DEBUG-BLOCKs
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))
+
+\f
+;;;; 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)))
(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))))
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)
(terpri stream))
(defun %invoke-debugger (condition)
-
(let ((*debug-condition* condition)
(*debug-restarts* (compute-restarts condition))
(*nested-debug-condition* nil))
;; 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*)))
(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
(*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*))))
\f
;;;; DEBUG-LOOP
(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)
(svref translations form-num)
context))))
\f
-;;; 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
--- /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")
+
+;; 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)))))
(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:
(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~^, ~}~]~%"
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.
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))))
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)))))
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))
(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)
(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)))
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.")
\f
;;;; miscellaneous utilities for working with with TOPLEVEL
;; 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)
(fresh-line)
(prin1 result)))))
;; If we started stepping in the debugger we want to stop now.
- (setf *stepping* nil
- *step* nil))))
+ (disable-stepping))))
\f
;;; a convenient way to get into the assembly-level debugger
(defun %halt ()
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore #!+gengc ,@(unless (eq return :tail) '(return-pc-pass))
,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
+ ,@(unless variable '(args))
+ ;; Step instrumentation for full calls not implemented yet.
+ ;; See the PPC backend for an example.
+ step-instrumenting)
(:temporary (:sc descriptor-reg
:offset ocfp-offset
(frob unknown-key-arg-error unknown-key-arg-error
sb!c::%unknown-key-arg-error key)
(frob nil-fun-returned-error nil-fun-returned-error nil fun))
+
+;;; Single-stepping
+
+(define-vop (step-instrument-before-vop)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ ;; Stub! See the PPC backend for an example.
+ (note-this-location vop :step-before-vop)))
cerror
breakpoint
fun-end-breakpoint
- single-step-breakpoint)
+ single-step-breakpoint
+ ;; Stepper actually not implemented on Alpha, but these constants
+ ;; are still needed to avoid undefined variable warnings during sbcl
+ ;; build.
+ single-step-around
+ single-step-before)
(defenum (:prefix trace-table-)
normal
(deftype location-kind ()
'(member :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))
;;; The LOCATION-INFO structure holds the information what we need
;;; about locations which code generation decided were "interesting".
;;; are spilled.
(defun dump-1-location (node block kind tlf-num label live var-locs vop)
(declare (type node node) (type ir2-block block)
- (type local-tn-bit-vector live)
+ (type (or null local-tn-bit-vector) live)
(type (or label index) label)
(type location-kind kind) (type (or index null) tlf-num)
(type hash-table var-locs) (type (or vop null) vop))
(write-var-integer (source-path-tlf-number path) *byte-buffer*))
(write-var-integer (source-path-form-number path) *byte-buffer*))
- (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
- *byte-buffer*)
-
+ (if live
+ (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
+ *byte-buffer*)
+ (write-packed-bit-vector
+ (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
+ :initial-element 0
+ :element-type 'bit)
+ *byte-buffer*))
+
+ (write-var-string (or (and (typep node 'combination)
+ (combination-step-info node))
+ "")
+ *byte-buffer*)
(values))
;;; Extract context info from a Location-Info structure and use it to
#!+(or x86 x86-64) (pseudo-atomic-bits)
(interrupt-data :c-type "struct interrupt_data *"
:length #!+alpha 2 #!-alpha 1)
+ (stepping)
(interrupt-contexts :c-type "os_context_t *" :rest-p t))
sb!kernel::undefined-alien-function-error
sb!kernel::memory-fault-error
sb!di::handle-breakpoint
+ sb!di::handle-single-step-trap
fdefinition-object
#!+sb-thread sb!thread::run-interruption
#!+win32 sb!kernel::handle-win32-exception))
sb!unix::*interrupt-pending*
*gc-inhibit*
*gc-pending*
+ #!-sb-thread
+ *stepping*
;; hash table weaknesses
:key
(ir1-error-bailout (start next result form)
(let ((*current-path* (or (gethash form *source-paths*)
(cons form *current-path*))))
- (cond ((step-form-p form)
- (ir1-convert-step start next result form))
- ((atom form)
+ (cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
(ir1-convert-var start next result form))
((leaf-p form)
\f
;;;; converting combinations
+;;; Does this form look like something that we should add single-stepping
+;;; instrumentation for?
+(defun step-form-p (form)
+ (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)))))))
+ (and *allow-instrumenting*
+ (policy *lexenv* (= insert-step-conditions 3))
+ (listp form)
+ (symbolp (car form))
+ (step-symbol-p (car form)))))
+
;;; Convert a function call where the function FUN is a LEAF. FORM is
;;; the source for the call. We return the COMBINATION node so that
;;; the caller can poke at it if it wants to.
(let ((ctran (make-ctran))
(fun-lvar (make-lvar)))
(ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun))
- (ir1-convert-combination-args fun-lvar ctran next result (cdr form))))
+ (let ((combination
+ (ir1-convert-combination-args fun-lvar ctran next result (cdr form))))
+ (when (step-form-p form)
+ ;; Store a string representation of the form in the
+ ;; combination node. This will let the IR2 translator know
+ ;; that we want stepper instrumentation for this node. The
+ ;; string will be stored in the debug-info by DUMP-1-LOCATION.
+ (setf (combination-step-info combination)
+ (let ((*print-pretty* t)
+ (*print-circle* t)
+ (*print-readably* nil))
+ (prin1-to-string form))))
+ combination)))
;;; Convert the arguments to a call and make the COMBINATION
;;; node. FUN-LVAR yields the function to call. ARGS is the list of
(vop move node block x y))
(values))
+;;; Determine whether we should emit a single-stepper breakpoint
+;;; around a call / before a vop.
+(defun emit-step-p (node)
+ (if (and (policy node (> insert-step-conditions 1))
+ (typep node 'combination))
+ (combination-step-info node)
+ nil))
+
;;; If there is any CHECK-xxx template for TYPE, then return it,
;;; otherwise return NIL.
(defun type-check-template (type)
(when (and lvar (lvar-dynamic-extent lvar))
(vop current-stack-pointer call block
(ir2-lvar-stack-pointer (lvar-info lvar))))
+ (when (emit-step-p call)
+ (vop sb!vm::step-instrument-before-vop call block))
(if info-args
(emit-template call block template args r-refs info-args)
(emit-template call block template args r-refs))
(vop* tail-call-named node block
(fun-tn old-fp return-pc pass-refs)
(nil)
- nargs)
+ nargs
+ (emit-step-p node))
(vop* tail-call node block
(fun-tn old-fp return-pc pass-refs)
(nil)
- nargs))))
+ nargs
+ (emit-step-p node)))))
(values))
(fun-lvar-tn node block (basic-combination-fun node))
(if named
(vop* call-named node block (fp fun-tn args) (loc-refs)
- arg-locs nargs nvals)
+ arg-locs nargs nvals (emit-step-p node))
(vop* call node block (fp fun-tn args) (loc-refs)
- arg-locs nargs nvals))
+ arg-locs nargs nvals (emit-step-p node)))
(move-lvar-result node block locs lvar))))
(values))
(fun-lvar-tn node block (basic-combination-fun node))
(if named
(vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
- arg-locs nargs)
+ arg-locs nargs (emit-step-p node))
(vop* multiple-call node block (fp fun-tn args) (loc-refs)
- arg-locs nargs)))))
+ arg-locs nargs (emit-step-p node))))))
(values))
;;; stuff to check in PONDER-FULL-CALL
((and 2lvar
(eq (ir2-lvar-kind 2lvar) :unknown))
(vop* multiple-call-variable node block (start fun nil)
- ((reference-tn-list (ir2-lvar-locs 2lvar) t))))
+ ((reference-tn-list (ir2-lvar-locs 2lvar) t))
+ (emit-step-p node)))
(t
(let ((locs (standard-result-tns lvar)))
(vop* call-variable node block (start fun nil)
- ((reference-tn-list locs t)) (length locs))
+ ((reference-tn-list locs t)) (length locs)
+ (emit-step-p node))
(move-lvar-result node block locs lvar)))))))
;;; Reset the stack pointer to the start of the specified
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
+ ,@(unless variable '(args))
+ ;; Step instrumentation for full calls not implemented yet.
+ ;; See the PPC backend for an example.
+ step-instrumenting)
(:temporary (:sc descriptor-reg
:offset ocfp-offset
(frob unknown-key-arg-error unknown-key-arg-error
sb!c::%unknown-key-arg-error key)
(frob nil-fun-returned-error nil-fun-returned-error nil fun))
+
+;;; Single-stepping
+
+(define-vop (step-instrument-before-vop)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ ;; Stub! See the PPC backend for an example.
+ (note-this-location vop :step-before-vop)))
unused
pseudo-atomic
object-not-list
- object-not-instance)
+ object-not-instance
+ ;; Stepper actually not implemented on Mips, but these constants
+ ;; are still needed to avoid undefined variable warnings during sbcl
+ ;; build.
+ single-step-around
+ single-step-before)
(defenum (:prefix trace-table-)
normal
;; if a call to a known global function, contains the FUN-INFO.
(fun-info nil :type (or fun-info null))
;; some kind of information attached to this node by the back end
- (info nil))
+ (info nil)
+ (step-info))
;;; The COMBINATION node represents all normal function calls,
;;; including FUNCALL. This is distinct from BASIC-COMBINATION so that
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(when (eq return :fixed)
'((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+ (:temporary (:scs (descriptor-reg) :to :eval) stepping)
+
,@(unless (eq return :tail)
'((:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
15
(if (eq return :unknown) 25 0))
(trace-table-entry trace-table-call-site)
+
(let* ((cur-nfp (current-nfp-tn vop))
,@(unless (eq return :tail)
'((lra-label (gen-label))))
+ (step-done-label (gen-label))
(filler
(remove nil
(list :load-nargs
'(if (> nargs register-arg-count)
(move cfp-tn new-fp)
(move cfp-tn csp-tn))))))
- ((nil))))))
+ ((nil)))))
+ (insert-step-instrumenting (callable-tn)
+ ;; Conditionally insert a conditional trap:
+ (when step-instrumenting
+ ;; Get the symbol-value of SB!IMPL::*STEPPING*
+ (loadw stepping
+ null-tn
+ (+ symbol-value-slot
+ (truncate (static-symbol-offset 'sb!impl::*stepping*)
+ n-word-bytes))
+ other-pointer-lowtag)
+ (inst cmpw stepping null-tn)
+ ;; If it's not null, trap.
+ (inst beq step-done-label)
+ ;; CONTEXT-PC will be pointing here when the
+ ;; interrupt is handled, not after the UNIMP.
+ (note-this-location vop :step-before-vop)
+ ;; Construct a trap code with the low bits from
+ ;; SINGLE-STEP-AROUND-TRAP and the high bits from
+ ;; the register number of CALLABLE-TN.
+ (inst unimp (logior single-step-around-trap
+ (ash (reg-tn-encoding callable-tn)
+ 5)))
+ (emit-label step-done-label))))
,@(if named
`((sc-case name
(descriptor-reg (move name-pass name))
(loadw name-pass code-tn (tn-offset name)
other-pointer-lowtag)
(do-next-filler)))
+ ;; The step instrumenting must be done after
+ ;; FUNCTION is loaded, but before ENTRY-POINT is
+ ;; calculated.
+ (insert-step-instrumenting name-pass)
(loadw entry-point name-pass fdefn-raw-addr-slot
other-pointer-lowtag)
(do-next-filler))
(loadw function lexenv closure-fun-slot
fun-pointer-lowtag)
(do-next-filler)
+ ;; The step instrumenting must be done before
+ ;; after FUNCTION is loaded, but before ENTRY-POINT
+ ;; is calculated.
+ (insert-step-instrumenting function)
(inst addi entry-point function
(- (ash simple-fun-code-offset word-shift)
fun-pointer-lowtag))
(frob unknown-key-arg-error unknown-key-arg-error
sb!c::%unknown-key-arg-error key)
(frob nil-fun-returned-error nil-fun-returned-error nil fun))
+
+(define-vop (step-instrument-before-vop)
+ (:temporary (:scs (descriptor-reg)) stepping)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ ;; Get the symbol-value of SB!IMPL::*STEPPING*
+ (loadw stepping
+ null-tn
+ (+ symbol-value-slot
+ (truncate (static-symbol-offset 'sb!impl::*stepping*)
+ n-word-bytes))
+ other-pointer-lowtag)
+ (inst cmpw stepping null-tn)
+ ;; If it's not null, trap.
+ (inst beq DONE)
+ ;; CONTEXT-PC will be pointing here when the interrupt is handled,
+ ;; not after the UNIMP.
+ (note-this-location vop :step-before-vop)
+ ;; CALLEE-REGISTER-OFFSET isn't needed for before-traps, so we
+ ;; can just use a bare SINGLE-STEP-BEFORE-TRAP as the code.
+ (inst unimp single-step-before-trap)
+ DONE))
breakpoint
fun-end-breakpoint
after-breakpoint
- fixnum-additive-overflow)
+ fixnum-additive-overflow
+ single-step-around
+ single-step-before)
-(defenum (:prefix object-not- :suffix -trap :start 16)
+(defenum (:prefix object-not- :suffix -trap :start 24)
list
instance)
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
+ ,@(unless variable '(args))
+ ;; Step instrumentation for full calls not implemented yet.
+ ;; See the PPC backend for an example.
+ step-instrumenting)
(:temporary (:sc descriptor-reg
:offset ocfp-offset
(frob unknown-key-arg-error unknown-key-arg-error
sb!c::%unknown-key-arg-error key)
(frob nil-fun-returned-error nil-fun-returned-error nil fun))
+
+;;; Single-stepping
+
+(define-vop (step-instrument-before-vop)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ ;; Stub! See the PPC backend for an example.
+ (note-this-location vop :step-before-vop)))
cerror
breakpoint
fun-end-breakpoint
- after-breakpoint)
-
-(defenum (:prefix object-not- :suffix -trap :start 16)
+ after-breakpoint
+ ;; Stepper actually not implemented on Sparc, but these constants
+ ;; are still needed to avoid undefined variable warnings during sbcl
+ ;; build.
+ single-step-around
+ single-step-before)
+
+(defenum (:prefix object-not- :suffix -trap :start 24)
list
instance)
(:info
,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
(move rbp-tn new-fp) ; NB - now on new stack frame.
)))
+ (when step-instrumenting
+ (emit-single-step-test)
+ (inst jmp :eq DONE)
+ (inst break single-step-around-trap))
+ DONE
+
(note-this-location vop :call-site)
(inst ,(if (eq return :tail) 'jmp 'call)
(def unknown-key-arg-error unknown-key-arg-error
sb!c::%unknown-key-arg-error key)
(def nil-fun-returned-error nil-fun-returned-error nil fun))
+
+;;; Single-stepping
+
+(defun emit-single-step-test ()
+ ;; We use different ways of representing whether stepping is on on
+ ;; +SB-THREAD / -SB-THREAD: on +SB-THREAD, we use a slot in the
+ ;; thread structure. On -SB-THREAD we use the value of a static
+ ;; symbol. Things are done this way, since reading a thread-local
+ ;; slot from a symbol would require an extra register on +SB-THREAD,
+ ;; and reading a slot from a thread structure would require an extra
+ ;; register on -SB-THREAD. While this isn't critical for x86-64,
+ ;; it's more serious for x86.
+ #!+sb-thread
+ (inst cmp (make-ea :qword
+ :base thread-base-tn
+ :disp (* thread-stepping-slot n-word-bytes))
+ nil-value)
+ #!-sb-thread
+ (inst cmp (make-ea :qword
+ :disp (+ nil-value (static-symbol-offset
+ 'sb!impl::*stepping*)
+ (* symbol-value-slot n-word-bytes)
+ (- other-pointer-lowtag)))
+ nil-value))
+
+(define-vop (step-instrument-before-vop)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ (emit-single-step-test)
+ (inst jmp :eq DONE)
+ (inst break single-step-before-trap)
+ DONE
+ (note-this-location vop :step-before-vop)))
(#.halt-trap
(nt "halt trap"))
(#.fun-end-breakpoint-trap
- (nt "function end breakpoint trap")))))
+ (nt "function end breakpoint trap"))
+ (#.single-step-around-trap
+ (nt "single-step trap (around)"))
+ (#.single-step-before-trap
+ (nt "single-step trap (before)")))))
(define-instruction break (segment code)
(:declare (type (unsigned-byte 8) code))
cerror
breakpoint
fun-end-breakpoint
- single-step-breakpoint)
+ single-step-around
+ single-step-before)
;;; FIXME: It'd be nice to replace all the DEFENUMs with something like
;;; (WITH-DEF-ENUM (:START 8)
;;; (DEF-ENUM HALT-TRAP)
;;; for the benefit of anyone doing a lexical search for definitions
;;; of these symbols.
-(defenum (:prefix object-not- :suffix -trap :start 16)
+(defenum (:prefix object-not- :suffix -trap :start 24)
list
instance)
(:info
,@(unless (or variable (eq return :tail)) '(arg-locs))
,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(when (eq return :fixed) '(nvals))
+ step-instrumenting)
(:ignore
,@(unless (or variable (eq return :tail)) '(arg-locs))
(move ebp-tn new-fp) ; NB - now on new stack frame.
)))
+ (when step-instrumenting
+ (emit-single-step-test)
+ (inst jmp :eq DONE)
+ (inst break single-step-around-trap))
+ DONE
+
(note-this-location vop :call-site)
(inst ,(if (eq return :tail) 'jmp 'call)
(def unknown-key-arg-error unknown-key-arg-error
sb!c::%unknown-key-arg-error key)
(def nil-fun-returned-error nil-fun-returned-error nil fun))
+
+;;; Single-stepping
+
+(defun emit-single-step-test ()
+ ;; We use different ways of representing whether stepping is on on
+ ;; +SB-THREAD / -SB-THREAD: on +SB-THREAD, we use a slot in the
+ ;; thread structure. On -SB-THREAD we use the value of a static
+ ;; symbol. Things are done this way, since reading a thread-local
+ ;; slot from a symbol would require an extra register on +SB-THREAD,
+ ;; and reading a slot from a thread structure would require an extra
+ ;; register on -SB-THREAD.
+ #!+sb-thread
+ (progn
+ (inst fs-segment-prefix)
+ (inst cmp (make-ea :dword
+ :disp (* thread-stepping-slot n-word-bytes))
+ nil-value))
+ #!-sb-thread
+ (inst cmp (make-ea :dword
+ :disp (+ nil-value (static-symbol-offset
+ 'sb!impl::*stepping*)
+ (* symbol-value-slot n-word-bytes)
+ (- other-pointer-lowtag)))
+ nil-value))
+
+(define-vop (step-instrument-before-vop)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ (emit-single-step-test)
+ (inst jmp :eq DONE)
+ (inst break single-step-before-trap)
+ DONE
+ (note-this-location vop :step-before-vop)))
cerror
breakpoint
fun-end-breakpoint
- single-step-breakpoint
+ single-step-around
+ single-step-before
#!+win32 context-restore) ;; HACK: The Win32 exception handling system does wrong things with this.
;;; FIXME: It'd be nice to replace all the DEFENUMs with something like
;;; (WITH-DEF-ENUM (:START 8)
;;; for the benefit of anyone doing a lexical search for definitions
;;; of these symbols.
-(defenum (:prefix object-not- :suffix -trap :start 16)
+(defenum (:prefix object-not- :suffix -trap :start 24)
list
instance)
return compute_pc(lra, fixnum_value(codeptr->constants[REAL_LRA_SLOT+1]));
#endif
}
+
+void
+handle_single_step_trap (os_context_t *context, int kind, int register_offset)
+{
+ fake_foreign_function_call(context);
+
+ funcall3(SymbolFunction(HANDLE_SINGLE_STEP_TRAP),
+ alloc_sap(context),
+ make_fixnum(kind),
+ make_fixnum(register_offset));
+
+ undo_fake_foreign_function_call(context);
+}
sizeof(unsigned int));
break;
+ case trap_SingleStepAround:
+ case trap_SingleStepBefore:
+ {
+ int register_offset = code >> 5 & 0x1f;
+
+ handle_single_step_trap(context, trap, register_offset);
+
+ arch_skip_instruction(context);
+ break;
+ }
default:
interrupt_handle_now(signal, code, context);
break;
}
th->interrupt_data->pending_handler = 0;
th->no_tls_value_marker=initial_function;
+
+ th->stepping = NIL;
return th;
}
case trap_PendingInterrupt:
case trap_Halt:
+ case trap_SingleStepAround:
+ case trap_SingleStepBefore:
/* only needed to skip the Code */
break;
(unsigned long)handle_fun_end_breakpoint(signal, info, context);
break;
+ case trap_SingleStepAround:
+ case trap_SingleStepBefore:
+ arch_skip_instruction(context);
+ /* On x86-64 the fdefn / function is always in RAX, so we pass
+ * 0 as the register_offset. */
+ handle_single_step_trap(context, trap, 0);
+ break;
+
default:
FSHOW((stderr,"/[C--trap default %d %d %x]\n",
signal, code, context));
case trap_PendingInterrupt:
case trap_Halt:
+ case trap_SingleStepAround:
+ case trap_SingleStepBefore:
/* only needed to skip the Code */
break;
(int)handle_fun_end_breakpoint(signal, info, context);
break;
+ case trap_SingleStepAround:
+ case trap_SingleStepBefore:
+ arch_skip_instruction(context);
+ /* On x86 the fdefn / function is always in EAX, so we pass 0
+ * as the register_offset. */
+ handle_single_step_trap(context, trap, 0);
+ break;
+
default:
FSHOW((stderr,"/[C--trap default %d %d %x]\n",
signal, trap, context));
;; bug 353: This test fails at least most of the time for x86/linux
;; ca. 0.8.20.16. -- WHN
- (with-test (:name (:undefined-function :bug-356)
- :fails-on '(or (and :x86 :linux) :alpha))
+ (with-test (:name (:undefined-function :bug-353)
+ ;; This used to have fewer :fails-on features pre-0.9.16.38,
+ ;; but it turns out that the bug was just being masked by
+ ;; the presence of the IR1 stepper instrumentation (and
+ ;; is thus again failing now that the instrumentation is
+ ;; no more).
+ :fails-on '(or :x86 :x86-64 :alpha))
(assert (verify-backtrace
(lambda () (test #'not-optimized))
(list *undefined-function-frame*
;;;; number.
(run "cc"
- #+x86-64 "-fPIC"
+ #+(and linux (or x86-64 ppc)) "-fPIC"
"stack-alignment-offset.c" "-o" "stack-alignment-offset")
(defparameter *good-offset*
;;;; Build the tool again, this time as a shared object, and load it
(run "cc" "stack-alignment-offset.c"
- #+x86-64 "-fPIC"
+ #+(and linux (or x86-64 ppc)) "-fPIC"
#+darwin "-bundle" #-darwin "-shared"
"-o" "stack-alignment-offset.so")
--- /dev/null
+;;;; This file is for testing the single-stepper.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+;; No stepper support on some platforms.
+#-(or x86 x86-64 ppc)
+(sb-ext:quit :unix-status 104)
+
+(defun fib (x)
+ (declare (optimize debug))
+ (if (< x 2)
+ 1
+ (+ (fib (1- x))
+ (fib (- x 2)))))
+
+(defvar *cerror-called* nil)
+
+(defun fib-break (x)
+ (declare (optimize debug))
+ (if (< x 2)
+ (progn
+ (unless *cerror-called*
+ (cerror "a" "b")
+ (setf *cerror-called* t))
+ 1)
+ (+ (fib-break (1- x))
+ (fib-break (- x 2)))))
+
+(defun test-step-into ()
+ (let* ((results nil)
+ (expected '(("(< X 2)" :unknown)
+ ("(- X 1)" :unknown)
+ ("(FIB (1- X))" (2))
+ ("(< X 2)" :unknown)
+ ("(- X 1)" :unknown)
+ ("(FIB (1- X))" (1))
+ ("(< X 2)" :unknown)
+ ("(- X 2)" :unknown)
+ ("(FIB (- X 2))" (0))
+ ("(< X 2)" :unknown)
+ ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
+ ("(- X 2)" :unknown)
+ ("(FIB (- X 2))" (1))
+ ("(< X 2)" :unknown)
+ ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
+ (*stepper-hook* (lambda (condition)
+ (typecase condition
+ (step-form-condition
+ (push (list (step-condition-form condition)
+ (step-condition-args condition))
+ results)
+ (invoke-restart 'step-into))))))
+ (step (fib 3))
+ (assert (equal expected (reverse results)))))
+
+(defun test-step-next ()
+ (let* ((results nil)
+ (expected '(("(< X 2)" :unknown)
+ ("(- X 1)" :unknown)
+ ("(FIB (1- X))" (2))
+ ("(< X 2)" :unknown)
+ ("(- X 1)" :unknown)
+ ("(FIB (1- X))" (1))
+ ("(- X 2)" :unknown)
+ ("(FIB (- X 2))" (0))
+ ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)
+ ("(- X 2)" :unknown)
+ ("(FIB (- X 2))" (1))
+ ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
+ (count 0)
+ (*stepper-hook* (lambda (condition)
+ (typecase condition
+ (step-form-condition
+ (push (list (step-condition-form condition)
+ (step-condition-args condition))
+ results)
+ (if (< (incf count) 4)
+ (invoke-restart 'step-into)
+ (invoke-restart 'step-next)))))))
+ (step (fib 3))
+ (assert (equal expected (reverse results)))))
+
+(defun test-step-out ()
+ (let* ((results nil)
+ (expected '(("(< X 2)" :unknown)
+ ("(- X 1)" :unknown)
+ ("(FIB (1- X))" (2))
+ ("(< X 2)" :unknown)
+ ("(- X 2)" :unknown)
+ ("(FIB (- X 2))" (1))
+ ("(< X 2)" :unknown)
+ ("(+ (FIB (1- X)) (FIB (- X 2)))" :unknown)))
+ (count 0)
+ (*stepper-hook* (lambda (condition)
+ (typecase condition
+ (step-form-condition
+ (push (list (step-condition-form condition)
+ (step-condition-args condition))
+ results)
+ (if (= (incf count) 4)
+ (invoke-restart 'step-out)
+ (invoke-restart 'step-into)))))))
+ (step (fib 3))
+ (assert (equal expected (reverse results)))))
+
+(defun test-step-start-from-break ()
+ (let* ((results nil)
+ (expected '(("(- X 2)" :unknown)
+ ("(FIB-BREAK (- X 2))" (0))
+ ("(< X 2)" :unknown)
+ ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)
+ ("(- X 2)" :unknown)
+ ("(FIB-BREAK (- X 2))" (1))
+ ("(< X 2)" :unknown)
+ ("(+ (FIB-BREAK (1- X)) (FIB-BREAK (- X 2)))" :unknown)))
+ (count 0)
+ (*stepper-hook* (lambda (condition)
+ (typecase condition
+ (step-form-condition
+ (push (list (step-condition-form condition)
+ (step-condition-args condition))
+ results)
+ (invoke-restart 'step-into))))))
+ (setf *cerror-called* nil)
+ (handler-bind ((error
+ (lambda (c)
+ (sb-impl::enable-stepping)
+ (invoke-restart 'continue))))
+ (fib-break 3))
+ (assert (equal expected (reverse results)))))
+
+(defun test-step-frame ()
+ (let* ((count 0)
+ (*stepper-hook* (lambda (condition)
+ (typecase condition
+ (step-form-condition
+ (let* ((frame (sb-di::find-stepped-frame))
+ (dfun (sb-di::frame-debug-fun frame))
+ (name (sb-di::debug-fun-name dfun)))
+ (assert (equal name 'fib))
+ (incf count)))))))
+ (step (fib 3))
+ (assert (= count 6))))
+
+(defun test-step-backtrace ()
+ (let* ((*stepper-hook* (lambda (condition)
+ (typecase condition
+ (step-form-condition
+ (let ((*debug-io* (make-broadcast-stream)))
+ (backtrace)))))))
+ (step (fib 3))))
+
+(handler-bind ((step-condition (lambda (c)
+ (funcall *stepper-hook* c))))
+ (with-test (:name :step-into)
+ (test-step-into))
+ (with-test (:name :step-next)
+ (test-step-next))
+ (with-test (:name :step-out)
+ (test-step-out))
+ (with-test (:name :step-start-from-break)
+ (test-step-start-from-break))
+ (with-test (:name :step-frame)
+ (test-step-frame))
+ (with-test (:name :step-backtrace)
+ (test-step-backtrace)))
+
+
+
;;; 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.9.16.37"
+"0.9.16.38"
projects / sbcl.git / commitdiff