mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-25 15:00:45 -08:00
Code Issues Projects Releases Wiki Activity

(struct byte_stack): New.

Browse source 
(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.
This commit is contained in:
Gerd Moellmann 1999-11-05 21:26:15 +00:00
parent 4d59c34cd8
commit 7ca1e8b752
1 changed files with 158 additions and 67 deletions
Download patch file Download diff file Expand all files Collapse all files

225
src/bytecode.c
View file

@ -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. */
/* Get the value which is at the top of the execution stack, but don't
pop it. */
#define TOP (*stackp)
#define TOP (*top)
/* Actions that must performed before and after calling a function
that might GC. */
#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;
}