debugger: eval frames.

We introduce evaluation tracking frames. The backtrace
function can use these to deduce the line from which
a function is called (if called from interpreted code).
Eventually we will have analogous virtual machine
frames to do this for compiled code.

* eval.c (do_eval): If backtraces are enabled, then push
and pop an eval frame, which holds the two key pieces: the
form and environment.

* share/txr/stdlib/debug.tl ((fcall-frame loc), (fcall-frame
print-trace), (eval-frame loc), (eval-frame print-trace)):
New methods.
(print-backtrace): Loop reduced to just dispatching
frame-specific print-trace methods. It gives the previous and
next frame to each method.
The (fcall-frame print-trace) method prints function frames,
using the previous form to deduce the location from which
the function is called. The (eval-frame print-trace) method
mostly suppresses the printing of eval frames. We print
an eval frame if it is the parent of an internal function
frame, and if it is the topmost frame (to identify the
toplevel form at the root of the backtrace).

* unwind.c (form_s): New symbol variable.
(eval_frame_type): New static variable.
(uw_find_frames_by_mask): Handle UW_EVAL case, producing
eval-frame struct.
(uw_push_eval): New function.
(uw_late_init): Allocate eval-frame struct type, storing it in
eval_frame_type, and gc-protect that new variable.
Register uw-eval variable evaluating to a one bit mask
with the UW_EVAL-th bit set.

* unwind.h (enum uw_frtype): New enum constant UW_EVAL.
(struct uw_eval): New struct type.
(union uw_frame): New member, el.
(uw_push_eval): Declared.

4 files changed, 97 insertions, 32 deletions

diff --git a/eval.c b/eval.c
index bf575c9c..df6b23e1 100644
--- a/eval.c
+++ b/eval.c
@@ -1497,19 +1497,27 @@ val eval_intrinsic_noerr(val form, val env, val *error_p)
 static val do_eval(val form, val env, val ctx,
                    val (*lookup)(val env, val sym))
 {
+  uw_frame_t *ev = 0;
+  val ret = nil;
+
+  if (dbg_backtrace) {
+    ev = coerce(uw_frame_t *, alloca(sizeof *ev));
+    uw_push_eval(ev, form, env);
+  }
+
   sig_check_fast();
 
-  if (nilp(form)) {
-    return nil;
-  } else if (symbolp(form)) {
+  if (form && symbolp(form)) {
     if (!bindable(form)) {
-      return form;
+      ret = form;
     } else {
       val binding = lookup(env, form);
-      if (binding)
-        return cdr(binding);
-      eval_error(ctx, lit("unbound variable ~s"), form, nao);
-      abort();
+      if (binding) {
+        ret = cdr(binding);
+      } else {
+        eval_error(ctx, lit("unbound variable ~s"), form, nao);
+        abort();
+      }
     }
   } else if (consp(form)) {
     val oper = car(form);
@@ -1517,11 +1525,10 @@ static val do_eval(val form, val env, val ctx,
 
     if (entry) {
       opfun_t fp = coerce(opfun_t, cptr_get(entry));
-      val ret, lfe_save = last_form_evaled;
+      val lfe_save = last_form_evaled;
       last_form_evaled = form;
       ret = fp(form, env);
       last_form_evaled = lfe_save;
-      return ret;
     } else {
       val fbinding = lookup_fun(env, oper);
 
@@ -1536,7 +1543,7 @@ static val do_eval(val form, val env, val ctx,
         val arglist = rest(form);
         cnum alen = if3(consp(arglist), c_num(length(arglist)), 0);
         cnum argc = max(alen, ARGS_MIN);
-        val ret, lfe_save = last_form_evaled;
+        val lfe_save = last_form_evaled;
         args_decl(args, argc);
 
         last_form_evaled = form;
@@ -1545,13 +1552,16 @@ static val do_eval(val form, val env, val ctx,
         ret = generic_funcall(cdr(fbinding), args);
 
         last_form_evaled = lfe_save;
-
-        return ret;
       }
     }
   } else {
-    return form;
+    ret = form;
   }
+
+  if (ev != 0)
+    uw_pop_frame(ev);
+
+  return ret;
 }
 
 val eval(val form, val env, val ctx)
diff --git a/share/txr/stdlib/debugger.tl b/share/txr/stdlib/debugger.tl
index 07cbcfe8..9cd52b61 100644
--- a/share/txr/stdlib/debugger.tl
+++ b/share/txr/stdlib/debugger.tl
@@ -44,26 +44,49 @@
 (defun debugger-help ()
   (mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%))
 
+(defmeth fcall-frame loc (fr))
+
+(defmeth fcall-frame print-trace (fr pr-fr nx-fr prefix)
+  (let* ((fun fr.fun)
+         (args fr.args)
+         (name (if (functionp fun)
+                 (func-get-name fun)))
+         (loc nx-fr.(loc))
+         (kind
+           (cond
+             ((interp-fun-p fun) "I")
+             ((vm-fun-p fun) "V")
+             ((functionp fun) "C")
+             (t "O"))))
+    (put-string `@prefix @kind:@(if loc `(@loc):`)`)
+    (prinl ^[,(or name fun) ,*args])))
+
+(defmeth eval-frame loc (fr)
+  (source-loc-str fr.form))
+
+(defmeth eval-frame print-trace (fr pr-fr nx-fr prefix)
+  (when (or (null nx-fr)
+            (and (typep pr-fr 'fcall-frame)
+                 (not (interp-fun-p pr-fr.fun))
+                 (not (vm-fun-p pr-fr.fun))))
+    (let* ((form fr.form)
+           (sym (if (consp form) (car form)))
+           (loc (source-loc-str form)))
+      (when sym
+        (put-string `@prefix E:@(if loc `(@loc):`)`)
+        (prinl (if (eq sym 'dwim)
+                 ^[,(cadr form)]
+                 ^(,sym)))))))
+
 (defun print-backtrace (: (*stdout* *stdout*) (prefix ""))
   (with-resources ((imode (set-indent-mode *stdout* indent-foff)
                           (set-indent-mode *stdout* imode))
-                   (depth (set-max-depth *stdout* 4)
+                   (depth (set-max-depth *stdout* 2)
                           (set-max-depth *stdout* depth))
                    (length (set-max-length *stdout* 10)
                            (set-max-length *stdout* length)))
-    (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])))))
+    (window-map 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix))
+                (find-frames-by-mask (logior uw-fcall uw-eval)))))
 
 (defun debugger ()
   (with-disabled-debugging
diff --git a/unwind.c b/unwind.c
index 994fed38..2ea8d2ef 100644
--- a/unwind.c
+++ b/unwind.c
@@ -61,13 +61,13 @@ 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;
+static val args_s, form_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 fcall_frame_type, eval_frame_type;
 
 static val deferred_warnings, tentative_defs;
 
@@ -433,6 +433,13 @@ val uw_find_frames_by_mask(val mask_in)
           slotset(frame, args_s, args_get_list(acopy));
           break;
         }
+      case UW_EVAL:
+        {
+          frame = allocate_struct(eval_frame_type);
+          slotset(frame, form_s, fr->el.form);
+          slotset(frame, env_s, fr->el.env);
+          break;
+        }
       default:
         break;
       }
