6 files changed, 303 insertions, 51 deletions

diff --git a/src/alloc.c b/src/alloc.c
index 9ed94dc8a1e..c19e3dabb6e 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -4928,7 +4928,7 @@ mark_maybe_pointer (void *p, bool symbol_only)
 /* Mark Lisp objects referenced from the address range START..END
    or END..START.  */
 
-static void ATTRIBUTE_NO_SANITIZE_ADDRESS
+void ATTRIBUTE_NO_SANITIZE_ADDRESS
 mark_memory (void const *start, void const *end)
 {
   char const *pp;
diff --git a/src/bytecode.c b/src/bytecode.c
index 7c390c0d40e..9356ebeb6cb 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -334,6 +334,166 @@ bcall0 (Lisp_Object f)
   Ffuncall (1, &f);
 }
 
+/* Layout of the stack frame header. */
+enum stack_frame_index {
+  SFI_SAVED_FP,   /* previous frame pointer */
+
+  /* In a frame called directly from C, the following two members are NULL.  */
+  SFI_SAVED_TOP,  /* previous stack pointer */
+  SFI_SAVED_PC,   /* previous program counter */
+
+  SFI_FUN,        /* current function object */
+
+  SF_SIZE         /* number of words in the header */
+};
+
+/* The bytecode stack size in Lisp words.
+   This is a fairly generous amount, but:
+   - if users need more, we could allocate more, or just reserve the address
+     space and allocate on demand
+   - if threads are used more, then it might be a good idea to reduce the
+     per-thread overhead in time and space
+   - for maximum flexibility but a small runtime penalty, we could allocate
+     the stack in smaller chunks as needed
+*/
+#define BC_STACK_SIZE (512 * 1024)
+
+/* Bytecode interpreter stack:
+
+           |--------------|         --
+           |fun           |           |                   ^ stack growth
+           |saved_pc      |           |                   | direction
+           |saved_top    -------      |
+     fp--->|saved_fp     ----   |     | current frame
+           |--------------|  |  |     | (called from bytecode in this example)
+           |   (free)     |  |  |     |
+     top-->| ...stack...  |  |  |     |
+           : ...          :  |  |     |
+           |incoming args |  |  |     |
+           |--------------|  |  |   --
+           |fun           |  |  |     |
+           |saved_pc      |  |  |     |
+           |saved_top     |  |  |     |
+           |saved_fp      |<-   |     | previous frame
+           |--------------|     |     |
+           |   (free)     |     |     |
+           | ...stack...  |<----      |
+           : ...          :           |
+           |incoming args |           |
+           |--------------|         --
+           :              :
+*/
+
+INLINE void *
+sf_get_ptr (Lisp_Object *fp, enum stack_frame_index index)
+{
+  return XLP (fp[index]);
+}
+
+INLINE void
+sf_set_ptr (Lisp_Object *fp, enum stack_frame_index index, void *value)
+{
+  fp[index] = XIL ((EMACS_INT)value);
+}
+
+INLINE Lisp_Object *
+sf_get_lisp_ptr (Lisp_Object *fp, enum stack_frame_index index)
+{
+  return sf_get_ptr (fp, index);
+}
+
+INLINE void
+sf_set_lisp_ptr (Lisp_Object *fp, enum stack_frame_index index,
+                 Lisp_Object *value)
+{
+  sf_set_ptr (fp, index, value);
+}
+
+INLINE const unsigned char *
+sf_get_saved_pc (Lisp_Object *fp)
+{
+  return sf_get_ptr (fp, SFI_SAVED_PC);
+}
+
+INLINE void
+sf_set_saved_pc (Lisp_Object *fp, const unsigned char *value)
+{
+  sf_set_ptr (fp, SFI_SAVED_PC, (unsigned char *)value);
+}
+
+void
+init_bc_thread (struct bc_thread_state *bc)
+{
+  bc->stack = xmalloc (BC_STACK_SIZE * sizeof *bc->stack);
+  bc->stack_end = bc->stack + BC_STACK_SIZE;
+  /* Put a dummy header at the bottom to indicate the first free location.  */
+  bc->fp = bc->stack;
+  memset (bc->fp, 0, SF_SIZE * sizeof *bc->stack);
+}
+
+void
+free_bc_thread (struct bc_thread_state *bc)
+{
+  xfree (bc->stack);
+}
+
+void
+mark_bytecode (struct bc_thread_state *bc)
+{
+  Lisp_Object *fp = bc->fp;
+  Lisp_Object *top = NULL;     /* stack pointer of topmost frame not known */
+  for (;;)
+    {
+      Lisp_Object *next_fp = sf_get_lisp_ptr (fp, SFI_SAVED_FP);
+      /* Only the dummy frame at the bottom has saved_fp = NULL.  */
+      if (!next_fp)
+        break;
+      mark_object (fp[SFI_FUN]);
+      Lisp_Object *frame_base = next_fp + SF_SIZE;
+      if (top)
+        {
+          /* The stack pointer of a frame is known: mark the part of the stack
+             above it conservatively.  This includes any outgoing arguments.  */
+          mark_memory (top + 1, fp);
+          /* Mark the rest of the stack precisely.  */
+          mark_objects (frame_base, top + 1 - frame_base);
+        }
+      else
+        {
+          /* The stack pointer is unknown -- mark everything conservatively.  */
+          mark_memory (frame_base, fp);
+        }
+      top = sf_get_lisp_ptr (fp, SFI_SAVED_TOP);
+      fp = next_fp;
+    }
+}
+
+DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats,
+       0, 0, 0,
+       doc: /* internal */)
+  (void)
+{
+  struct bc_thread_state *bc = &current_thread->bc;
+  int nframes = 0;
+  int nruns = 0;
+  for (Lisp_Object *fp = bc->fp; fp; fp = sf_get_lisp_ptr (fp, SFI_SAVED_FP))
+    {
+      nframes++;
+      if (sf_get_lisp_ptr (fp, SFI_SAVED_TOP) == NULL)
+        nruns++;
+    }
+  fprintf (stderr, "%d stack frames, %d runs\n", nframes, nruns);
+  return Qnil;
+}
+
+/* Whether a stack pointer is valid in the current frame.  */
+INLINE bool
+valid_sp (struct bc_thread_state *bc, Lisp_Object *sp)
+{
+  Lisp_Object *fp = bc->fp;
+  return sp < fp && sp + 1 >= sf_get_lisp_ptr (fp, SFI_SAVED_FP) + SF_SIZE;
+}
+
 /* Execute the byte-code in FUN.  ARGS_TEMPLATE is the function arity
    encoded as an integer (the one in FUN is ignored), and ARGS, of
    size NARGS, should be a vector of the actual arguments.  The
@@ -347,37 +507,49 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
 #ifdef BYTE_CODE_METER
   int volatile this_op = 0;
 #endif
+  unsigned char quitcounter = 1;
+  struct bc_thread_state *bc = &current_thread->bc;
+
+  /* Values used for the first stack record when called from C.  */
+  Lisp_Object *top = NULL;
+  unsigned char const *pc = NULL;
 
   Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE);
 
