debugger: initial backtrace support.

* debug.c (debug_state): Switch to unsigned, since this is now
a bitmask.
(sys_print_backtrace_s): New symbol variable.
(dbg_clear, dbg_set, dbg_restore): New static functions.
(debug_init): Initialize sys_print_backtrace_s. Register
dbg-clear, dbg-set, dbg-restore intrinsics. Register
dbg-enable, dbg-step, dbg-backtrace and dbg-all bitmask
variables, Lisp equivalents of DBG_ENABLE, DBG_SETP,
DBG_BACKTRACE and DBG_ALL.
(debug_dump_backtrace): New function.

* debug.h (opt_debugger): Declaration removed.
(debug_state): Declaration updated.
(DBG_ENABLE, DBG_STEP, DBG_BACKTRACE, DBG_ALL): New
preprocessor symbols.
(debug_set_state): Inline function removed.
(debug_clear, debug_set, debug_restore): New inline functions.
(dbg_backtrace, dbg_fcall_begin, dbg_fcall_end): New macros.
(debug_dump_backtrace): Declared.

* eval.c (error_trace): Invoke debug_dump_backtrace if support
is compiled in and backtraces are enabled.

* lib.c (do_generic_funcall): New function, copy of
generic_funcall.
(generic_funcall): Now a wrapper for do_generic_funcall which
registers fcall frames if backtrace support is enabled.
(funcall, funcall1, funcall2, funcall3, funcall4): Route to
slow generic_funcall path if backtraces are enabled.

* lisplib.c (debugger_instantiate, debugger_set_entries):
New static functions.
(lisplib_init): Autload support for debug module via above
new functions.
(lisplib_try_load): Save and restore debugger state in new
way using debug_set and debug_restore, with specific mask
values.

* parser.y (parse_once): Disable debugging in new way.

* share/txr/stdlib/debug.tl New file.

* sighal.h (EJ_DBG_MEMB, EJ_DBG_SAVE, EJ_DBG_REST): New
macros for saving/restoring debug state.
(EJ_OPT_MEMB, EJ_OPT_SAVE, EJ_OPT_REST): Reference the above
macros to include debug state in extended jump context.

* txr.c (help): Document --backtrace and that that -d
implies --backtrace.
(txr_main): Enable debugger using debug_set.
Provide new --backtrace option to enable backtraces only.

* unwind.c (args_s): New symbol variable.
(fcall_frame_type): New static variable.
(unwind_to_exit_point): Save pointer to original frame stack
and restore it when calling error_trace.  This is so that
error_trace can walk the stack to collect a backtrace.
(uw_find_frames_by_mask, uw_push_fcall): New functions.
(uw_late_init): Initialize args_s and fcall_frame_type.
gc-protect fcall_frame_type. Register uw-* variables
corresponding to the UW_* frame types.

* unwind.h (uw_frtype_t): New enum constant UW_FCALL.
(struct uw_fcall): New frame structure.
(union uw_frame): New member fc.
(uw_push_fcall, uw_find_frames_by_mask): Declared.

11 files changed, 355 insertions, 26 deletions

diff --git a/debug.c b/debug.c
index f2cacfe5..26a2572b 100644
--- a/debug.c
+++ b/debug.c
@@ -38,17 +38,50 @@
 #include "unwind.h"
 #include "stream.h"
 #include "parser.h"
+#include "struct.h"
 #include "eval.h"
+#include "arith.h"
 #include "txr.h"
 #include "debug.h"
 
 int opt_debugger;
-int debug_state;
+unsigned debug_state;
 
