Merge pull request #1725 from clasp-developers/bytecode-step

Stepping in bytecode

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