@@ -576,6 +583,16 @@ void uw_push_fcall(uw_frame_t *fr, val fun, struct args *args)
   uw_stack = fr;
 }
 
+void uw_push_eval(uw_frame_t *fr, val form, val env)
+{
+  memset(fr, 0, sizeof *fr);
+  fr->el.type = UW_EVAL;
+  fr->el.form = form;
+  fr->el.env = env;
+  fr->el.up = uw_stack;
+  uw_stack = fr;
+}
+
 #endif
 
 static val exception_subtypes;
@@ -1134,13 +1151,14 @@ 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));
+  protect(&fcall_frame_type, &eval_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);
+  form_s = intern(lit("form"), user_package);
 #endif
   sys_cont_s = intern(lit("cont"), system_package);
   sys_cont_poison_s = intern(lit("cont-poison"), system_package);
@@ -1162,6 +1180,10 @@ void uw_late_init(void)
                                       frame_type, nil,
                                       list(fun_s, args_s, nao),
                                       nil, nil, nil, nil);
+  eval_frame_type = make_struct_type(intern(lit("eval-frame"), user_package),
+                                     frame_type, nil,
+                                     list(form_s, env_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*"),
@@ -1197,6 +1219,7 @@ void uw_late_init(void)
   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_varl(intern(lit("uw-eval"), user_package), num_fast(1U <<UW_EVAL));
   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);
diff --git a/unwind.h b/unwind.h
index 58e8c5fd..1a122ebd 100644
--- a/unwind.h
+++ b/unwind.h
@@ -30,7 +30,7 @@ typedef enum uw_frtype {
   UW_BLOCK, UW_CAPTURED_BLOCK, UW_MENV, UW_CATCH, UW_HANDLE,
   UW_CONT_COPY, UW_GUARD,
 #if CONFIG_DEBUG_SUPPORT
-  UW_FCALL,
+  UW_FCALL, UW_EVAL
 #endif
 } uw_frtype_t;
 
@@ -100,6 +100,13 @@ struct uw_fcall {
   struct args *args;
 };
 
+struct uw_eval {
+  uw_frame_t *up;
+  uw_frtype_t type;
+  val form;
+  val env;
+};
+
 #endif
 
 #if __aarch64__
@@ -118,6 +125,7 @@ union uw_frame {
   struct uw_guard gu;
 #if CONFIG_DEBUG_SUPPORT
   struct uw_fcall fc;
+  struct uw_eval el;
 #endif
 } UW_FRAME_ALIGN;
 
@@ -137,6 +145,7 @@ 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);
+void uw_push_eval(uw_frame_t *, val form, val env);
 #endif
 noreturn val uw_throw(val sym, val exception);
 noreturn val uw_throwv(val sym, struct args *);