feature/zach-soc-funcall-from-bytecode e1aee0f 6/6: Don't call Ffuncall directly from exec_byte_code

[Rocky Bernstein]

branch: feature/zach-soc-funcall-from-bytecode
commit e1aee0ffe8aa51a8963737f8a957cf19eabdb9d7
Author: Zach Shaftel <zshaftel@gmail.com>
Commit: Zach Shaftel <zshaftel@gmail.com>

    Don't call Ffuncall directly from exec_byte_code
    
    * src/bytecode.c (exec_byte_code): Do a good chunk of Ffuncall's
    work in the Bcall ops, so Ffuncall no longer needs to be called. As
    it stands, it's an ugly clone of the contents of Ffuncall (and
    some of funcall_lambda). Work in progress.
    
    * src/eval.c (record_in_backtrace_with_offset): New function. Like
    record_in_backtrace but accepts the bytecode offset and stores it
    in the pertinent backtrace frame.
    (record_in_backtrace): Don't record the offset.
    (funcall_lambda): Remove unnecessary SYMBOLP check.
    
    * src/lisp.h (funcall_lambda, do_debug_on_call)
    (record_in_backtrace_with_offset , backtrace_debug_on_exit):
    Declare.
---
 src/bytecode.c | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++----
 src/eval.c     | 37 +++++++++++++++++-------
 src/lisp.h     |  5 +++-
 3 files changed, 116 insertions(+), 17 deletions(-)

diff --git a/src/bytecode.c b/src/bytecode.c
index 29b76f8..fe59cf6 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -311,8 +311,6 @@ enum byte_code_op
 
 #define TOP (*top)
 
-#define UPDATE_OFFSET (backtrace_byte_offset = pc - bytestr_data);
-
 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
        doc: /* Function used internally in byte-compiled code.
 The first argument, BYTESTR, is a string of byte code;
@@ -433,7 +431,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, 
Lisp_Object maxdepth,
       /* NEXT is invoked at the end of an instruction to go to the
         next instruction.  It is either a computed goto, or a
         plain break.  */
-#define NEXT UPDATE_OFFSET goto *(targets[op = FETCH])
+#define NEXT goto *(targets[op = FETCH])
       /* FIRST is like NEXT, but is only used at the start of the
         interpreter body.  In the switch-based interpreter it is the
         switch, so the threaded definition must include a semicolon.  */
@@ -635,7 +633,90 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, 
Lisp_Object maxdepth,
                  }
              }
 #endif
