From 88b8418253475feff4f1ebd94338ecd6ab3d7164 Mon Sep 17 00:00:00 2001
From: Calvin Rose <calsrose@gmail.com>
Date: Sat, 4 May 2019 15:03:41 -0400
Subject: [PATCH] Add simple tracing functionality to VM.

Also disable debugger for normal errors.
---
 CHANGELOG.md        |  1 +
 src/boot/boot.janet | 15 +++++++--------
 src/core/corelib.c  | 24 ++++++++++++++++++++++++
 src/core/vm.c       | 19 +++++++++++++++++++
 src/include/janet.h |  2 ++
 5 files changed, 53 insertions(+), 8 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6a02553f..a9a61092 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,7 @@
 All notable changes to this project will be documented in this file.
 
 ## 0.5.0 - ??
+- Add `trace` and `untrace` to the core library.
 - Add `string/has-prefix?` and `string/has-suffix?` to string module.
 - Add simple debugger to repl that activates on errors or debug signal
 - Remove `*env*` and `*doc-width*`.
diff --git a/src/boot/boot.janet b/src/boot/boot.janet
index e7aff188..bcc87c43 100644
--- a/src/boot/boot.janet
+++ b/src/boot/boot.janet
@@ -1732,16 +1732,14 @@
                         :dead (do
                                 (pp x)
                                 (put env '_ @{:value x}))
-                        (let [nextenv (make-env env)]
-                          (put nextenv '_fiber @{:value f})
-                          (put nextenv '_signal @{:value x})
-                          (setdyn :debug-level level)
-                          (debug/stacktrace f x)
-                          (print ```
+                        :debug (let [nextenv (make-env env)]
+                                 (put nextenv '_fiber @{:value f})
+                                 (setdyn :debug-level level)
+                                 (debug/stacktrace f x)
+                                 (print ```
 
 entering debugger - Ctrl-D to exit
 _fiber is bound to the suspended fiber
-_signal is the error or signal value
 
 ```)
                           (repl (fn [buf p]
@@ -1749,7 +1747,8 @@ _signal is the error or signal value
                                   (def c (parser/where p))
                                   (def prompt (string "debug[" level "]:" c ":" status "> "))
                                   (getline prompt buf))
-                                onsignal nextenv)))))
+                                onsignal nextenv))
+                        (debug/stacktrace f x))))
   (run-context {:env env
                 :chunks chunks
                 :on-status onsignal
diff --git a/src/core/corelib.c b/src/core/corelib.c
index 1860cd6b..39d6958d 100644
--- a/src/core/corelib.c
+++ b/src/core/corelib.c
@@ -273,6 +273,20 @@ static Janet janet_core_getline(int32_t argc, Janet *argv) {
     return janet_wrap_buffer(buf);
 }
 
+static Janet janet_core_trace(int32_t argc, Janet *argv) {
+    janet_fixarity(argc, 1);
+    JanetFunction *func = janet_getfunction(argv, 0);
+    func->gc.flags |= JANET_FUNCFLAG_TRACE;
+    return argv[0];
+}
+
+static Janet janet_core_untrace(int32_t argc, Janet *argv) {
+    janet_fixarity(argc, 1);
+    JanetFunction *func = janet_getfunction(argv, 0);
+    func->gc.flags &= ~JANET_FUNCFLAG_TRACE;
+    return argv[0];
+}
+
 static const JanetReg corelib_cfuns[] = {
     {
         "native", janet_core_native,
@@ -432,6 +446,16 @@ static const JanetReg corelib_cfuns[] = {
         JDOC("(setdyn key value)\n\n"
              "Set a dynamic binding. Returns value.")
     },
+    {
+        "trace", janet_core_trace,
+        JDOC("(trace func)\n\n"
+             "Enable tracing on a function. Returns the function.")
+    },
+    {
+        "untrace", janet_core_untrace,
+        JDOC("(untrace func)\n\n"
+             "Disables tracing on a function. Returns the function.")
+    },
     {NULL, NULL, NULL}
 };
 
diff --git a/src/core/vm.c b/src/core/vm.c
index 6513a587..5e5f652d 100644
--- a/src/core/vm.c
+++ b/src/core/vm.c
@@ -224,6 +224,23 @@ static void *op_lookup[255] = {
 #define vm_bitop(op) _vm_bitop(op, int32_t)
 #define vm_bitopu(op) _vm_bitop(op, uint32_t)
 
+/* Trace a function call */
+static void vm_do_trace(JanetFunction *func) {
+    Janet *stack = janet_vm_fiber->data + janet_vm_fiber->stackstart;
+    int32_t start = janet_vm_fiber->stackstart;
+    int32_t end = janet_vm_fiber->stacktop;
+    int32_t argc = end - start;
+    if (func->def->name) {
+        janet_printf("trace (%S", func->def->name);
+    } else {
+        janet_printf("trace (%p", janet_wrap_function(func));
+    }
+    for (int32_t i = 0; i < argc; i++) {
+        janet_printf(" %p", stack[i]);
+    }
+    printf(")\n");
+}
+
 /* Call a non function type */
 static Janet call_nonfn(JanetFiber *fiber, Janet callee) {
     int32_t argn = fiber->stacktop - fiber->stackstart;
@@ -563,6 +580,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
         }
         if (janet_checktype(callee, JANET_FUNCTION)) {
             func = janet_unwrap_function(callee);
+            if (func->gc.flags & JANET_FUNCFLAG_TRACE) vm_do_trace(func);
             janet_stack_frame(stack)->pc = pc;
             if (janet_fiber_funcframe(fiber, func)) {
                 int32_t n = fiber->stacktop - fiber->stackstart;
@@ -598,6 +616,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
         }
         if (janet_checktype(callee, JANET_FUNCTION)) {
             func = janet_unwrap_function(callee);
+            if (func->gc.flags & JANET_FUNCFLAG_TRACE) vm_do_trace(func);
             if (janet_fiber_funcframe_tail(fiber, func)) {
                 janet_stack_frame(fiber->data + fiber->frame)->pc = pc;
                 int32_t n = fiber->stacktop - fiber->stackstart;
diff --git a/src/include/janet.h b/src/include/janet.h
index 0d072dc9..663d2e7f 100644
--- a/src/include/janet.h
+++ b/src/include/janet.h
@@ -805,6 +805,8 @@ struct JanetFuncEnv {
         environment is no longer on the stack. */
 };
 
+#define JANET_FUNCFLAG_TRACE (1 << 16)
+
 /* A function */
 struct JanetFunction {
     JanetGCObject gc;