+ setup_frame: ;
   eassert (!STRING_MULTIBYTE (bytestr));
   eassert (string_immovable_p (bytestr));
+  /* FIXME: in debug mode (!NDEBUG, BYTE_CODE_SAFE or enabled checking),
+     save the specpdl index on function entry and check that it is the same
+     when returning, to detect unwind imbalances.  This would require adding
+     a field to the frame header.  */
+
   Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS);
   Lisp_Object maxdepth = AREF (fun, COMPILED_STACK_DEPTH);
   ptrdiff_t const_length = ASIZE (vector);
   ptrdiff_t bytestr_length = SCHARS (bytestr);
   Lisp_Object *vectorp = XVECTOR (vector)->contents;
 
-  unsigned char quitcounter = 1;
-  /* Allocate two more slots than required, because... */
-  EMACS_INT stack_items = XFIXNAT (maxdepth) + 2;
-  USE_SAFE_ALLOCA;
-  void *alloc;
-  SAFE_ALLOCA_LISP (alloc, stack_items);
-  Lisp_Object *stack_base = alloc;
-  /* ... we plonk BYTESTR and VECTOR there to ensure that they survive
-     GC (bug#33014), since these variables aren't used directly beyond
-     the interpreter prologue and wouldn't be found in the stack frame
-     otherwise.  */
-  stack_base[0] = bytestr;
-  stack_base[1] = vector;
-  Lisp_Object *top = stack_base + 1;
-  Lisp_Object *stack_lim = top + stack_items;
+  EMACS_INT max_stack = XFIXNAT (maxdepth);
+  Lisp_Object *frame_base = bc->fp + SF_SIZE;
+  Lisp_Object *fp = frame_base + max_stack;
+
+  if (fp + SF_SIZE > bc->stack_end)
+    error ("Bytecode stack overflow");
+
+  /* Save the function object so that the bytecode and vector are
+     held from removal by the GC. */
+  fp[SFI_FUN] = fun;
+  /* Save previous stack pointer and pc in the new frame.  If we came
+     directly from outside, these will be NULL.  */
+  sf_set_lisp_ptr (fp, SFI_SAVED_TOP, top);
+  sf_set_saved_pc (fp, pc);
+  sf_set_lisp_ptr (fp, SFI_SAVED_FP, bc->fp);
+  bc->fp = fp;
+
+  top = frame_base - 1;
   unsigned char const *bytestr_data = SDATA (bytestr);