-           TOP = Ffuncall (op + 1, &TOP);
+           Lisp_Object fun, original_fun;
+           Lisp_Object funcar;
+           Lisp_Object *fun_args;
+           ptrdiff_t numargs = op;
+           Lisp_Object val;
+           ptrdiff_t count_c;
+
+           maybe_quit ();
+
+           if (++lisp_eval_depth > max_lisp_eval_depth)
+             {
+               if (max_lisp_eval_depth < 100)
+                 max_lisp_eval_depth = 100;
+               if (lisp_eval_depth > max_lisp_eval_depth)
+                 error ("Lisp nesting exceeds `max-lisp-eval-depth'");
+             }
+
+           fun_args = &TOP + 1;
+
+           count_c = record_in_backtrace_with_offset (TOP, fun_args, numargs, 
pc - bytestr_data - 1);
+
+           maybe_gc ();
+
+           if (debug_on_next_call)
+             do_debug_on_call (Qlambda, count);
+
+           original_fun = TOP;
+
+         retry:
+
+           /* Optimize for no indirection.  */
+           fun = original_fun;
+           if (SYMBOLP (fun) && !NILP (fun)
+               && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
+             fun = indirect_function (fun);
+
+           if (COMPILEDP (fun))
+             {
+               Lisp_Object syms_left = AREF (fun, COMPILED_ARGLIST);
+               if (FIXNUMP (syms_left))
+                 {
+                   if (CONSP (AREF (fun, COMPILED_BYTECODE)))
+                     Ffetch_bytecode (fun);
+                   val = exec_byte_code (AREF (fun, COMPILED_BYTECODE),
+                                         AREF (fun, COMPILED_CONSTANTS),
+                                         AREF (fun, COMPILED_STACK_DEPTH),
+                                         syms_left, numargs, fun_args);
+                 }
+               else
+                 {
+                   /* The rest of funcall_lambda is very bulky */
+                   val = funcall_lambda (fun, numargs, fun_args);
+                 }
+             }
+           else if (SUBRP (fun))
+             val = funcall_subr (XSUBR (fun), numargs, fun_args);
+#ifdef HAVE_MODULES
+           else if (MODULE_FUNCTIONP (fun))
+             val = funcall_module (fun, numargs, fun_args);
+#endif
+           else
+             {
+               if (NILP (fun))
+                 xsignal1 (Qvoid_function, original_fun);
+               if (!CONSP (fun)
+                   || (funcar = XCAR (fun), !SYMBOLP(funcar)))
+                 xsignal1 (Qinvalid_function, original_fun);
+               if (EQ (funcar, Qlambda)
+                   || EQ (funcar, Qclosure))
+                 val = funcall_lambda (fun, numargs, fun_args);
+               else if (EQ (funcar, Qautoload))
+                 {
+                   Fautoload_do_load (fun, original_fun, Qnil);
+                   goto retry;
+                 }
+               else
+                 xsignal1 (Qinvalid_function, original_fun);
+             }
+           lisp_eval_depth--;
+           if (backtrace_debug_on_exit (specpdl + count_c))
+             val = call_debugger (list2 (Qexit, val));
+           specpdl_ptr--;
+
+           TOP = val;
            NEXT;
          }
 
@@ -1451,7 +1532,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, 
Lisp_Object maxdepth,
        unbind_to (count, Qnil);
       error ("binding stack not balanced (serious byte compiler bug)");
     }
-  backtrace_byte_offset = -1;
+
   Lisp_Object result = TOP;
   SAFE_FREE ();
   return result;
diff --git a/src/eval.c b/src/eval.c
index 5b43b81..544dfc2 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -56,8 +56,6 @@ Lisp_Object Vrun_hooks;
 /* FIXME: We should probably get rid of this!  */
 Lisp_Object Vsignaling_function;
 
-int backtrace_byte_offset = -1;
-
 /* These would ordinarily be static, but they need to be visible to GDB.  */
 bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
 Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
@@ -65,7 +63,6 @@ Lisp_Object backtrace_function (union specbinding *) 
EXTERNALLY_VISIBLE;
 union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE;
 union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE;
 
-static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
 static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t);
 static Lisp_Object lambda_arity (Lisp_Object);
 
@@ -146,7 +143,7 @@ backtrace_bytecode_offset (union specbinding *pdl)
   return pdl->bt.bytecode_offset;
 }
 
-static bool
+bool
 backtrace_debug_on_exit (union specbinding *pdl)
 {
   eassert (pdl->kind == SPECPDL_BACKTRACE);
@@ -354,7 +351,7 @@ call_debugger (Lisp_Object arg)
   return unbind_to (count, val);
 }
 
-static void
+void
 do_debug_on_call (Lisp_Object code, ptrdiff_t count)
 {
   debug_on_next_call = 0;
@@ -2146,6 +2143,27 @@ grow_specpdl (void)
 }
 
 ptrdiff_t
