Stepping in bytecode

It should be possible to get sources, but saving them would be kind
of involved so I'm not so sure about that one. Also we really ought
to get arguments in native compiled functions.

Author: Bike

include/clasp/core/step.h

@@ -0,0 +1,12 @@
+#pragma once
+
+#include <clasp/core/foundation.h>
+#include <clasp/core/object.h>
+#include <clasp/core/lisp.h>
+
+namespace core {
+
+void breakstep(T_sp source, void* frame);
+void breakstep_args(void* frame, Function_sp fun, List_sp args);
+
+}; // namespace core

src/core/bytecode.cc

@@ -16,6 +16,7 @@
 #include <clasp/core/designators.h> // calledFunctionDesignator
 #include <clasp/core/evaluator.h>   // eval::funcall
 #include <clasp/gctools/interrupt.h> // handle_all_queued_interrupts
+#include <clasp/core/step.h> // breakstep_arguments
 
 #define VM_CODES
 #include <virtualMachine.h>
@@ -60,6 +61,19 @@ void BytecodeModule_O::register_for_debug() {
     newc->setCdr(old);
 }
 
+// Note that we check stepping in the callER not the callEE.
+// This is so that we could provide the actual source forms, as we already do
+// in native code. TODO
+static void maybe_step_call(void* frame,
+                            Function_sp func, size_t nargs, T_O** rargs) {
+  if (my_thread->_Breakstep) [[unlikely]] {
+    ql::list args;
+    for (size_t iarg = 0; iarg < nargs; ++iarg)
+      args << T_sp((gctools::Tagged)rargs[iarg]);
+    breakstep_args(frame, func, args.cons());
+  }
+}
+
 static inline int16_t read_s16(unsigned char* pc) {
   uint8_t byte0 = *pc;
   uint8_t byte1 = *(pc + 1);
@@ -259,6 +273,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure
       T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
       Function_sp func = gc::As_assert<Function_sp>(tfunc);
       T_O** args = vm.stackref(sp, nargs - 1);
+      maybe_step_call(__builtin_frame_address(0), func, nargs, args);
       // We push the PC for the debugger (see make_bytecode_frame in backtrace.cc)
       // We do this here rather than bytecode_call because e.g. we may call a
       // non-bytecode function, that in turn calls a bunch of different bytecode
@@ -281,6 +296,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure
       VM_RECORD_PLAYBACK(func, "vm_call_receive_one_func");
       VM_RECORD_PLAYBACK((void*)(uintptr_t)nargs, "vm_call_receive_one_nargs");
       T_O** args = vm.stackref(sp, nargs - 1);
+      maybe_step_call(__builtin_frame_address(0), func, nargs, args);
 #if DEBUG_VM_RECORD_PLAYBACK == 1
       for (size_t ii = 0; ii < nargs; ii++) {
         stringstream name_args;
@@ -305,6 +321,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure
       T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
       Function_sp func = gc::As_assert<Function_sp>(tfunc);
       T_O** args = vm.stackref(sp, nargs - 1);
+      maybe_step_call(__builtin_frame_address(0), func, nargs, args);
       vm.push(sp, (T_O*)pc);
       vm._pc = pc;
       vm._stackPointer = sp;
@@ -658,6 +675,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure
       T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
       Function_sp func = gc::As_assert<Function_sp>(tfunc);
       T_O** args = vm.stackref(sp, nargs - 1);
+      maybe_step_call(__builtin_frame_address(0), func, nargs, args);
       vm.push(sp, (T_O*)pc);
       vm._pc = pc;
       vm._stackPointer = sp;
@@ -675,6 +693,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure
       T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
       Function_sp func = gc::As_assert<Function_sp>(tfunc);
       T_O** args = vm.stackref(sp, nargs - 1);
+      maybe_step_call(__builtin_frame_address(0), func, nargs, args);
       vm.push(sp, (T_O*)pc);
       vm._pc = pc;
       vm._stackPointer = sp;
@@ -693,6 +712,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure
       T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
       Function_sp func = gc::As_assert<Function_sp>(tfunc);
       T_O** args = vm.stackref(sp, nargs - 1);
+      maybe_step_call(__builtin_frame_address(0), func, nargs, args);
       vm.push(sp, (T_O*)pc);
       vm._pc = pc;
       vm._stackPointer = sp;
@@ -1045,6 +1065,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi
     T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
     Function_sp func = gc::As_assert<Function_sp>(tfunc);
     T_O** args = vm.stackref(sp, nargs - 1);
+    maybe_step_call(__builtin_frame_address(0), func, nargs, args);
     vm.push(sp, (T_O*)pc);
     vm._pc = pc;
     vm._stackPointer = sp;
@@ -1060,9 +1081,10 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi
     DBG_VM1("long call-receive-one %" PRIu16 "\n", nargs);
     T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
     Function_sp func = gc::As_assert<Function_sp>(tfunc);
+    T_O** args = vm.stackref(sp, nargs - 1);
+    maybe_step_call(__builtin_frame_address(0), func, nargs, args);
     VM_RECORD_PLAYBACK(func, "vm_call_receive_one_func");
     VM_RECORD_PLAYBACK((void*)(uintptr_t)nargs, "vm_call_receive_one_nargs");
-    T_O** args = vm.stackref(sp, nargs - 1);
 #if DEBUG_VM_RECORD_PLAYBACK == 1
     for (size_t ii = 0; ii < nargs; ii++) {
       stringstream name_args;
@@ -1089,6 +1111,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi
     T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
     Function_sp func = gc::As_assert<Function_sp>(tfunc);
     T_O** args = vm.stackref(sp, nargs - 1);
+    maybe_step_call(__builtin_frame_address(0), func, nargs, args);
     vm.push(sp, (T_O*)pc);
     vm._pc = pc;
     vm._stackPointer = sp;
@@ -1307,6 +1330,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi
     T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs))));
     Function_sp func = gc::As_assert<Function_sp>(tfunc);
     T_O** args = vm.stackref(sp, nargs - 1);