-  unsigned char const *pc = bytestr_data;
-#if BYTE_CODE_SAFE || !defined NDEBUG
-  specpdl_ref count = SPECPDL_INDEX ();
-#endif
+  pc = bytestr_data;
 
   /* ARGS_TEMPLATE is composed of bit fields:
      bits 0..6    minimum number of arguments
@@ -404,7 +576,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
       int op;
       enum handlertype type;
 
-      if (BYTE_CODE_SAFE && ! (stack_base <= top && top < stack_lim))
+      if (BYTE_CODE_SAFE && !valid_sp (bc, top))
         emacs_abort ();
 
 #ifdef BYTE_CODE_METER
@@ -636,36 +808,45 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
                   error ("Lisp nesting exceeds `max-lisp-eval-depth'");
               }
 
-            ptrdiff_t numargs = op;
-            Lisp_Object fun = TOP;
-            Lisp_Object *args = &TOP + 1;
+            ptrdiff_t call_nargs = op;
+            Lisp_Object call_fun = TOP;
+            Lisp_Object *call_args = &TOP + 1;
 
-            specpdl_ref count1 = record_in_backtrace (fun, args, numargs);
+            specpdl_ref count1 = record_in_backtrace (call_fun,
+                                                      call_args, call_nargs);
             maybe_gc ();
             if (debug_on_next_call)
               do_debug_on_call (Qlambda, count1);
 
-            Lisp_Object original_fun = fun;
-            if (SYMBOLP (fun))
-              fun = XSYMBOL (fun)->u.s.function;
+            Lisp_Object original_fun = call_fun;
+            if (SYMBOLP (call_fun))
+              call_fun = XSYMBOL (call_fun)->u.s.function;
             Lisp_Object template;
             Lisp_Object bytecode;
-            Lisp_Object val;
-            if (COMPILEDP (fun)
+            if (COMPILEDP (call_fun)
                 // Lexical binding only.
-                && (template = AREF (fun, COMPILED_ARGLIST),
+                && (template = AREF (call_fun, COMPILED_ARGLIST),
                     FIXNUMP (template))
                 // No autoloads.
-                && (bytecode = AREF (fun, COMPILED_BYTECODE),
+                && (bytecode = AREF (call_fun, COMPILED_BYTECODE),
                     !CONSP (bytecode)))
-              val = exec_byte_code (fun, XFIXNUM (template), numargs, args);
-            else if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
-              val = funcall_subr (XSUBR (fun), numargs, args);
+              {
+                fun = call_fun;
+                bytestr = bytecode;
+                args_template = XFIXNUM (template);
+                nargs = call_nargs;
+                args = call_args;
+                goto setup_frame;
+              }
+
+            Lisp_Object val;
+            if (SUBRP (call_fun) && !SUBR_NATIVE_COMPILED_DYNP (call_fun))
+              val = funcall_subr (XSUBR (call_fun), call_nargs, call_args);
             else
-              val = funcall_general (original_fun, numargs, args);
+              val = funcall_general (original_fun, call_nargs, call_args);
 
             lisp_eval_depth--;
-            if (backtrace_debug_on_exit (specpdl_ref_to_ptr (count1)))
+            if (backtrace_debug_on_exit (specpdl_ptr - 1))
               val = call_debugger (list2 (Qexit, val));
             specpdl_ptr--;
 
@@ -731,7 +912,40 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
           NEXT;
 
         CASE (Breturn):
-          goto exit;
+          {
+            Lisp_Object *saved_top = sf_get_lisp_ptr (bc->fp, SFI_SAVED_TOP);
+            if (saved_top)
+              {
+                Lisp_Object val = TOP;
+
+                lisp_eval_depth--;
+                if (backtrace_debug_on_exit (specpdl_ptr - 1))
+                  val = call_debugger (list2 (Qexit, val));
+                specpdl_ptr--;
+
+                top = saved_top;
+                pc = sf_get_saved_pc (bc->fp);
+                Lisp_Object *fp = sf_get_lisp_ptr (bc->fp, SFI_SAVED_FP);
+                bc->fp = fp;
+
+                Lisp_Object fun = fp[SFI_FUN];
+                Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE);
+                Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS);
+                bytestr_data = SDATA (bytestr);
+                vectorp = XVECTOR (vector)->contents;
+                if (BYTE_CODE_SAFE)
+                  {
+                    /* Only required for checking, not for execution.  */
+                    const_length = ASIZE (vector);
+                    bytestr_length = SCHARS (bytestr);
+                  }
+
+                TOP = val;
+                NEXT;
+              }
+            else
+              goto exit;
+          }
 
         CASE (Bdiscard):
           DISCARD (1);
