(struct byte_stack): New.

(byte_stack_list, mark_byte_stack, relocate_byte_pcs): New
(BEFORE_POTENTIAL_GC, AFTER_POTENTIAL_GC): New.
(FETCH, PUSH, POP, DISCARD, TOP, MAYBE_GC): Rewritten.
(HANDLE_RELOCATION): Removed.
(Fbyte_code): Use byte_stack structures.

1 files changed, 158 insertions, 67 deletions

diff --git a/src/bytecode.c b/src/bytecode.c
index e69ae722248..0093e692b2f 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -224,10 +224,86 @@ Lisp_Object Qbytecode;
 
 #define Bconstant 0300
 #define CONSTANTLIM 0100
+
+/* Structure describing a value stack used during byte-code execution
+   in Fbyte_code.  */
+
+struct byte_stack
+{
+  /* Program counter.  This points into the byte_string below
+     and is relocated when that string is relocated.  */
+  unsigned char *pc;
+
+  /* Top and bottom of stack.  The bottom points to an area of memory
+     allocated with alloca in Fbyte_code.  */
+  Lisp_Object *top, *bottom;
+
+  /* The string containing the byte-code, and its current address.
+     Storing this here protects it from GC because mark_byte_stack
+     marks it.  */
+  Lisp_Object byte_string;
+  unsigned char *byte_string_start;
+
+  /* The vector of constants used during byte-code execution.  Storing
+     this here protects it from GC because mark_byte_stack marks it.  */
+  Lisp_Object constants;
+
+  /* Next entry in byte_stack_list.  */
+  struct byte_stack *next;
+};
+
+/* A list of currently active byte-code execution value stacks.
+   Fbyte_code adds an entry to the head of this list before it starts
+   processing byte-code, and it removed the entry again when it is
+   done.  Signalling an error truncates the list analoguous to
+   gcprolist.  */
+
+struct byte_stack *byte_stack_list;
+
+/* Mark objects on byte_stack_list.  Called during GC.  */
+
+void
+mark_byte_stack ()
+{
+  struct byte_stack *stack;
+  Lisp_Object *obj;
+
+  for (stack = byte_stack_list; stack; stack = stack->next)
+    {
+      if (!stack->top)
+        abort ();
+      
+      for (obj = stack->bottom; obj <= stack->top; ++obj)
+        mark_object (obj);
+
+      mark_object (&stack->byte_string);
+      mark_object (&stack->constants);
+    }
+}
+
+
+/* Relocate program counters in the stacks on byte_stack_list.  Called
+   when GC has completed.  */
+
+void 
+relocate_byte_pcs ()
+{
+  struct byte_stack *stack;
+
+  for (stack = byte_stack_list; stack; stack = stack->next)
+    if (stack->byte_string_start != XSTRING (stack->byte_string)->data)
+      {
+        int offset = stack->pc - stack->byte_string_start;
+        stack->byte_string_start = XSTRING (stack->byte_string)->data;
+        stack->pc = stack->byte_string_start + offset;
+      }
+}
+
+
 
 /* Fetch the next byte from the bytecode stream */
 
-#define FETCH *pc++
+#define FETCH *stack.pc++
 
 /* Fetch two bytes from the bytecode stream
  and make a 16-bit number out of them */
@@ -236,22 +312,30 @@ Lisp_Object Qbytecode;
 
 /* Push x onto the execution stack. */
 
-/* This used to be #define PUSH(x) (*++stackp = (x))
-   This oddity is necessary because Alliant can't be bothered to
-   compile the preincrement operator properly, as of 4/91.  -JimB  */
-#define PUSH(x) (stackp++, *stackp = (x))
+/* This used to be #define PUSH(x) (*++stackp = (x)) This oddity is
+   necessary because Alliant can't be bothered to compile the
+   preincrement operator properly, as of 4/91.  -JimB */
+
+#define PUSH(x) (top++, *top = (x))
 
 /* Pop a value off the execution stack.  */
 
-#define POP (*stackp--)
+#define POP (*top--)
 
 /* Discard n values from the execution stack.  */
 
-#define DISCARD(n) (stackp -= (n))
+#define DISCARD(n) (top -= (n))
+
+/* Get the value which is at the top of the execution stack, but don't
+   pop it. */
+
+#define TOP (*top)
 
-/* Get the value which is at the top of the execution stack, but don't pop it. */
+/* Actions that must performed before and after calling a function
+   that might GC.  */
 
-#define TOP (*stackp)
+#define BEFORE_POTENTIAL_GC()   stack.top = top
+#define AFTER_POTENTIAL_GC()    stack.top = NULL
 
 /* Garbage collect if we have consed enough since the last time.
    We do this at every branch, to avoid loops that never GC.  */
@@ -259,24 +343,26 @@ Lisp_Object Qbytecode;
 #define MAYBE_GC()                              \
   if (consing_since_gc > gc_cons_threshold)     \
     {                                           \
+      BEFORE_POTENTIAL_GC ();                   \
       Fgarbage_collect ();                      \
-      HANDLE_RELOCATION ();                     \
+      AFTER_POTENTIAL_GC ();                    \
     }                                           \
   else
 