+    maybe_step_call(__builtin_frame_address(0), func, nargs, args);
     vm.push(sp, (T_O*)pc);
     vm._pc = pc;
     vm._stackPointer = sp;

src/core/corePackage.cc

@@ -211,6 +211,7 @@ SYMBOL_EXPORT_SC_(CorePkg, _PLUS_fe_overflow_PLUS_);
 SYMBOL_EXPORT_SC_(CorePkg, arguments);
 SYMBOL_EXPORT_SC_(CorePkg, array_out_of_bounds);
 SYMBOL_EXPORT_SC_(CorePkg, breakstep);
+SYMBOL_EXPORT_SC_(CorePkg, breakstep_arguments);
 SYMBOL_EXPORT_SC_(CorePkg, c_local);
 SYMBOL_EXPORT_SC_(CorePkg, circle_subst);
 SYMBOL_EXPORT_SC_(CorePkg, class_source_location)

src/core/cscript.lisp

@@ -17,6 +17,7 @@
            #~"stackmap.cc"
            #~"debugger.cc"
            #~"debugger2.cc"
+           #~"step.cc"
            #~"backtrace.cc"
            #~"bytecode.cc"
            #~"bytecode_compiler.cc"

src/core/debugger2.cc

@@ -13,6 +13,7 @@
 #include <clasp/core/lispStream.h>
 #include <clasp/core/wrappers.h>
 #include <clasp/core/backtrace.h>