@@ -786,9 +1000,23 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
             if (sys_setjmp (c->jmp))
               {
                 struct handler *c = handlerlist;
+                handlerlist = c->next;
                 top = c->bytecode_top;
                 op = c->bytecode_dest;
-                handlerlist = c->next;
+                Lisp_Object *fp = bc->fp;
+
+                Lisp_Object fun = fp[SFI_FUN];
+                Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE);
+                Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS);
+                bytestr_data = SDATA (bytestr);
+                vectorp = XVECTOR (vector)->contents;
+                if (BYTE_CODE_SAFE)
+                  {
+                    /* Only required for checking, not for execution.  */
+                    const_length = ASIZE (vector);
+                    bytestr_length = SCHARS (bytestr);
+                  }
+                pc = bytestr_data;
                 PUSH (c->val);
                 goto op_branch;
               }
@@ -1527,20 +1755,9 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
 
  exit:
 
-#if BYTE_CODE_SAFE || !defined NDEBUG
-  if (!specpdl_ref_eq (SPECPDL_INDEX (), count))
-    {
-      /* Binds and unbinds are supposed to be compiled balanced.  */
-      if (specpdl_ref_lt (count, SPECPDL_INDEX ()))
-        unbind_to (count, Qnil);
-      error ("binding stack not balanced (serious byte compiler bug)");
-    }
-#endif
-  /* The byte code should have been properly pinned.  */
-  eassert (SDATA (bytestr) == bytestr_data);
+  bc->fp = sf_get_lisp_ptr (bc->fp, SFI_SAVED_FP);
 
   Lisp_Object result = TOP;
-  SAFE_FREE ();
   return result;
 }
 
@@ -1562,6 +1779,7 @@ void
 syms_of_bytecode (void)
 {
   defsubr (&Sbyte_code);
+  defsubr (&Sinternal_stack_stats);
 
 #ifdef BYTE_CODE_METER
 
diff --git a/src/eval.c b/src/eval.c
index b1c1a8c676b..c46b74ac40c 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1233,6 +1233,7 @@ unwind_to_catch (struct handler *catch, enum nonlocal_exit type,
   eassert (handlerlist == catch);
 
   lisp_eval_depth = catch->f_lisp_eval_depth;
+  set_act_rec (current_thread, catch->act_rec);
 
   sys_longjmp (catch->jmp, 1);
 }
@@ -1673,6 +1674,7 @@ push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
   c->next = handlerlist;
   c->f_lisp_eval_depth = lisp_eval_depth;
   c->pdlcount = SPECPDL_INDEX ();
+  c->act_rec = get_act_rec (current_thread);
   c->poll_suppress_count = poll_suppress_count;
   c->interrupt_input_blocked = interrupt_input_blocked;
   handlerlist = c;
diff --git a/src/lisp.h b/src/lisp.h
index 5e3590675d1..8053bbc9777 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3546,6 +3546,7 @@ struct handler
   sys_jmp_buf jmp;
   EMACS_INT f_lisp_eval_depth;
   specpdl_ref pdlcount;
+  Lisp_Object *act_rec;
   int poll_suppress_count;
   int interrupt_input_blocked;
 };
