Lots of work on improving debugging.

doc macro can take no arguments and print out all bindings. Fix an issues with the vm skipping over a breakpoint in some situations. Add examples/debugger.janet for proof of concept debugger.
2025-10-30 23:23:07 +00:00 · 2019-11-24 17:45:53 -06:00
parent 8372d1e499
commit d37c43716a
7 changed files with 306 additions and 115 deletions
--- a/examples/debug.janet
+++ b/examples/debug.janet
@@ -0,0 +1,8 @@
+# Load this file and run (myfn) to see the debugger
+
+(defn myfn
+  []
+  (debug)
+  (for i 0 10 (print i)))
+
+(debug/fbreak myfn 3)
--- a/examples/debugger.janet
+++ b/examples/debugger.janet
@@ -0,0 +1,136 @@
+###
+### A useful debugger library for Janet. Should be used
+### inside a debug repl.
+###
+
+(defn .fiber
+  "Get the current fiber being debugged."
+  []
+  (if-let [entry (dyn '_fiber)]
+    (entry :value)
+    (dyn :fiber)))
+
+(defn .stack
+  "Print the current fiber stack"
+  []
+  (print)
+  (debug/stacktrace (.fiber) "")
+  (print))
+
+(defn .frame
+  "Show a stack frame"
+  [&opt n]
+  (def stack (debug/stack (.fiber)))
+  (in stack (or n 0)))
+
+(defn .fn
+  "Get the current function"
+  [&opt n]
+  (in (.frame n) :function))
+
+(defn .slots
+  "Get an array of slots in a stack frame"
+  [&opt n]
+  (in (.frame n) :slots))
+
+(defn .slot
+  "Get the value of the nth slot."
+  [&opt nth frame-idx]
+  (in (.slots frame-idx) (or nth 0)))
+
+(defn .quit
+  "Resume (dyn :fiber) with the value passed to it after exiting the debugger."
+  [&opt val]
+  (setdyn :exit true)
+  (setdyn :resume-value val)
+  nil)
+
+(defn .disasm
+  "Gets the assembly for the current function."
+  [&opt n]
+  (def frame (.frame n))
+  (def func (frame :function))
+  (disasm func))
+
+
+(defn .bytecode
+  "Get the bytecode for the current function."
+  [&opt n]
+  ((.disasm n) 'bytecode))
+
+(defn .ppasm
+  "Pretty prints the assembly for the current function"
+  [&opt n]
+  (def frame (.frame n))
+  (def func (frame :function))
+  (def dasm (disasm func))
+  (def bytecode (dasm 'bytecode))
+  (def pc (frame :pc))
+  (def sourcemap (dasm 'sourcemap))
+  (var last-loc [-2 -2])
+  (print "\n  function:   " (dasm 'name) " [" (in dasm 'source "") "]")
+  (printf "  constants:  %.4Q\n" (dasm 'constants))
+  (printf "  slots:      %.4Q\n\n" (frame :slots))
+  (def padding (string/repeat " " 20))
+  (loop [i :range [0 (length bytecode)]
+         :let [instr (bytecode i)]]
+    (prin (if (= (tuple/type instr) :brackets) "*" " "))
+    (prin (if (= i pc) "> " "  "))
+    (printf "\e[33m%.20s\e[0m" (string (string/join (map string instr) " ") padding))
+    (when sourcemap
+      (let [[sl sc] (sourcemap i)
+            loc [sl sc]]
+        (when (not= loc last-loc)
+          (set last-loc loc)
+          (prin " # line " sl ", column " sc))))
+    (print))
+  (print))
+
+(defn .source
+  "Show the source code for the function being debugged."
+  [&opt n]
+  (def frame (.frame n))
+  (def s (frame :source))
+  (def all-source (slurp s))
+  (print "\n\e[33m" all-source "\e[0m\n"))
+
+(defn .breakall
+  "Set breakpoints on all instructions in the current function."
+  [&opt n]
+  (def fun (.fn n))
+  (def bytecode (.bytecode n))
+  (for i 0 (length bytecode)
+    (debug/fbreak fun i))
+  (print "Set " (length bytecode) " breakpoints in " fun))
+
+(defn .clearall
+  "Clear all breakpoints on the current function."
+  [&opt n]
+  (def fun (.fn n))
+  (def bytecode (.bytecode n))
+  (for i 0 (length bytecode)
+    (debug/unfbreak fun i))
+  (print "Cleared " (length bytecode) " breakpoints in " fun))
+
+(defn .clear
+  "Clear the current breakpoint"
+  []
+  (def frame (-> (.fiber) debug/stack first))
+  (def fun (frame :function))
+  (def pc (frame :pc))
+  (debug/unfbreak fun pc)
+  (print "Cleared breakpoint in " fun " at pc=" pc))
+
+(defn .next
+  "Go to the next breakpoint."
+  [&opt n]
+  (var res nil)
+  (for i 0 (or n 1)
+    (set res (resume (.fiber))))
+  res)
+
+(defn .nextc
+  "Go to the next breakpoint, clearing the current breakpoint."
+  [&opt n]
+  (.clear)
+  (.next n))
--- a/src/boot/boot.janet
+++ b/src/boot/boot.janet
@@ -1308,6 +1308,30 @@
 ###
 ###

+(defn- env-walk
+  [pred &opt env]
+  (default env (fiber/getenv (fiber/current)))
+  (def envs @[])
+  (do (var e env) (while e (array/push envs e) (set e (table/getproto e))))
+  (def ret-set @{})
+  (loop [envi :in envs
+         k :keys envi
+         :when (pred k)]
+    (put ret-set k true))
+  (sort (keys ret-set)))
+
+(defn all-bindings
+  "Get all symbols available in an enviroment. Defaults to the current
+  fiber's environment."
+  [&opt env]
+  (env-walk symbol? env))
+
+(defn all-dynamics
+  "Get all dynamic bindings in an environment. Defaults to the current
+  fiber's environment."
+  [&opt env]
+  (env-walk keyword? env))
+
 (defn doc-format
  "Reformat text to wrap at a given line."
  [text]
@@ -1346,35 +1370,59 @@

  buf)

+(defn- print-index
+  "Print bindings in the current environment given a filter function"
+  [fltr]
+  (def bindings (filter fltr (all-bindings)))
+  (def dynamics (map describe (filter fltr (all-dynamics))))
+  (print)
+  (print (doc-format (string "Bindings:\n\n" (string/join bindings " "))))
+  (print)
+  (print (doc-format (string "Dynamics:\n\n" (string/join dynamics " "))))
+  (print))
+
 (defn doc*
  "Get the documentation for a symbol in a given environment."
-  [sym]
-  (def x (dyn sym))
-  (if (not x)
-    (print "symbol " sym " not found.")
+  [&opt sym]
+
+  (cond
+    (string? sym)
+    (print-index (fn [x] (string/find sym x)))
+
+    sym
    (do
-      (def bind-type
-        (string "    "
-                (cond
-                  (x :ref) (string :var " (" (type (in (x :ref) 0)) ")")
-                  (x :macro) :macro
-                  (type (x :value)))
-                "\n"))
-      (def sm (x :source-map))
-      (def d (x :doc))
-      (print "\n\n"
-             (if d bind-type "")
-             (if-let [[path line col] sm]
-               (string "    " path " on line " line ", column " col "\n") "")
-             (if (or d sm) "\n" "")
-             (if d (doc-format d) "no documentation found.")
-             "\n\n"))))
+      (def x (dyn sym))
+      (if (not x)
+        (print "symbol " sym " not found.")
+        (do
+          (def bind-type
+            (string "    "
+                    (cond
+                      (x :ref) (string :var " (" (type (in (x :ref) 0)) ")")
+                      (x :macro) :macro
+                      (type (x :value)))
+                    "\n"))
+          (def sm (x :source-map))
+          (def d (x :doc))
+          (print "\n\n"
+                 (if d bind-type "")
+                 (if-let [[path line col] sm]
+                   (string "    " path " on line " line ", column " col "\n") "")
+                 (if (or d sm) "\n" "")
+                 (if d (doc-format d) "no documentation found.")
+                 "\n\n"))))
+
+    # else
+    (print-index identity)))

 (defmacro doc
  "Shows documentation for the given symbol."
-  [sym]
+  [&opt sym]
  ~(,doc* ',sym))

+(put _env 'env-walk nil)
+(put _env 'print-index nil)
+
 ###
 ###
 ### Macro Expansion
@@ -1719,8 +1767,10 @@
              (on-compile-error msg errf where))))
        (or guard :a)))
    (fiber/setenv f env)
-    (def res (resume f nil))
-    (when good (if going (onstatus f res))))
+    (while (let [fs (fiber/status f)]
+             (and (not= :dead fs) (not= :error fs)))
+      (def res (resume f nil))
+      (when good (when going (onstatus f res)))))

  # Loop
  (def buf @"")
@@ -1746,14 +1796,16 @@
  (when (= (parser/status p) :error)
    (on-parse-error p where))

-  env)
+  (in env :exit-value env))

 (defn quit
  "Tries to exit from the current repl or context. Does not always exit the application.
-  Works by setting the :exit dynamic binding to true."
-  []
+  Works by setting the :exit dynamic binding to true. Passing a non-nil value here will cause the outer
+  run-context to return that value."
+  [&opt value]
  (setdyn :exit true)
-  "Bye!")
+  (setdyn :exit-value value)
+  nil)

 (defn eval-string
  "Evaluates a string in the current environment. If more control over the
@@ -1908,8 +1960,11 @@
  (def f (if (= (type path) :core/file)
           path
           (file/open path :rb)))
+  (def path-is-file (= f path))
  (default env (make-env))
-  (put env :current-file (string path))
+  (def spath (string path))
+  (put env :current-file (if-not path-is-file spath))
+  (put env :source (if-not path-is-file spath path))
  (defn chunks [buf _] (file/read f 2048 buf))
  (defn bp [&opt x y]
    (def ret (bad-parse x y))
@@ -1921,19 +1976,20 @@
    ret)
  (unless f
    (error (string "could not find file " path)))
-  (run-context {:env env
-                :chunks chunks
-                :on-parse-error bp
-                :on-compile-error bc
-                :on-status (fn [f x]
-                             (when (not= (fiber/status f) :dead)
-                               (debug/stacktrace f x)
-                               (if exit-on-error (os/exit 1))))
-                :evaluator evaluator
-                :expander expander
-                :source (or source (if (= f path) "<anonymous>" path))})
-  (when (not= f path) (file/close f))
-  env)
+  (def nenv
+    (run-context {:env env
+                  :chunks chunks
+                  :on-parse-error bp
+                  :on-compile-error bc
+                  :on-status (fn [f x]
+                               (when (not= (fiber/status f) :dead)
+                                 (debug/stacktrace f x)
+                                 (if exit-on-error (os/exit 1))))
+                  :evaluator evaluator
+                  :expander expander
+                  :source (if path-is-file "<anonymous>" spath)}))
+  (if-not path-is-file (file/close f))
+  nenv)

 (def module/loaders
  "A table of loading method names to loading functions.
@@ -1943,7 +1999,6 @@
    :source (fn [path args]
              (put module/loading path true)
              (def newenv (dofile path ;args))
-              (put newenv :source path)
              (put module/loading path nil)
              newenv)
    :image (fn [path &] (load-image (slurp path)))})