+#include <clasp/gctools/threadlocal.h> // ThreadLocalState access
 
 namespace core {
 

src/core/step.cc

@@ -0,0 +1,87 @@
+#include <clasp/core/foundation.h>
+#include <clasp/core/object.h>
+#include <clasp/core/lisp.h>
+#include <clasp/core/evaluator.h>
+#include <clasp/gctools/threadlocal.h>
+
+namespace core {
+
+// RAII thing to toggle breakstep while respecting nonlocal exit.
+// TODO: Check that this works with our unwinding? Not sure it does
+struct BreakstepToggle {
+  ThreadLocalState* mthread;
+  bool old_breakstep;
+  BreakstepToggle(ThreadLocalState* thread, bool new_breakstep) {
+    mthread = thread;
+    old_breakstep = thread->_Breakstep;
+    thread->_Breakstep = new_breakstep;
+  }
+  ~BreakstepToggle() { mthread->_Breakstep = old_breakstep; }
+};
+
+void breakstep(T_sp source, void* frame) {
+  void* bframe = my_thread->_BreakstepFrame;
+  // If bframe is NULL, we are doing step-into.
+  // Otherwise, we are doing step-over, and we need to check
+  // if we've returned yet. bframe is the frame step-over was initiated
+  // from, and lframe/frame is the caller frame.
+  // We have to check here because a function being stepped over may
+  // nonlocally exit past the caller, and in that situation we want to
+  // resume stepping.
+  // FIXME: We assume stack growth direction here.
+  if (!bframe || (frame >= bframe)) {
+    // Make sure we don't invoke the stepper recursively,
+    // but can do so again once we're out of the Lisp interaction.
+    BreakstepToggle tog(my_thread, false);
+    T_sp res = core::eval::funcall(core::_sym_breakstep, source);
+    if (res.fixnump()) {
+      switch (res.unsafe_fixnum()) {
+      case 0:
+          goto stop_stepping;
+      case 1:
+          my_thread->_BreakstepFrame = NULL;
+          return;
+      case 2:
+          my_thread->_BreakstepFrame = frame;
+          return;
+      }
+    }
+    SIMPLE_ERROR("BUG: Unknown return value from {}: {}", _rep_(core::_sym_breakstep), _rep_(res));
+  } else
+    return;
+ stop_stepping: // outside the scope of tog
+  my_thread->_Breakstep = false;
+  return;
+}
+
+// when we have a call but no source - bytecode for now FIXME
+void breakstep_args(void* frame, Function_sp function, List_sp args) {
+  void* bframe = my_thread->_BreakstepFrame;
+  // FIXME: We assume stack growth direction here.
+  if (!bframe || (frame >= bframe)) {
+    // Make sure we don't invoke the stepper recursively,
+    // but can do so again once we're out of the Lisp interaction.
+    BreakstepToggle tog(my_thread, false);
+    T_sp res = core::eval::funcall(core::_sym_breakstep_arguments,
+                                   function, args);
+    if (res.fixnump()) {
+      switch (res.unsafe_fixnum()) {
+      case 0:
+          goto stop_stepping;
+      case 1:
+          my_thread->_BreakstepFrame = NULL;
+          return;
+      case 2:
+          my_thread->_BreakstepFrame = frame;
+          return;
+      }
+    }
+    SIMPLE_ERROR("BUG: Unknown return value from {}: {}", _rep_(core::_sym_breakstep), _rep_(res));
+  } else
+    return;
+ stop_stepping: // outside the scope of tog
+  my_thread->_Breakstep = false;
+  return;
+}
+
+}; // namespace core

src/lisp/kernel/clos/conditions.lisp

@@ -493,14 +493,13 @@ format string."
                          :FORMAT-ARGUMENTS format-arguments)))))
   nil)
 
-(defun breakstep (source)
+(defun %breakstep (condition)
   "Pause due to stepping or a breakpoint."
   (clasp-debug:with-truncated-stack ()
     (restart-case
         (let ((*debugger-hook* nil))
-          (invoke-debugger
-           (make-condition 'clasp-debug:step-form :source source)))
-      ;; cc_breakstep interprets our return value as follows:
+          (invoke-debugger condition))
+      ;; the C++ breakstep interprets our return value as follows:
       ;; 0: continue without stepping
       ;; 1: step-into
       ;; 2: step-over
@@ -509,12 +508,21 @@ format string."
         :report "Resume normal, unstepped execution."
         0)
       (clasp-debug:step-into ()
-        :report "Step into call."
+        :report "Step into form."
         1)
       (clasp-debug:step-over ()
-        :report "Step over call."
+        :report "Step over form."
         2))))
 
+;;; called from C++ - see step.cc
+(defun breakstep (source)
+  (%breakstep (make-condition 'clasp-debug:step-form :source source)))
+(defun breakstep-arguments (function arguments &optional source)
+  (%breakstep (make-condition 'clasp-debug:step-call
+                              :source source
+                              :function function :arguments arguments
+                              :arguments-available-p t)))
+
 (defun warn (datum &rest arguments)
   "Args: (format-string &rest args)
 Formats FORMAT-STRING and ARGs to *ERROR-OUTPUT* as a warning message.  Enters
@@ -1255,12 +1263,32 @@ The conflict resolver must be one of ~s" chosen-symbol candidates))
 			   for value in values
 			   collect (assert-prompt place-name value)))))))
 