-/* Relocate BYTESTR if there has been a GC recently.  */
-#define HANDLE_RELOCATION()                                             \
-  if (! EQ (string_saved, bytestr))                                     \
-    {                                                                   \
-      pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data; \
-      string_saved = bytestr;                                           \
-    }                                                                   \
-  else
-
 /* Check for jumping out of range.  */
+
+#ifdef BYTE_CODE_SAFE
+
 #define CHECK_RANGE(ARG)                        \
   if (ARG >= bytestr_length) abort ()
 
+#else
+
+#define CHECK_RANGE(ARG)
+
+#endif
+
+
 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
   "Function used internally in byte-compiled code.\n\
 The first argument, BYTESTR, is a string of byte code;\n\
@@ -286,61 +372,53 @@ If the third argument is incorrect, Emacs may crash.")
   (bytestr, vector, maxdepth)
      Lisp_Object bytestr, vector, maxdepth;
 {
-  struct gcpro gcpro1, gcpro2, gcpro3;
   int count = specpdl_ptr - specpdl;
 #ifdef BYTE_CODE_METER
   int this_op = 0;
   int prev_op;
 #endif
-  register int op;
-  unsigned char *pc;
-  Lisp_Object *stack;
-  register Lisp_Object *stackp;
-  Lisp_Object *stacke;
-  register Lisp_Object v1, v2;
-  register Lisp_Object *vectorp = XVECTOR (vector)->contents;
+  int op;
+  Lisp_Object v1, v2;
+  Lisp_Object *stackp;
+  Lisp_Object *vectorp = XVECTOR (vector)->contents;
 #ifdef BYTE_CODE_SAFE
-  register int const_length = XVECTOR (vector)->size;
+  int const_length = XVECTOR (vector)->size;
+  Lisp_Object *stacke;
 #endif
-  /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated.  */
-  Lisp_Object string_saved;
-  /* Cached address of beginning of string,
-     valid if BYTESTR equals STRING_SAVED.  */
-  register unsigned char *strbeg;
   int bytestr_length = STRING_BYTES (XSTRING (bytestr));
+  struct byte_stack stack;
+  Lisp_Object *top;
 
   CHECK_STRING (bytestr, 0);
   if (!VECTORP (vector))
     vector = wrong_type_argument (Qvectorp, vector);
   CHECK_NUMBER (maxdepth, 2);
 
-  stackp = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object));
-  bzero (stackp, XFASTINT (maxdepth) * sizeof (Lisp_Object));
-  GCPRO3 (bytestr, vector, *stackp);
-  gcpro3.nvars = XFASTINT (maxdepth);
-
-  --stackp;
-  stack = stackp;
-  stacke = stackp + XFASTINT (maxdepth);
-
-  /* Initialize the saved pc-pointer for fetching from the string.  */
-  string_saved = bytestr;
-  pc = XSTRING (string_saved)->data;
+  stack.byte_string = bytestr;
+  stack.pc = stack.byte_string_start = XSTRING (bytestr)->data;
+  stack.constants = vector;
+  stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth) 
+                                         * sizeof (Lisp_Object));
+  top = stack.bottom - 1;
+  stack.top = NULL;
+  stack.next = byte_stack_list;
+  byte_stack_list = &stack;
 
+#ifdef BYTE_CODE_SAFE
+  stacke = stack.bottom - 1 + XFASTINT (maxdepth);
+#endif
+  
   while (1)
     {
 #ifdef BYTE_CODE_SAFE
-      if (stackp > stacke)
+      if (top > stacks)
         error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
-               pc - XSTRING (string_saved)->data, stacke - stackp);
-      if (stackp < stack)
+               stack.pc - stack.byte_string_start, stacke - top);
+      else if (top < stack.bottom - 1)
         error ("Byte code stack underflow (byte compiler bug), pc %d",
-               pc - XSTRING (string_saved)->data);
+               stack.pc - stack.byte_string_start);
 #endif
 
-      /* Update BYTESTR if we had a garbage collection.  */
-      HANDLE_RELOCATION ();
-
 #ifdef BYTE_CODE_METER
       prev_op = this_op;
       this_op = op = FETCH;
@@ -430,7 +508,9 @@ If the third argument is incorrect, Emacs may crash.")
                 }
             }
 #endif
+          BEFORE_POTENTIAL_GC ();
           TOP = Ffuncall (op + 1, &TOP);
+          AFTER_POTENTIAL_GC ();
           break;
 
         case Bunbind+6:
@@ -445,13 +525,17 @@ If the third argument is incorrect, Emacs may crash.")
         case Bunbind+4: case Bunbind+5:
           op -= Bunbind;
         dounbind:
+          BEFORE_POTENTIAL_GC ();
           unbind_to (specpdl_ptr - specpdl - op, Qnil);