@@ -2000,73 +2055,57 @@
  [& modules]
  ~(do ,;(map (fn [x] ~(,import* ,(string x) :prefix "")) modules)))

+###
+###
+### REPL
+###
+###
+
 (defn repl
  "Run a repl. The first parameter is an optional function to call to
  get a chunk of source code that should return nil for end of file.
  The second parameter is a function that is called when a signal is
-  caught."
+  caught. Lastly, one can provide an optional environment table to run
+  the repl in."
  [&opt chunks onsignal env]
-  (def level (+ (dyn :debug-level 0) 1))
  (default env (make-env))
  (default chunks (fn [buf p] (getline (string "repl:"
                                               ((parser/where p) 0)
                                               ":"
                                               (parser/state p :delimiters) "> ")
                                       buf)))
-  (default onsignal (fn [f x]
-                      (case (fiber/status f)
-                        :dead (do
-                                (pp x)
-                                (put env '_ @{:value x}))
-                        :debug (let [nextenv (make-env env)]
-                                 (put nextenv '_fiber @{:value f})
-                                 (setdyn :debug-level level)
-                                 (debug/stacktrace f x)
-                                 (print ```
+  (defn make-onsignal
+    [e level]
+    (fn [f x]
+      (case (fiber/status f)
+        :dead (do
+                (pp x)
+                (put e '_ @{:value x}))
+        :debug (let [nextenv (make-env env)]
+                 (put nextenv :fiber f)
+                 (put nextenv :debug-level level)
+                 (debug/stacktrace f x)
+                 (defn debugger-chunks [buf p]
+                   (def status (parser/state p :delimiters))
+                   (def c ((parser/where p) 0))
+                   (def prompt (string "debug[" level "]:" c ":" status "> "))
+                   (getline prompt buf))
+                 (repl debugger-chunks (make-onsignal nextenv (+ 1 level)) nextenv)
+                 (print "exiting debug[" level "]")
+                 (def lastval (get-in nextenv ['_ :value] (nextenv :resume-value)))
+                 (pp lastval)
+                 (put e '_ @{:value lastval}))
+        (debug/stacktrace f x))))

-entering debugger - (quit) or Ctrl-D to exit
-_fiber is bound to the suspended fiber
+  (default onsignal (make-onsignal env 1))

-```)
-                          (repl (fn [buf p]
-                                  (def status (parser/state p :delimiters))
-                                  (def c ((parser/where p) 0))
-                                  (def prompt (string "debug[" level "]:" c ":" status "> "))
-                                  (getline prompt buf))
-                                onsignal nextenv))
-                        (debug/stacktrace f x))))
  (run-context {:env env
                :chunks chunks
                :on-status onsignal
                :source "repl"}))

-(defn- env-walk
-  [pred &opt env]
-  (default env (fiber/getenv (fiber/current)))
-  (def envs @[])
-  (do (var e env) (while e (array/push envs e) (set e (table/getproto e))))
-  (def ret-set @{})
-  (loop [envi :in envs
-         k :keys envi
-         :when (pred k)]
-    (put ret-set k true))
-  (sort (keys ret-set)))
-
-(defn all-bindings
-  "Get all symbols available in an enviroment. Defaults to the current
-  fiber's environment."
-  [&opt env]
-  (env-walk symbol? env))
-
-(defn all-dynamics
-  "Get all dynamic bindings in an environment. Defaults to the current
-  fiber's environment."
-  [&opt env]
-  (env-walk keyword? env))
-
 # Clean up some extra defs
 (put _env 'boot/opts nil)
-(put _env 'env-walk nil)
 (put _env '_env nil)

 ###
--- a/src/core/bytecode.c
+++ b/src/core/bytecode.c
@@ -203,7 +203,7 @@ int32_t janet_verify(JanetFuncDef *def) {

 /* Allocate an empty funcdef. This function may have added functionality
 * as commonalities between asm and compile arise. */
-JanetFuncDef *janet_funcdef_alloc() {
+JanetFuncDef *janet_funcdef_alloc(void) {
    JanetFuncDef *def = janet_gcalloc(JANET_MEMORY_FUNCDEF, sizeof(JanetFuncDef));
    def->environments = NULL;
    def->constants = NULL;
--- a/src/core/cfuns.c
+++ b/src/core/cfuns.c
@@ -27,10 +27,6 @@
 #include "vector.h"
 #endif

-static int fixarity0(JanetFopts opts, JanetSlot *args) {
-    (void) opts;
-    return janet_v_count(args) == 0;
-}
 static int fixarity1(JanetFopts opts, JanetSlot *args) {
    (void) opts;
    return janet_v_count(args) == 1;
@@ -101,8 +97,13 @@ static JanetSlot do_error(JanetFopts opts, JanetSlot *args) {
 }
 static JanetSlot do_debug(JanetFopts opts, JanetSlot *args) {
    (void)args;
-    janetc_emit(opts.compiler, JOP_SIGNAL | (2 << 24));
-    return janetc_cslot(janet_wrap_nil());
+    int32_t len = janet_v_count(args);
+    JanetSlot t = janetc_gettarget(opts);
+    janetc_emit_ssu(opts.compiler, JOP_SIGNAL, t,
+            (len == 1) ? args[0] : janetc_cslot(janet_wrap_nil()),
+            JANET_SIGNAL_DEBUG,
+            1);
+    return t;
 }
 static JanetSlot do_in(JanetFopts opts, JanetSlot *args) {
    return opreduce(opts, args, JOP_GET, janet_wrap_nil());
@@ -270,7 +271,7 @@ static JanetSlot do_neq(JanetFopts opts, JanetSlot *args) {

 /* Arranged by tag */
 static const JanetFunOptimizer optimizers[] = {
-    {fixarity0, do_debug},
+    {maxarity1, do_debug},
    {fixarity1, do_error},
    {minarity2, do_apply},
    {maxarity1, do_yield},
--- a/src/core/corelib.c
+++ b/src/core/corelib.c
@@ -953,7 +953,7 @@ static const uint32_t error_asm[] = {
 };
 static const uint32_t debug_asm[] = {
    JOP_SIGNAL | (2 << 24),
-    JOP_RETURN_NIL
+    JOP_RETURN
 };
 static const uint32_t yield_asm[] = {
    JOP_SIGNAL | (3 << 24),
@@ -1002,17 +1002,17 @@ JanetTable *janet_core_env(JanetTable *replacements) {
                         "fiber is in a state that can be resumed, resuming the current fiber will "
                         "first resume fiber."));
    janet_quick_asm(env, JANET_FUN_DEBUG,
-                    "debug", 0, 0, 0, 1, debug_asm, sizeof(debug_asm),
-                    JDOC("(debug)\n\n"
+                    "debug", 1, 0, 1, 1, debug_asm, sizeof(debug_asm),
+                    JDOC("(debug &opt x)\n\n"
                         "Throws a debug signal that can be caught by a parent fiber and used to inspect "
-                         "the running state of the current fiber. Returns nil."));
+                         "the running state of the current fiber. Returns the value passed in by resume."));
    janet_quick_asm(env, JANET_FUN_ERROR,
                    "error", 1, 1, 1, 1, error_asm, sizeof(error_asm),
                    JDOC("(error e)\n\n"
                         "Throws an error e that can be caught and handled by a parent fiber."));
    janet_quick_asm(env, JANET_FUN_YIELD,
                    "yield", 1, 0, 1, 2, yield_asm, sizeof(yield_asm),
-                    JDOC("(yield x)\n\n"
+                    JDOC("(yield &opt x)\n\n"
                         "Yield a value to a parent fiber. When a fiber yields, its execution is paused until "
                         "another thread resumes it. The fiber will then resume, and the last yield call will "
                         "return the value that was passed to resume."));
--- a/src/core/vm.c
+++ b/src/core/vm.c
@@ -490,21 +490,20 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
     * waiting to be resumed. In those cases, use input and increment pc. We
     * DO NOT use input when resuming a fiber that has been interrupted at a
     * breakpoint. */
+    uint8_t first_opcode;
    if (status != JANET_STATUS_NEW &&
            ((*pc & 0xFF) == JOP_SIGNAL ||
             (*pc & 0xFF) == JOP_PROPAGATE ||
             (*pc & 0xFF) == JOP_RESUME)) {
        stack[A] = in;
        pc++;
+        first_opcode = *pc & 0xFF;
+    } else if (status == JANET_STATUS_DEBUG) {
+        first_opcode = *pc & 0x7F;
+    } else {
+        first_opcode = *pc & 0xFF;
    }

-    /* The first opcode to execute. If the first opcode has
-     * the breakpoint bit set and we were in the debug state, skip
-     * that first breakpoint. */
-    uint8_t first_opcode = (status == JANET_STATUS_DEBUG)
-                           ? (*pc & 0x7F)
-                           : (*pc & 0xFF);
-
    /* Main interpreter loop. Semantically is a switch on
     * (*pc & 0xFF) inside of an infinite loop. */
    VM_START();
@@ -894,7 +893,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
        JanetFiber *f = janet_unwrap_fiber(fv);
        JanetFiberStatus sub_status = janet_fiber_status(f);
        if (sub_status > JANET_STATUS_USER9) {
-            vm_throw("cannot propagate from new or alive fiber");
+            vm_commit();
+            janet_panicf("cannot propagate from fiber with status :%s",
+                         janet_status_names[sub_status]);
        }
        janet_vm_fiber->child = f;
        vm_return((int) sub_status, stack[B]);
@@ -949,8 +950,10 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
    VM_OP(JOP_MAKE_TABLE) {
        int32_t count = fiber->stacktop - fiber->stackstart;
        Janet *mem = fiber->data + fiber->stackstart;
-        if (count & 1)
-            vm_throw("expected even number of arguments to table constructor");
+        if (count & 1) {
+            vm_commit();
+            janet_panicf("expected even number of arguments to table constructor, got %d", count);
+        }
        JanetTable *table = janet_table(count / 2);
        for (int32_t i = 0; i < count; i += 2)
            janet_table_put(table, mem[i], mem[i + 1]);
@@ -962,8 +965,10 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
    VM_OP(JOP_MAKE_STRUCT) {
        int32_t count = fiber->stacktop - fiber->stackstart;
        Janet *mem = fiber->data + fiber->stackstart;
-        if (count & 1)
-            vm_throw("expected even number of arguments to struct constructor");
+        if (count & 1) {
+            vm_commit();
+            janet_panicf("expected even number of arguments to struct constructor, got %d", count);
+        }
        JanetKV *st = janet_struct_begin(count / 2);
        for (int32_t i = 0; i < count; i += 2)
            janet_struct_put(st, mem[i], mem[i + 1]);
@@ -1045,7 +1050,9 @@ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) {
    if (old_status == JANET_STATUS_ALIVE ||
            old_status == JANET_STATUS_DEAD ||
            old_status == JANET_STATUS_ERROR) {
-        *out = janet_cstringv("cannot resume alive, dead, or errored fiber");
+        const uint8_t *str = janet_formatc("cannot resume fiber with status :%s",
+                                           janet_status_names[old_status]);
+        *out = janet_wrap_string(str);
        return JANET_SIGNAL_ERROR;
    }