-(define-condition step-condition () ())
+(define-condition clasp-debug:step-condition () ())
 
-(define-condition clasp-debug:step-form (step-condition)
+(define-condition clasp-debug:step-form (clasp-debug:step-condition)
   ((%source :initarg :source :reader source))
   (:report (lambda (condition stream)
-             (format stream "Evaluating form: ~s" (source condition)))))
+             (format stream "Evaluating form:~%~t~s" (source condition)))))
+
+(define-condition clasp-debug:step-call (clasp-debug:step-condition)
+  ((%source :initarg :source :reader source)
+   (%called-function :initarg :function :reader called-function)
+   (%arguments :initarg :arguments :reader arguments)
+   (%arguments-available-p :initarg :arguments-available-p
+                           :reader arguments-available-p))
+  (:report (lambda (condition stream)
+             (let ((form (source condition)))
+               (if form ; NIL is never really a call
+                   (format stream "Evaluating form:~%~t~s" form)
+                   (let* ((function (called-function condition))
+                          (name (and function (core:function-name function)))
+                          (dname (if (eq name 'cl:lambda)
+                                     "anonymous function"
+                                     name)))
+                     (format stream "Calling ~a" name))))
+             (when (arguments-available-p condition)
+               (format stream "~%With arguments:~%~t~s"
+                       (arguments condition))))))
 
 ;;; ----------------------------------------------------------------------
 ;;; Unicode, initially forgotten in clasp

src/lisp/kernel/lsp/debug.lisp

@@ -43,7 +43,8 @@
     ;; misc
     (%export '(#:function-name-package))
     ;; stepper
-    (%export '(#:step-form #:step-into #:step-over))
+    (%export '(#:step-condition #:step-form #:step-call
+               #:step-into #:step-over))
     (import '(core:set-breakstep core:unset-breakstep core:breakstepping-p))
     (export '(core:set-breakstep core:unset-breakstep core:breakstepping-p))))
 

src/lisp/regression-tests/debug.lisp

@@ -264,23 +264,27 @@
              (let ((ext:*invoke-debugger-hook*
                      (lambda (condition old-hook)
                        (declare (ignore old-hook))
-                       (return (typep condition 'clasp-debug:step-form)))))
+                       (return (typep condition 'clasp-debug:step-condition)))))
                (step (print 4)))))
 
 (test breakstepping-p
-      (values (progn (clasp-debug:set-breakstep)
-                     (clasp-debug:breakstepping-p))
-              (progn (clasp-debug:unset-breakstep)
-                     (clasp-debug:breakstepping-p)))
-      (t nil))
+  (let ((ext:*invoke-debugger-hook* ; don't step during the test!
+          (lambda (condition old-hook)
+            (declare (ignore condition old-hook))
+            (invoke-restart 'clasp-debug:step-over))))
+    (values (progn (clasp-debug:set-breakstep)
+                   (clasp-debug:breakstepping-p))
+            (progn (clasp-debug:unset-breakstep)
+                   (clasp-debug:breakstepping-p))))
+  (t nil))
 
 ;;; breakstep can also be used to enable the stepper, without STEP itself.
 (test-true breakstep
            (block nil
              (let ((ext:*invoke-debugger-hook*
                      (lambda (condition old-hook)
                        (declare (ignore old-hook))
-                       (return (typep condition 'clasp-debug:step-form)))))
+                       (return (typep condition 'clasp-debug:step-condition)))))
                (clasp-debug:set-breakstep)
                (unwind-protect
                     (locally