+          AFTER_POTENTIAL_GC ();
           break;
 
         case Bunbind_all:
           /* To unbind back to the beginning of this frame.  Not used yet,
              but will be needed for tail-recursion elimination.  */
+          BEFORE_POTENTIAL_GC ();
           unbind_to (count, Qnil);
+          AFTER_POTENTIAL_GC ();
           break;
 
         case Bgoto:
@@ -459,7 +543,7 @@ If the third argument is incorrect, Emacs may crash.")
           QUIT;
           op = FETCH2;    /* pc = FETCH2 loses since FETCH2 contains pc++ */
           CHECK_RANGE (op);
-          pc = XSTRING (string_saved)->data + op;
+          stack.pc = stack.byte_string_start + op;
           break;
 
         case Bgotoifnil:
@@ -469,7 +553,7 @@ If the third argument is incorrect, Emacs may crash.")
             {
               QUIT;
               CHECK_RANGE (op);
-              pc = XSTRING (string_saved)->data + op;
+              stack.pc = stack.byte_string_start + op;
             }
           break;
 
@@ -480,7 +564,7 @@ If the third argument is incorrect, Emacs may crash.")
             {
               QUIT;
               CHECK_RANGE (op);
-              pc = XSTRING (string_saved)->data + op;
+              stack.pc = stack.byte_string_start + op;
             }
           break;
 
@@ -491,7 +575,7 @@ If the third argument is incorrect, Emacs may crash.")
             {
               QUIT;
               CHECK_RANGE (op);
-              pc = XSTRING (string_saved)->data + op;
+              stack.pc = stack.byte_string_start + op;
             }
           else DISCARD (1);
           break;
@@ -503,7 +587,7 @@ If the third argument is incorrect, Emacs may crash.")
             {
               QUIT;
               CHECK_RANGE (op);
-              pc = XSTRING (string_saved)->data + op;
+              stack.pc = stack.byte_string_start + op;
             }
           else DISCARD (1);
           break;
@@ -511,7 +595,7 @@ If the third argument is incorrect, Emacs may crash.")
         case BRgoto:
           MAYBE_GC ();
           QUIT;
-          pc += (int) *pc - 127;
+          stack.pc += (int) *stack.pc - 127;
           break;
 
         case BRgotoifnil:
@@ -519,9 +603,9 @@ If the third argument is incorrect, Emacs may crash.")
           if (NILP (POP))
             {
               QUIT;
-              pc += (int) *pc - 128;
+              stack.pc += (int) *stack.pc - 128;
             }
-          pc++;
+          stack.pc++;
           break;
 
         case BRgotoifnonnil:
@@ -529,29 +613,29 @@ If the third argument is incorrect, Emacs may crash.")
           if (!NILP (POP))
             {
               QUIT;
-              pc += (int) *pc - 128;
+              stack.pc += (int) *stack.pc - 128;
             }
-          pc++;
+          stack.pc++;
           break;
 
         case BRgotoifnilelsepop:
           MAYBE_GC ();
-          op = *pc++;
+          op = *stack.pc++;
           if (NILP (TOP))
             {
               QUIT;
-              pc += op - 128;
+              stack.pc += op - 128;
             }
           else DISCARD (1);
           break;
 
         case BRgotoifnonnilelsepop:
           MAYBE_GC ();
-          op = *pc++;
+          op = *stack.pc++;
           if (!NILP (TOP))
             {
               QUIT;
-              pc += op - 128;
+              stack.pc += op - 128;
             }
           else DISCARD (1);
           break;
@@ -603,7 +687,9 @@ If the third argument is incorrect, Emacs may crash.")
         case Bcondition_case:
           v1 = POP;
           v1 = Fcons (POP, v1);
+          BEFORE_POTENTIAL_GC ();
           TOP = Fcondition_case (Fcons (TOP, v1));
+          AFTER_POTENTIAL_GC ();
           break;
 
         case Btemp_output_buffer_setup:
@@ -616,7 +702,9 @@ If the third argument is incorrect, Emacs may crash.")
           temp_output_buffer_show (TOP);
           TOP = v1;
           /* pop binding of standard-output */
+          BEFORE_POTENTIAL_GC ();
           unbind_to (specpdl_ptr - specpdl - 1, Qnil);
+          AFTER_POTENTIAL_GC ();
           break;
 
         case Bnth:
@@ -1146,7 +1234,9 @@ If the third argument is incorrect, Emacs may crash.")
     }
 
  exit:
-  UNGCPRO;
+
+  byte_stack_list = byte_stack_list->next;
+
   /* Binds and unbinds are supposed to be compiled balanced.  */
   if (specpdl_ptr - specpdl != count)
 #ifdef BYTE_CODE_SAFE
@@ -1154,6 +1244,7 @@ If the third argument is incorrect, Emacs may crash.")
 #else
     abort ();
 #endif
+  
   return v1;
 }