-#if __STDC_VERSION__ >= 199901L
-int debug_set_state(int state);
-#endif
+static val sys_print_backtrace_s;
+
+static val dbg_clear(val mask)
+{
+  return unum(debug_clear(c_unum(mask)));
+}
+
+static val dbg_set(val mask)
+{
+  return unum(debug_set(c_unum(mask)));
+}
+
+static val dbg_restore(val state)
+{
+  debug_restore(c_unum(state));
+  return nil;
+}
 
 void debug_init(void)
 {
+  sys_print_backtrace_s = intern(lit("print-backtrace"), system_package);
+  reg_varl(intern(lit("dbg-enable"), system_package), num_fast(DBG_ENABLE));
+  reg_varl(intern(lit("dbg-step"), system_package), num_fast(DBG_STEP));
+  reg_varl(intern(lit("dbg-backtrace"), system_package), num_fast(DBG_BACKTRACE));
+  reg_varl(intern(lit("dbg-all"), system_package), num_fast(DBG_ALL));
+  reg_fun(intern(lit("dbg-clear"), system_package), func_n1(dbg_clear));
+  reg_fun(intern(lit("dbg-set"), system_package), func_n1(dbg_set));
+  reg_fun(intern(lit("dbg-restore"), system_package), func_n1(dbg_restore));
+}
+
+void debug_dump_backtrace(val stream, val prefix)
+{
+  val fb = lookup_fun(nil, sys_print_backtrace_s);
+  if (fb)
+    funcall2(cdr(fb), stream, prefix);
+  else
+    format(nil, lit("~s: no function binding"), sys_print_backtrace_s, nao);
 }
diff --git a/debug.h b/debug.h
index 61ce6a6f..4eb042e2 100644
--- a/debug.h
+++ b/debug.h
@@ -25,24 +25,65 @@
  * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  */
 
-extern int opt_debugger;
 
-int debug_state;
+#define DBG_ENABLE      1
+#define DBG_STEP        2
+#define DBG_BACKTRACE   4
+#define DBG_ALL         7
 
 #if CONFIG_DEBUG_SUPPORT
 
+extern unsigned debug_state;
+
 void debug_init(void);
 
-INLINE int debug_set_state(int state)
+INLINE unsigned debug_clear(unsigned mask)
 {
   int ret = debug_state;
-  debug_state = state;
+  debug_state &= ~mask;
   return ret;
 }
 
+INLINE unsigned debug_set(unsigned mask)
+{
+  int ret = debug_state;
+  debug_state |= mask;
+  return ret;
+}
+
+INLINE void debug_restore(unsigned state)
+{
+  debug_state = state;
+}
+
+void debug_dump_backtrace(val stream, val prefix);
+
+#define dbg_backtrace (debug_state & DBG_BACKTRACE)
+
+#define dbg_fcall_begin(fun, args)      \
+  {                                     \
+    uw_frame_t uw_fc;                   \
+    args_decl(args_cp, args->argc);     \
+    args_copy(args_cp, args);           \
+    uw_push_fcall(&uw_fc, fun, args_cp)
+
+#define dbg_fcall_end                   \
+    uw_pop_frame(&uw_fc);               \
+  }
+
 #else
 
-#define debug_init() ((void) 0)
-#define debug_set_state(S) 0
+#define debug_clear(mask) 0
+#define debug_set(mask) 0
+#define debug_restore(state) ((void) 0)
+#define debug_dump_backtrace(stream, prefix) ((void) 0)
+
+#define dbg_backtrace 0
+
+#define dbg_fcall_begin(fun, args)      \
+  {
+
+#define dbg_fcall_end                   \
+  }
 
 #endif
diff --git a/eval.c b/eval.c
index f57b084f..518730fd 100644
--- a/eval.c
+++ b/eval.c
@@ -438,6 +438,17 @@ void error_trace(val exsym, val exvals, val out_stream, val prefix)
       break;
     }
   }
+
+#if CONFIG_DEBUG_SUPPORT
+  if (dbg_backtrace) {
+    format(out_stream, lit("~a backtrace:\n"), prefix, nao);
+    debug_dump_backtrace(out_stream, prefix);
+  } else {
+    format(std_error, lit("~a run with --backtrace to enable backtraces\n"), prefix, nao);
+  }
+#else
+  format(std_error, lit("~a not compiled with backtrace support\n"), prefix, nao);
+#endif
 }
 
 val lookup_global_var(val sym)
diff --git a/lib.c b/lib.c
index c787174f..afd6e627 100644
--- a/lib.c
+++ b/lib.c
@@ -72,6 +72,7 @@
 #include "buf.h"
 #include "ffi.h"
 #include "txr.h"
+#include "debug.h"
 
 #define max(a, b) ((a) > (b) ? (a) : (b))
 #define min(a, b) ((a) < (b) ? (a) : (b))
@@ -6044,7 +6045,7 @@ static noreturn void callerror(val fun, val msg)
   abort();
 }
 
