0.9.16.38:

[sbcl.git] / src / compiler / x86 / call.lisp

diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp
index 5f4f80a..3cca339 100644 (file)
--- a/src/compiler/x86/call.lisp
+++ b/src/compiler/x86/call.lisp
@@ -759,7 +759,8 @@
                (: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))
@@ -893,6 +894,12 @@
                           (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)
@@ -1436,3 +1443,37 @@
   (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)))