@@ -4087,6 +4088,7 @@ extern void alloc_unexec_pre (void);
 extern void alloc_unexec_post (void);
 extern void mark_stack (char const *, char const *);
 extern void flush_stack_call_func1 (void (*func) (void *arg), void *arg);
+extern void mark_memory (void const *start, void const *end);
 
 /* Force callee-saved registers and register windows onto the stack,
    so that conservative garbage collection can see their values.  */
@@ -4855,6 +4857,21 @@ extern void syms_of_bytecode (void);
 extern Lisp_Object exec_byte_code (Lisp_Object, ptrdiff_t,
                                    ptrdiff_t, Lisp_Object *);
 extern Lisp_Object get_byte_code_arity (Lisp_Object);
+extern void init_bc_thread (struct bc_thread_state *bc);
+extern void free_bc_thread (struct bc_thread_state *bc);
+extern void mark_bytecode (struct bc_thread_state *bc);
+
+INLINE Lisp_Object *
+get_act_rec (struct thread_state *th)
+{
+  return th->bc.fp;
+}
+
+INLINE void
+set_act_rec (struct thread_state *th, Lisp_Object *act_rec)
+{
+  th->bc.fp = act_rec;
+}
 
 /* Defined in macros.c.  */
 extern void init_macros (void);
diff --git a/src/thread.c b/src/thread.c
index b5b7d7c0d71..c6742341fb8 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -671,6 +671,8 @@ mark_one_thread (struct thread_state *thread)
       mark_object (tem);
     }
 
+  mark_bytecode (&thread->bc);
+
   /* No need to mark Lisp_Object members like m_last_thing_searched,
      as mark_threads_callback does that by calling mark_object.  */
 }
@@ -839,6 +841,7 @@ finalize_one_thread (struct thread_state *state)
   free_search_regs (&state->m_search_regs);
   free_search_regs (&state->m_saved_search_regs);
   sys_cond_destroy (&state->thread_condvar);
+  free_bc_thread (&state->bc);
 }
 
 DEFUN ("make-thread", Fmake_thread, Smake_thread, 1, 2, 0,
@@ -868,6 +871,8 @@ If NAME is given, it must be a string; it names the new thread.  */)
   new_thread->m_specpdl_end = new_thread->m_specpdl + size;
   new_thread->m_specpdl_ptr = new_thread->m_specpdl;
 
+  init_bc_thread (&new_thread->bc);
+
   sys_cond_init (&new_thread->thread_condvar);
 
   /* We'll need locking here eventually.  */
@@ -1127,6 +1132,7 @@ init_threads (void)
   sys_mutex_lock (&global_lock);
   current_thread = &main_thread.s;
   main_thread.s.thread_id = sys_thread_self ();
+  init_bc_thread (&main_thread.s.bc);
 }
 
 void
diff --git a/src/thread.h b/src/thread.h
index f2755045b2e..a29af702d13 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -33,6 +33,13 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 #include "sysselect.h"          /* FIXME */
 #include "systhread.h"
 
+/* Byte-code interpreter thread state.  */
+struct bc_thread_state {
+  Lisp_Object *fp;              /* current frame pointer (see bytecode.c) */
+  Lisp_Object *stack;
+  Lisp_Object *stack_end;
+};
+
 struct thread_state
 {
   union vectorlike_header header;
@@ -181,6 +188,8 @@ struct thread_state
 
   /* Threads are kept on a linked list.  */
   struct thread_state *next_thread;
+
+  struct bc_thread_state bc;
 } GCALIGNED_STRUCT;
 
 INLINE bool