-val generic_funcall(val fun, struct args *args_in)
+INLINE val do_generic_funcall(val fun, struct args *args_in)
 {
   int variadic, fixparam, reqargs;
   struct args *args = args_in;
@@ -6257,6 +6258,18 @@ val generic_funcall(val fun, struct args *args_in)
   internal_error("corrupt function type field");
 }
 
+val generic_funcall(val fun, struct args *args)
+{
+  if (dbg_backtrace) {
+    val ret;
+    dbg_fcall_begin(fun, args);
+    ret = do_generic_funcall(fun, args);
+    dbg_fcall_end;
+    return ret;
+  }
+  return do_generic_funcall(fun, args);
+}
+
 static noreturn void wrongargs(val fun)
 {
   callerror(fun, lit("wrong number of arguments"));
@@ -6264,7 +6277,7 @@ static noreturn void wrongargs(val fun)
 
 val funcall(val fun)
 {
-  if (type(fun) != FUN || fun->f.optargs) {
+  if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
     args_decl(args, ARGS_MIN);
     return generic_funcall(fun, args);
   }
@@ -6305,7 +6318,7 @@ val funcall(val fun)
 
 val funcall1(val fun, val arg)
 {
-  if (type(fun) != FUN || fun->f.optargs) {
+  if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
     args_decl(args, ARGS_MIN);
     args_add(args, arg);
     return generic_funcall(fun, args);
@@ -6357,7 +6370,7 @@ val funcall1(val fun, val arg)
 
 val funcall2(val fun, val arg1, val arg2)
 {
-  if (type(fun) != FUN || fun->f.optargs) {
+  if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
     args_decl(args, ARGS_MIN);
     args_add2(args, arg1, arg2);
     return generic_funcall(fun, args);
@@ -6415,7 +6428,7 @@ val funcall2(val fun, val arg1, val arg2)
 
 val funcall3(val fun, val arg1, val arg2, val arg3)
 {
-  if (type(fun) != FUN || fun->f.optargs) {
+  if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
     args_decl(args, ARGS_MIN);
     args_add3(args, arg1, arg2, arg3);
     return generic_funcall(fun, args);
@@ -6479,7 +6492,7 @@ val funcall3(val fun, val arg1, val arg2, val arg3)
 
 val funcall4(val fun, val arg1, val arg2, val arg3, val arg4)
 {
-  if (type(fun) != FUN || fun->f.optargs) {
+  if (type(fun) != FUN || fun->f.optargs || dbg_backtrace) {
     args_decl(args, ARGS_MIN);
     args_add4(args, arg1, arg2, arg3, arg4);
     return generic_funcall(fun, args);
diff --git a/lisplib.c b/lisplib.c
index 6d9dcda7..b0f0fcc2 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -720,6 +720,25 @@ static val compiler_set_entries(val dlt, val fun)
   return nil;
 }
 
+static val debugger_instantiate(val set_fun)
+{
+  funcall1(set_fun, nil);
+  load(format(nil, lit("~adebugger"), stdlib_path, nao));
+  return nil;
+}
+
+static val debugger_set_entries(val dlt, val fun)
+{
+  val sys_name[] = {
+    lit("debugger"), lit("print-backtrace"),
+    nil
+  };
+
+  set_dlt_entries_sys(dlt, sys_name, fun);
+  return nil;
+}
+
+
 static val op_set_entries(val dlt, val fun)
 {
   val name[] = {
@@ -818,6 +837,7 @@ void lisplib_init(void)
   dlt_register(dl_table, stream_wrap_instantiate, stream_wrap_set_entries);
   dlt_register(dl_table, asm_instantiate, asm_set_entries);
   dlt_register(dl_table, compiler_instantiate, compiler_set_entries);
+  dlt_register(dl_table, debugger_instantiate, debugger_set_entries);
 
   if (!opt_compat || opt_compat >= 185)
     dlt_register(dl_table, op_instantiate, op_set_entries);
@@ -833,14 +853,14 @@ val lisplib_try_load(val sym)
   val fun = gethash(dl_table, sym);
 
   if (fun) {
-     int ds = debug_set_state(opt_dbg_autoload);
+     unsigned ds = debug_clear(opt_dbg_autoload ? 0 : DBG_ENABLE);
      val saved_dyn_env = dyn_env;
      dyn_env = make_env(nil, nil, dyn_env);
      env_vbind(dyn_env, package_s, system_package);
      env_vbind(dyn_env, package_alist_s, packages);
      funcall(fun);
      dyn_env = saved_dyn_env;
-     debug_set_state(ds);
+     debug_restore(ds);
      return t;
   }
   return nil;
diff --git a/parser.y b/parser.y
index b3cadd19..f70693c5 100644
--- a/parser.y
+++ b/parser.y
@@ -1851,9 +1851,8 @@ int parse_once(val stream, val name, parser_t *parser)
 {
   int res = 0;
 #if CONFIG_DEBUG_SUPPORT
-  int ds = debug_set_state(opt_dbg_expansion);
+  unsigned dbg_state = debug_clear(opt_dbg_expansion ? 0 : DBG_ENABLE);
 #endif
-
   parser_common_init(parser);
 
   parser->stream = stream;
@@ -1862,6 +1861,7 @@ int parse_once(val stream, val name, parser_t *parser)
 
   uw_catch_begin(cons(error_s, nil), esym, eobj);
 
+
   res = yyparse(parser->scanner, parser);
 
   parser_resolve_circ(parser);
@@ -1874,7 +1874,7 @@ int parse_once(val stream, val name, parser_t *parser)
   uw_unwind {
     parser_cleanup(parser);
 #if CONFIG_DEBUG_SUPPORT
-    debug_set_state(ds);
+    debug_set(dbg_state);
 #endif
   }
 
diff --git a/share/txr/stdlib/debugger.tl b/share/txr/stdlib/debugger.tl
new file mode 100644
index 00000000..9afab9ef
--- /dev/null
+++ b/share/txr/stdlib/debugger.tl
@@ -0,0 +1,66 @@
+;; Copyright 2019
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice, this
+;;    list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(defmacro with-disabled-debugging (. forms)
+  (let ((state (gensym)))
+    ^(let ((,state (dbg-clear dbg-all)))
+       (unwind-protect
+         (progn ,*forms)
+         (dbg-restore ,state)))))
+
+(defun make-command-env (command-table)
+  (let ((env (make-env )))
+    (mapdo (ado env-vbind env @1 ^(,@2)) command-table)
+    env))
+
+(defparml %dbg-commands% '((usr:? debugger-help "list command summary")
+                           (usr:bt print-backtrace "print backtrace")))
+
+(defparml %dbg-command-env% (make-command-env %dbg-commands%))
+
+(defun debugger-help ()
+  (mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%))
+
+(defun print-backtrace (: (*stdout* *stdout*) (prefix ""))
+  (with-resources ((imode (set-indent-mode *stdout* indent-off)
+                          (set-indent-mode *stdout* imode)))
+    (each ((fr (find-frames-by-mask uw-fcall)))
+      (let* ((fun fr.fun)
+             (args fr.args)
+             (name (if (functionp fun)
+                     (func-get-name fun)))
+             (kind
+               (cond
+                 ((interp-fun-p fun) "I")
+                 ((vm-fun-p fun) "V")
+                 ((functionp fun) "C")
+                 (t "O"))))
+        (put-string `@prefix @kind: `)
+        (prinl ^[,(or name fun) ,*args])))))
+
+(defun debugger ()
+  (with-disabled-debugging
+    (sys:repl nil *stdin* *stdout* %dbg-command-env%)))
diff --git a/signal.h b/signal.h
index fc98590b..09204fc3 100644
--- a/signal.h
+++ b/signal.h
@@ -26,9 +26,20 @@
  */
 
 
-#define EJ_OPT_MEMB
-#define EJ_OPT_SAVE(EJB)
-#define EJ_OPT_REST(EJB)
+#if CONFIG_DEBUG_SUPPORT
+extern unsigned debug_state;
+#define EJ_DBG_MEMB int ds;
+#define EJ_DBG_SAVE(EJB) ((EJB).ds = debug_state),
+#define EJ_DBG_REST(EJB) (debug_state = (EJB).ds),
+#else
+#define EJ_DBG_MEMB
+#define EJ_DBG_SAVE(EJB)
+#define EJ_DBG_REST(EJB)
+#endif
+
+#define EJ_OPT_MEMB EJ_DBG_MEMB
+#define EJ_OPT_SAVE(EJB) EJ_DBG_SAVE(EJB)
+#define EJ_OPT_REST(EJB) EJ_DBG_REST(EJB)
 
 #if __i386__
 
diff --git a/txr.c b/txr.c
index 4a69c0ba..4de8c3f7 100644
--- a/txr.c
+++ b/txr.c
@@ -111,7 +111,7 @@ static void help(void)
 "-l                     If dumping bindings, use TXR Lisp format.\n"
 "-i                     Interactive TXR Lisp listener mode.\n"
 "                       (Requires compiled-in support.)\n"
-"-d                     Debugger mode.\n"
+"-d                     Enable debugger. Implies --backtrace.\n"
 "-n                     Noninteractive input mode for standard input stream,\n"
 "                       even if its connected to a terminal device.\n"
 "                       Also, forces the interactive listener into\n"
@@ -144,6 +144,7 @@ static void help(void)
 "--compiled             Treat unsuffixed query files as compiled TXR Lisp.\n"
 "--lisp-bindings        Synonym for -l\n"
 "--debugger             Synonym for -d\n"
+"--backtrace            Enable backtraces.\n"
 "--noninteractive       Synonym for -n\n"
 "--compat=N             Synonym for -C N\n"
 "--gc-delta=N           Invoke garbage collection when malloc activity\n"
@@ -730,6 +731,7 @@ int txr_main(int argc, char **argv)
         drop_privilege();
 #if CONFIG_DEBUG_SUPPORT
         opt_debugger = 1;
+        debug_set(DBG_ENABLE | DBG_BACKTRACE);
         continue;
 #else
         no_dbg_support(arg);
@@ -740,6 +742,7 @@ int txr_main(int argc, char **argv)
 #if CONFIG_DEBUG_SUPPORT
         opt_debugger = 1;
         opt_dbg_autoload = 1;
+        debug_set(DBG_ENABLE | DBG_BACKTRACE);
         continue;
 #else
         no_dbg_support(opt);
@@ -750,6 +753,7 @@ int txr_main(int argc, char **argv)
 #if CONFIG_DEBUG_SUPPORT
         opt_debugger = 1;
         opt_dbg_expansion = 1;
+        debug_set(DBG_ENABLE | DBG_BACKTRACE);
         continue;
 #else
         no_dbg_support(opt);
@@ -770,6 +774,14 @@ int txr_main(int argc, char **argv)
                  prog_string, arg, nao);
           return EXIT_FAILURE;
         }
+      } else if (equal(opt, lit("backtrace"))) {
+#if CONFIG_DEBUG_SUPPORT
+        debug_set(DBG_BACKTRACE);
+        continue;
+#else
+        no_dbg_support(arg);
+        return EXIT_FAILURE;
+#endif
       } else if (equal(opt, lit("noninteractive"))) {
         opt_noninteractive = 1;
         stream_set_prop(std_input, real_time_k, nil);
@@ -965,6 +977,7 @@ int txr_main(int argc, char **argv)
           drop_privilege();
 #if CONFIG_DEBUG_SUPPORT
           opt_debugger = 1;
+          debug_set(DBG_ENABLE | DBG_BACKTRACE);
 #else
           no_dbg_support(opch);
           return EXIT_FAILURE;
diff --git a/unwind.c b/unwind.c
index 5d24e6ce..d937e094 100644
--- a/unwind.c
+++ b/unwind.c
@@ -46,7 +46,9 @@
 #include "struct.h"
 #include "cadr.h"
 #include "alloca.h"
+#include "arith.h"
 #include "unwind.h"
+#include "debug.h"
 
 #define UW_CONT_FRAME_BEFORE (32 * sizeof (val))
 #define UW_CONT_FRAME_AFTER (16 * sizeof (val))
@@ -58,10 +60,14 @@ static uw_frame_t toplevel_env;
 static uw_frame_t unhandled_ex;
 
 static val unhandled_hook_s, types_s, jump_s, desc_s;
+#if CONFIG_DEBUG_SUPPORT
+static val args_s;
+#endif
 static val sys_cont_s, sys_cont_poison_s;
 static val sys_cont_free_s, sys_capture_cont_s;
 
 static val frame_type, catch_frame_type, handle_frame_type;
+static val fcall_frame_type;
 
 static val deferred_warnings, tentative_defs;
 
@@ -76,6 +82,7 @@ val uw_block_return(val tag, val result);
 
 static void uw_unwind_to_exit_point(void)
 {
+  uw_frame_t *orig_stack = uw_stack;
   assert (uw_exit_point);
 
   for (; uw_stack && uw_stack != uw_exit_point; uw_stack = uw_stack->uw.up) {
@@ -126,6 +133,7 @@ static void uw_unwind_to_exit_point(void)
       format(std_error, lit("~a unhandled exception of type ~a:\n"),
              prefix, sym, nao);
 
+      uw_stack = orig_stack;
       error_trace(sym, args, std_error, prefix);
     }
     if (uw_exception_subtype_p(sym, query_error_s) ||
@@ -390,6 +398,59 @@ val uw_find_frames(val extype, val frtype)
   return uw_find_frames_impl(extype, frtype, nil);
 }
 
+#if CONFIG_DEBUG_SUPPORT
+
+val uw_find_frames_by_mask(val mask_in)
+{
+  ucnum mask = c_unum(mask_in);
+  list_collect_decl (out, ptail);
+  uw_frame_t *fr;
+
+  for (fr = uw_stack; fr != 0; fr = fr->uw.up) {
+    uw_frtype_t type = fr->uw.type;
+    if (((1U << type) & mask) != 0) {
+      val frame = nil;
+      args_decl(args, ARGS_MIN);
+      switch (type) {
+      case UW_CATCH:
+        {
+          frame = make_struct(catch_frame_type, nil, args);
+          slotset(frame, types_s, fr->ca.matches);
+          slotset(frame, desc_s, fr->ca.desc);
+          slotset(frame, jump_s, cptr(coerce(mem_t *, fr)));
+          break;
+        }
+      case UW_HANDLE:
+        {
+          frame = make_struct(handle_frame_type, nil, args);
+          slotset(frame, types_s, fr->ha.matches);
+          slotset(frame, fun_s, fr->ha.fun);
+          break;
+        }
+      case UW_FCALL:
+        {
+          struct args *frargs = fr->fc.args;
+          args_decl(acopy, frargs->argc);
+          args_copy(acopy, frargs);
+          frame = make_struct(fcall_frame_type, nil, args);
+          slotset(frame, fun_s, fr->fc.fun);
+          slotset(frame, args_s, args_get_list(acopy));
+          break;
+        }
+      default:
+        break;
+      }
+
+      if (frame)
+        ptail = list_collect(ptail, frame);
+    }
+  }
+
+  return out;
+}
+
+#endif
+
 val uw_invoke_catch(val catch_frame, val sym, struct args *args)
 {
   uw_frame_t *ex, *ex_point;
@@ -507,6 +568,20 @@ void uw_push_handler(uw_frame_t *fr, val matches, val fun)
   uw_stack = fr;
 }
 
+#if CONFIG_DEBUG_SUPPORT
+
+void uw_push_fcall(uw_frame_t *fr, val fun, struct args *args)
+{
+  memset(fr, 0, sizeof *fr);
+  fr->fc.type = UW_FCALL;
+  fr->fc.fun = fun;
+  fr->fc.args = args;
+  fr->fc.up = uw_stack;
+  uw_stack = fr;
+}
+
+#endif
+
 static val exception_subtypes;
 
 val uw_exception_subtype_p(val sub, val sup)
@@ -1062,9 +1137,15 @@ void uw_late_init(void)
 {
   protect(&frame_type, &catch_frame_type, &handle_frame_type,
           &deferred_warnings, &tentative_defs, convert(val *, 0));
+#if CONFIG_DEBUG_SUPPORT
+  protect(&fcall_frame_type, convert(val *, 0));
+#endif
   types_s = intern(lit("types"), user_package);
   jump_s = intern(lit("jump"), user_package);
   desc_s = intern(lit("desc"), user_package);
+#if CONFIG_DEBUG_SUPPORT
+  args_s = intern(lit("args"), user_package);
+#endif
   sys_cont_s = intern(lit("cont"), system_package);
   sys_cont_poison_s = intern(lit("cont-poison"), system_package);
   sys_cont_free_s = intern(lit("cont-free"), system_package);
@@ -1080,6 +1161,12 @@ void uw_late_init(void)
                                        frame_type, nil,
                                        list(types_s, fun_s, nao),
                                        nil, nil, nil, nil);
+#if CONFIG_DEBUG_SUPPORT
+  fcall_frame_type = make_struct_type(intern(lit("fcall-frame"), user_package),
+                                      frame_type, nil,
+                                      list(fun_s, args_s, nao),
+                                      nil, nil, nil, nil);
+#endif
   reg_mac(intern(lit("defex"), user_package), func_n2(me_defex));
   reg_var(unhandled_hook_s = intern(lit("*unhandled-hook*"),
           user_package), nil);
@@ -1105,6 +1192,17 @@ void uw_late_init(void)
           func_n2v(uw_invoke_catch));
   reg_fun(sys_capture_cont_s = intern(lit("capture-cont"), system_package),
           func_n3o(uw_capture_cont, 2));
+#if CONFIG_DEBUG_SUPPORT
+  reg_varl(intern(lit("uw-block"), user_package), num_fast(1U << UW_BLOCK));
+  reg_varl(intern(lit("uw-captured-block"), user_package), num_fast(1U << UW_CAPTURED_BLOCK));
+  reg_varl(intern(lit("uw-menv"), user_package), num_fast(1U <<UW_MENV));
+  reg_varl(intern(lit("uw-catch"), user_package), num_fast(1U <<UW_CATCH));
+  reg_varl(intern(lit("uw-handle"), user_package), num_fast(1U <<UW_HANDLE));
+  reg_varl(intern(lit("uw-cont-copy"), user_package), num_fast(1U <<UW_CONT_COPY));
+  reg_varl(intern(lit("uw-guard"), user_package), num_fast(1U <<UW_GUARD));
+  reg_varl(intern(lit("uw-fcall"), user_package), num_fast(1U <<UW_FCALL));
+  reg_fun(intern(lit("find-frames-by-mask"), user_package), func_n1(uw_find_frames_by_mask));
+#endif
   uw_register_subtype(continue_s, restart_s);
   uw_register_subtype(warning_s, t);
   uw_register_subtype(defr_warning_s, warning_s);
diff --git a/unwind.h b/unwind.h
index edf079ee..58e8c5fd 100644
--- a/unwind.h
+++ b/unwind.h
@@ -28,7 +28,10 @@
 typedef union uw_frame uw_frame_t;
 typedef enum uw_frtype {
   UW_BLOCK, UW_CAPTURED_BLOCK, UW_MENV, UW_CATCH, UW_HANDLE,
-  UW_CONT_COPY, UW_GUARD
+  UW_CONT_COPY, UW_GUARD,
+#if CONFIG_DEBUG_SUPPORT
+  UW_FCALL,
+#endif
 } uw_frtype_t;
 
 struct uw_common {
@@ -88,6 +91,17 @@ struct uw_guard {
   int uw_ok;
 };
 
+#if CONFIG_DEBUG_SUPPORT
+
+struct uw_fcall {
+  uw_frame_t *up;
+  uw_frtype_t type;
+  val fun;
+  struct args *args;
+};
+
+#endif
+
 #if __aarch64__
 #define UW_FRAME_ALIGN __attribute__ ((aligned (16)))
 #else
@@ -102,6 +116,9 @@ union uw_frame {
   struct uw_handler ha;
   struct uw_cont_copy cp;
   struct uw_guard gu;
+#if CONFIG_DEBUG_SUPPORT
+  struct uw_fcall fc;
+#endif
 } UW_FRAME_ALIGN;
 
 void uw_push_block(uw_frame_t *, val tag);
@@ -118,6 +135,9 @@ INLINE val uw_block_return(val tag, val result)
 val uw_block_abscond(val tag, val result);
 void uw_push_catch(uw_frame_t *, val matches);
 void uw_push_handler(uw_frame_t *, val matches, val fun);
+#if CONFIG_DEBUG_SUPPORT
+void uw_push_fcall(uw_frame_t *, val fun, struct args *args);
+#endif
 noreturn val uw_throw(val sym, val exception);
 noreturn val uw_throwv(val sym, struct args *);
 noreturn val uw_throwf(val sym, val fmt, ...);
@@ -143,6 +163,9 @@ uw_frame_t *uw_current_exit_point(void);
 val uw_get_frames(void);
 val uw_find_frame(val extype, val frtype);
 val uw_find_frames(val extype, val frtype);
+#if CONFIG_DEBUG_SUPPORT
+val uw_find_frames_by_mask(val mask);
+#endif
 val uw_invoke_catch(val catch_frame, val sym, struct args *);
 val uw_muffle_warning(val exc, struct args *);
 val uw_trace_error(val ctx, val exc, struct args *);