+record_in_backtrace_with_offset (Lisp_Object function, Lisp_Object *args,
+                                 ptrdiff_t nargs, int offset)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+
+  eassert (nargs >= UNEVALLED);
+  specpdl_ptr->bt.kind = SPECPDL_BACKTRACE;
+  specpdl_ptr->bt.debug_on_exit = false;
+  specpdl_ptr->bt.function = function;
+  current_thread->stack_top = specpdl_ptr->bt.args = args;
+  specpdl_ptr->bt.nargs = nargs;
+  specpdl_ptr->bt.bytecode_offset = -1;
+  union specbinding *nxt = backtrace_top ();
+  if (backtrace_p (nxt) && nxt->kind == SPECPDL_BACKTRACE)
+    nxt->bt.bytecode_offset = offset;
+  grow_specpdl ();
+
+  return count;
+}
+
+ptrdiff_t
 record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs)
 {
   ptrdiff_t count = SPECPDL_INDEX ();
@@ -2156,10 +2174,7 @@ record_in_backtrace (Lisp_Object function, Lisp_Object 
*args, ptrdiff_t nargs)
   specpdl_ptr->bt.function = function;
   current_thread->stack_top = specpdl_ptr->bt.args = args;
   specpdl_ptr->bt.nargs = nargs;
-  union specbinding *nxt = specpdl_ptr;
-  nxt = backtrace_next(nxt);
-  if (nxt->kind == SPECPDL_BACKTRACE)
-    nxt->bt.bytecode_offset = backtrace_byte_offset;
+  specpdl_ptr->bt.bytecode_offset = -1;
   grow_specpdl ();
 
   return count;
@@ -2965,7 +2980,7 @@ apply_lambda (Lisp_Object fun, Lisp_Object args, 
ptrdiff_t count)
    FUN must be either a lambda-expression, a compiled-code object,
    or a module function.  */
 
-static Lisp_Object
+Lisp_Object
 funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
                register Lisp_Object *arg_vector)
 {
@@ -3053,7 +3068,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
            arg = Qnil;
 
          /* Bind the argument.  */
-         if (!NILP (lexenv) && SYMBOLP (next))
+         if (!NILP (lexenv))
            /* Lexically bind NEXT by adding it to the lexenv alist.  */
            lexenv = Fcons (Fcons (next, arg), lexenv);
          else
diff --git a/src/lisp.h b/src/lisp.h
index ef6302a..e04e374 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4113,7 +4113,6 @@ extern Lisp_Object Vautoload_queue;
 extern Lisp_Object Vrun_hooks;
 extern Lisp_Object Vsignaling_function;
 extern Lisp_Object inhibit_lisp_code;
-extern int backtrace_byte_offset;
 
 /* To run a normal hook, use the appropriate function from the list below.
    The calling convention:
@@ -4141,6 +4140,7 @@ extern AVOID signal_error (const char *, Lisp_Object);
 extern AVOID overflow_error (void);
 extern bool FUNCTIONP (Lisp_Object);
 extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, 
Lisp_Object *arg_vector);
+extern Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
 extern Lisp_Object eval_sub (Lisp_Object form);
 extern Lisp_Object apply1 (Lisp_Object, Lisp_Object);
 extern Lisp_Object call0 (Lisp_Object);
@@ -4185,6 +4185,7 @@ extern Lisp_Object vformat_string (const char *, va_list)
   ATTRIBUTE_FORMAT_PRINTF (1, 0);
 extern void un_autoload (Lisp_Object);
 extern Lisp_Object call_debugger (Lisp_Object arg);
+extern void do_debug_on_call (Lisp_Object code, ptrdiff_t count);
 extern void init_eval_once (void);
 extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...);
 extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object);
@@ -4193,8 +4194,10 @@ extern void init_eval (void);
 extern void syms_of_eval (void);
 extern void prog_ignore (Lisp_Object);
 extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
+extern ptrdiff_t record_in_backtrace_with_offset (Lisp_Object, Lisp_Object *, 
ptrdiff_t, int);
 extern void mark_specpdl (union specbinding *first, union specbinding *ptr);
 extern void get_backtrace (Lisp_Object array);
+extern bool backtrace_debug_on_exit (union specbinding *pdl);
 Lisp_Object backtrace_top_function (void);
 extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);