X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=src%2Fbytecode.c;h=de2b646425bd2afd4212d11cf5033fa53eb9c1c4;hp=3cb169a23e0509110c46b2ee653d8bb5ec8a1159;hb=113b194be934327de99a168d809271db252c07c4;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910 diff --git a/src/bytecode.c b/src/bytecode.c index 3cb169a..de2b646 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1,4 +1,5 @@ /* Execution of byte code produced by bytecomp.el. + Implementation of compiled-function objects. Copyright (C) 1992, 1993 Free Software Foundation, Inc. This file is part of XEmacs. @@ -27,7 +28,7 @@ Boston, MA 02111-1307, USA. */ FSF: long ago. -hacked on by jwz@netscape.com 17-jun-91 +hacked on by jwz@netscape.com 1991-06 o added a compile-time switch to turn on simple sanity checking; o put back the obsolete byte-codes for error-detection; o added a new instruction, unbind_all, which I will use for @@ -41,25 +42,192 @@ by Hallvard: o added relative jump instructions; o all conditionals now only do QUIT if they jump. - Ben Wing: some changes for Mule, June 1995. + Ben Wing: some changes for Mule, 1995-06. + + Martin Buchholz: performance hacking, 1998-09. + See Internals Manual, Evaluation. */ #include #include "lisp.h" +#include "backtrace.h" #include "buffer.h" +#include "bytecode.h" +#include "opaque.h" #include "syntax.h" -/* - * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for - * debugging the byte compiler...) Somewhat surprisingly, defining this - * makes Fbyte_code about 8% slower. - * - * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. - */ -/* This isn't defined in FSF Emacs and isn't defined in XEmacs v19 */ -#ifdef DEBUG_XEMACS -#define BYTE_CODE_SAFE -#endif +#include +#include + +EXFUN (Ffetch_bytecode, 1); + +Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; + +enum Opcode /* Byte codes */ +{ + Bvarref = 010, + Bvarset = 020, + Bvarbind = 030, + Bcall = 040, + Bunbind = 050, + + Bnth = 070, + Bsymbolp = 071, + Bconsp = 072, + Bstringp = 073, + Blistp = 074, + Bold_eq = 075, + Bold_memq = 076, + Bnot = 077, + Bcar = 0100, + Bcdr = 0101, + Bcons = 0102, + Blist1 = 0103, + Blist2 = 0104, + Blist3 = 0105, + Blist4 = 0106, + Blength = 0107, + Baref = 0110, + Baset = 0111, + Bsymbol_value = 0112, + Bsymbol_function = 0113, + Bset = 0114, + Bfset = 0115, + Bget = 0116, + Bsubstring = 0117, + Bconcat2 = 0120, + Bconcat3 = 0121, + Bconcat4 = 0122, + Bsub1 = 0123, + Badd1 = 0124, + Beqlsign = 0125, + Bgtr = 0126, + Blss = 0127, + Bleq = 0130, + Bgeq = 0131, + Bdiff = 0132, + Bnegate = 0133, + Bplus = 0134, + Bmax = 0135, + Bmin = 0136, + Bmult = 0137, + + Bpoint = 0140, + Beq = 0141, /* was Bmark, + but no longer generated as of v18 */ + Bgoto_char = 0142, + Binsert = 0143, + Bpoint_max = 0144, + Bpoint_min = 0145, + Bchar_after = 0146, + Bfollowing_char = 0147, + Bpreceding_char = 0150, + Bcurrent_column = 0151, + Bindent_to = 0152, + Bequal = 0153, /* was Bscan_buffer, + but no longer generated as of v18 */ + Beolp = 0154, + Beobp = 0155, + Bbolp = 0156, + Bbobp = 0157, + Bcurrent_buffer = 0160, + Bset_buffer = 0161, + Bsave_current_buffer = 0162, /* was Bread_char, + but no longer generated as of v19 */ + Bmemq = 0163, /* was Bset_mark, + but no longer generated as of v18 */ + Binteractive_p = 0164, /* Needed since interactive-p takes + unevalled args */ + Bforward_char = 0165, + Bforward_word = 0166, + Bskip_chars_forward = 0167, + Bskip_chars_backward = 0170, + Bforward_line = 0171, + Bchar_syntax = 0172, + Bbuffer_substring = 0173, + Bdelete_region = 0174, + Bnarrow_to_region = 0175, + Bwiden = 0176, + Bend_of_line = 0177, + + Bconstant2 = 0201, + Bgoto = 0202, + Bgotoifnil = 0203, + Bgotoifnonnil = 0204, + Bgotoifnilelsepop = 0205, + Bgotoifnonnilelsepop = 0206, + Breturn = 0207, + Bdiscard = 0210, + Bdup = 0211, + + Bsave_excursion = 0212, + Bsave_window_excursion= 0213, + Bsave_restriction = 0214, + Bcatch = 0215, + + Bunwind_protect = 0216, + Bcondition_case = 0217, + Btemp_output_buffer_setup = 0220, + Btemp_output_buffer_show = 0221, + + Bunbind_all = 0222, + + Bset_marker = 0223, + Bmatch_beginning = 0224, + Bmatch_end = 0225, + Bupcase = 0226, + Bdowncase = 0227, + + Bstring_equal = 0230, + Bstring_lessp = 0231, + Bold_equal = 0232, + Bnthcdr = 0233, + Belt = 0234, + Bold_member = 0235, + Bold_assq = 0236, + Bnreverse = 0237, + Bsetcar = 0240, + Bsetcdr = 0241, + Bcar_safe = 0242, + Bcdr_safe = 0243, + Bnconc = 0244, + Bquo = 0245, + Brem = 0246, + Bnumberp = 0247, + Bintegerp = 0250, + + BRgoto = 0252, + BRgotoifnil = 0253, + BRgotoifnonnil = 0254, + BRgotoifnilelsepop = 0255, + BRgotoifnonnilelsepop = 0256, + + BlistN = 0257, + BconcatN = 0260, + BinsertN = 0261, + Bmember = 0266, /* new in v20 */ + Bassq = 0267, /* new in v20 */ + + Bconstant = 0300 +}; +typedef enum Opcode Opcode; +typedef unsigned char Opbyte; + + +static void invalid_byte_code_error (char *error_message, ...); + +Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, + CONST Opbyte *program_ptr, + Opcode opcode); + +static Lisp_Object execute_optimized_program (CONST Opbyte *program, + int stack_depth, + Lisp_Object *constants_data); + +extern Lisp_Object Qand_rest, Qand_optional; + +/* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. + This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */ /* #define BYTE_CODE_METER */ @@ -73,546 +241,648 @@ int byte_metering_on; #define METER_1(code) METER_2 (0, (code)) -#define METER_CODE(last_code, this_code) \ -{ \ - if (byte_metering_on) \ - { \ - if (METER_1 (this_code) != ((1< ival2 ? 1 : 0; + } + + arithcompare_float: + + { + double dval1, dval2; + + if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1); + else if (INTP (obj1)) dval1 = (double) XINT (obj1); + else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1); + else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2); + else if (INTP (obj2)) dval2 = (double) XINT (obj2); + else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2); + else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; + } +#else /* !LISP_FLOAT_TYPE */ + { + int ival1, ival2; + + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; + } +#endif /* !LISP_FLOAT_TYPE */ +} + +static Lisp_Object +bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) +{ +#ifdef LISP_FLOAT_TYPE + int ival1, ival2; + int float_p; + + retry: + + float_p = 0; + + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else if (FLOATP (obj1)) ival1 = 0, float_p = 1; + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else if (FLOATP (obj2)) ival2 = 0, float_p = 1; + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + if (!float_p) + { + switch (opcode) + { + case Bplus: ival1 += ival2; break; + case Bdiff: ival1 -= ival2; break; + case Bmult: ival1 *= ival2; break; + case Bquo: + if (ival2 == 0) Fsignal (Qarith_error, Qnil); + ival1 /= ival2; + break; + case Bmax: if (ival1 < ival2) ival1 = ival2; break; + case Bmin: if (ival1 > ival2) ival1 = ival2; break; + } + return make_int (ival1); + } + else + { + double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1; + double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2; + switch (opcode) + { + case Bplus: dval1 += dval2; break; + case Bdiff: dval1 -= dval2; break; + case Bmult: dval1 *= dval2; break; + case Bquo: + if (dval2 == 0) Fsignal (Qarith_error, Qnil); + dval1 /= dval2; + break; + case Bmax: if (dval1 < dval2) dval1 = dval2; break; + case Bmin: if (dval1 > dval2) dval1 = dval2; break; + } + return make_float (dval1); + } +#else /* !LISP_FLOAT_TYPE */ + int ival1, ival2; + + retry: -#define DISCARD(n) (stackp -= (n)) + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + switch (opcode) + { + case Bplus: ival1 += ival2; break; + case Bdiff: ival1 -= ival2; break; + case Bmult: ival1 *= ival2; break; + case Bquo: + if (ival2 == 0) Fsignal (Qarith_error, Qnil); + ival1 /= ival2; + break; + case Bmax: if (ival1 < ival2) ival1 = ival2; break; + case Bmin: if (ival1 > ival2) ival1 = ival2; break; + } + return make_int (ival1); +#endif /* !LISP_FLOAT_TYPE */ +} + +/* Apply compiled-function object FUN to the NARGS evaluated arguments + in ARGS, and return the result of evaluation. */ +Lisp_Object +funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) +{ + /* This function can GC */ + Lisp_Object symbol, tail; + int speccount = specpdl_depth(); + REGISTER int i = 0; + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + int optional = 0; + + if (!OPAQUEP (f->instructions)) + /* Lazily munge the instructions into a more efficient form */ + optimize_compiled_function (fun); + + /* optimize_compiled_function() guaranteed that f->specpdl_depth is + the required space on the specbinding stack for binding the args + and local variables of fun. So just reserve it once. */ + SPECPDL_RESERVE (f->specpdl_depth); + + /* Fmake_byte_code() guaranteed that f->arglist is a valid list + containing only non-constant symbols. */ + LIST_LOOP_3 (symbol, f->arglist, tail) + { + if (EQ (symbol, Qand_rest)) + { + tail = XCDR (tail); + symbol = XCAR (tail); + SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i])); + goto run_code; + } + else if (EQ (symbol, Qand_optional)) + optional = 1; + else if (i == nargs && !optional) + goto wrong_number_of_arguments; + else + SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil); + } + + if (i < nargs) + goto wrong_number_of_arguments; + + run_code: + + { + Lisp_Object value = + execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), + f->stack_depth, + XVECTOR_DATA (f->constants)); + + /* The attempt to optimize this by only unbinding variables failed + because using buffer-local variables as function parameters + leads to specpdl_ptr->func != 0 */ + /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */ + UNBIND_TO_GCPRO (speccount, value); + return value; + } + + wrong_number_of_arguments: + return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); +} + + +/* Read next uint8 from the instruction stream. */ +#define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++) + +/* Read next uint16 from the instruction stream. */ +#define READ_UINT_2 \ + (program_ptr += 2, \ + (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ + ((unsigned int) (unsigned char) program_ptr[-2]))) + +/* Read next int8 from the instruction stream. */ +#define READ_INT_1 ((int) (signed char) *program_ptr++) + +/* Read next int16 from the instruction stream. */ +#define READ_INT_2 \ + (program_ptr += 2, \ + (((int) ( signed char) program_ptr[-1]) * 256 + \ + ((int) (unsigned char) program_ptr[-2]))) + +/* Read next int8 from instruction stream; don't advance program_pointer */ +#define PEEK_INT_1 ((int) (signed char) program_ptr[0]) + +/* Read next int16 from instruction stream; don't advance program_pointer */ +#define PEEK_INT_2 \ + ((((int) ( signed char) program_ptr[1]) * 256) | \ + ((int) (unsigned char) program_ptr[0])) + +/* Do relative jumps from the current location. + We only do a QUIT if we jump backwards, for efficiency. + No infloops without backward jumps! */ +#define JUMP_RELATIVE(jump) do { \ + int JR_jump = (jump); \ + if (JR_jump < 0) QUIT; \ + program_ptr += JR_jump; \ +} while (0) + +#define JUMP JUMP_RELATIVE (PEEK_INT_2) +#define JUMPR JUMP_RELATIVE (PEEK_INT_1) + +#define JUMP_NEXT ((void) (program_ptr += 2)) +#define JUMPR_NEXT ((void) (program_ptr += 1)) + +/* Push x onto the execution stack. */ +#define PUSH(x) (*++stack_ptr = (x)) + +/* Pop a value off the execution stack. */ +#define POP (*stack_ptr--) + +/* Discard n values from the execution stack. */ +#define DISCARD(n) (stack_ptr -= (n)) /* Get the value which is at the top of the execution stack, but don't pop it. */ +#define TOP (*stack_ptr) -#define TOP (*stackp) +/* The actual interpreter for byte code. + This function has been seriously optimized for performance. + Don't change the constructs unless you are willing to do + real benchmarking and profiling work -- martin */ -DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* -Function used internally in byte-compiled code. -The first argument is a string of byte code; the second, a vector of constants; -the third, the maximum stack depth used in this function. -If the third argument is incorrect, Emacs may crash. -*/ - (bytestr, vector, maxdepth)) + +static Lisp_Object +execute_optimized_program (CONST Opbyte *program, + int stack_depth, + Lisp_Object *constants_data) { /* This function can GC */ - struct gcpro gcpro1, gcpro2, gcpro3; + REGISTER CONST Opbyte *program_ptr = (Opbyte *) program; + REGISTER Lisp_Object *stack_ptr + = alloca_array (Lisp_Object, stack_depth + 1); int speccount = specpdl_depth (); + struct gcpro gcpro1; + #ifdef BYTE_CODE_METER - int this_op = 0; - int prev_op; + Opcode this_opcode = 0; + Opcode prev_opcode; #endif - REGISTER int op; - int pc; - Lisp_Object *stack; - REGISTER Lisp_Object *stackp; - Lisp_Object *stacke; - REGISTER Lisp_Object v1, v2; - REGISTER Lisp_Object *vectorp = XVECTOR_DATA (vector); -#ifdef BYTE_CODE_SAFE - REGISTER int const_length = XVECTOR_LENGTH (vector); + +#ifdef ERROR_CHECK_BYTE_CODE + Lisp_Object *stack_beg = stack_ptr; + Lisp_Object *stack_end = stack_beg + stack_depth; #endif - REGISTER Emchar *massaged_code; - int massaged_code_len; - - CHECK_STRING (bytestr); - if (!VECTORP (vector)) - vector = wrong_type_argument (Qvectorp, vector); - CHECK_NATNUM (maxdepth); - - stackp = alloca_array (Lisp_Object, XINT (maxdepth)); - memset (stackp, 0, XINT (maxdepth) * sizeof (Lisp_Object)); - GCPRO3 (bytestr, vector, *stackp); - gcpro3.nvars = XINT (maxdepth); - - --stackp; - stack = stackp; - stacke = stackp + XINT (maxdepth); - - /* Initialize the pc-register and convert the string into a fixed-width - format for easier processing. */ - massaged_code = alloca_array (Emchar, 1 + XSTRING_CHAR_LENGTH (bytestr)); - massaged_code_len = - convert_bufbyte_string_into_emchar_string (XSTRING_DATA (bytestr), - XSTRING_LENGTH (bytestr), - massaged_code); - massaged_code[massaged_code_len] = 0; - pc = 0; + + /* Initialize all the objects on the stack to Qnil, + so we can GCPRO the whole stack. + The first element of the stack is actually a dummy. */ + { + int i; + Lisp_Object *p; + for (i = stack_depth, p = stack_ptr; i--;) + *++p = Qnil; + } + + GCPRO1 (stack_ptr[1]); + gcpro1.nvars = stack_depth; while (1) { -#ifdef BYTE_CODE_SAFE - if (stackp > stacke) - error ("Byte code stack overflow (byte compiler bug), pc %d, depth %ld", - pc, (long) (stacke - stackp)); - if (stackp < stack) - error ("Byte code stack underflow (byte compiler bug), pc %d", - pc); + REGISTER Opcode opcode = (Opcode) READ_UINT_1; +#ifdef ERROR_CHECK_BYTE_CODE + if (stack_ptr > stack_end) + invalid_byte_code_error ("byte code stack overflow"); + if (stack_ptr < stack_beg) + invalid_byte_code_error ("byte code stack underflow"); #endif #ifdef BYTE_CODE_METER - prev_op = this_op; - this_op = op = FETCH; - METER_CODE (prev_op, op); - switch (op) -#else - switch (op = FETCH) + prev_opcode = this_opcode; + this_opcode = opcode; + METER_CODE (prev_opcode, this_opcode); #endif + + switch (opcode) { - case Bvarref+6: - op = FETCH; - goto varref; - - case Bvarref+7: - op = FETCH2; - goto varref; - - case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3: - case Bvarref+4: case Bvarref+5: - op = op - Bvarref; - varref: - v1 = vectorp[op]; - if (!SYMBOLP (v1)) - v2 = Fsymbol_value (v1); + REGISTER int n; + + default: + if (opcode >= Bconstant) + PUSH (constants_data[opcode - Bconstant]); else - { - v2 = XSYMBOL (v1)->value; - if (SYMBOL_VALUE_MAGIC_P (v2)) - v2 = Fsymbol_value (v1); - } - PUSH (v2); + stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode); + break; + + case Bvarref: + case Bvarref+1: + case Bvarref+2: + case Bvarref+3: + case Bvarref+4: + case Bvarref+5: n = opcode - Bvarref; goto do_varref; + case Bvarref+7: n = READ_UINT_2; goto do_varref; + case Bvarref+6: n = READ_UINT_1; /* most common */ + do_varref: + { + Lisp_Object symbol = constants_data[n]; + Lisp_Object value = XSYMBOL (symbol)->value; + if (SYMBOL_VALUE_MAGIC_P (value)) + value = Fsymbol_value (symbol); + PUSH (value); break; + } - case Bvarset+6: - op = FETCH; - goto varset; - - case Bvarset+7: - op = FETCH2; - goto varset; - - case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3: - case Bvarset+4: case Bvarset+5: - op -= Bvarset; - varset: - Fset (vectorp[op], POP); + case Bvarset: + case Bvarset+1: + case Bvarset+2: + case Bvarset+3: + case Bvarset+4: + case Bvarset+5: n = opcode - Bvarset; goto do_varset; + case Bvarset+7: n = READ_UINT_2; goto do_varset; + case Bvarset+6: n = READ_UINT_1; /* most common */ + do_varset: + { + Lisp_Object symbol = constants_data[n]; + struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); + Lisp_Object old_value = symbol_ptr->value; + Lisp_Object new_value = POP; + if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) + symbol_ptr->value = new_value; + else + Fset (symbol, new_value); break; + } - case Bvarbind+6: - op = FETCH; - goto varbind; - - case Bvarbind+7: - op = FETCH2; - goto varbind; + case Bvarbind: + case Bvarbind+1: + case Bvarbind+2: + case Bvarbind+3: + case Bvarbind+4: + case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind; + case Bvarbind+7: n = READ_UINT_2; goto do_varbind; + case Bvarbind+6: n = READ_UINT_1; /* most common */ + do_varbind: + { + Lisp_Object symbol = constants_data[n]; + struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); + Lisp_Object old_value = symbol_ptr->value; + Lisp_Object new_value = POP; + if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) + { + specpdl_ptr->symbol = symbol; + specpdl_ptr->old_value = old_value; + specpdl_ptr->func = 0; + specpdl_ptr++; + specpdl_depth_counter++; - case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3: - case Bvarbind+4: case Bvarbind+5: - op -= Bvarbind; - varbind: - specbind (vectorp[op], POP); + symbol_ptr->value = new_value; + } + else + specbind_magic (symbol, new_value); break; + } + case Bcall: + case Bcall+1: + case Bcall+2: + case Bcall+3: + case Bcall+4: + case Bcall+5: case Bcall+6: - op = FETCH; - goto docall; - case Bcall+7: - op = FETCH2; - goto docall; - - case Bcall: case Bcall+1: case Bcall+2: case Bcall+3: - case Bcall+4: case Bcall+5: - op -= Bcall; - docall: - DISCARD (op); + n = (opcode < Bcall+6 ? opcode - Bcall : + opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2); + DISCARD (n); #ifdef BYTE_CODE_METER if (byte_metering_on && SYMBOLP (TOP)) { - v1 = TOP; - v2 = Fget (v1, Qbyte_code_meter, Qnil); - if (INTP (v2) - && XINT (v2) != ((1< 0 ? Qt : Qnil; + break; + } case Blss: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_less); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; + break; + } case Bleq: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_less_or_equal); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; + break; + } case Bgeq: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_grtr_or_equal); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; + break; + } - case Bdiff: - DISCARD (1); - TOP = Fminus (2, &TOP); - break; case Bnegate: - v1 = TOP; - if (INTP (v1)) - { - XSETINT (v1, - XINT (v1)); - TOP = v1; - } - else - TOP = Fminus (1, &TOP); + TOP = bytecode_negate (TOP); break; - case Bplus: + case Bnconc: DISCARD (1); - TOP = Fplus (2, &TOP); + TOP = bytecode_nconc2 (&TOP); break; - case Bmax: - DISCARD (1); - TOP = Fmax (2, &TOP); - break; + case Bplus: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = TOP; + TOP = INTP (arg1) && INTP (arg2) ? + make_int (XINT (arg1) + XINT (arg2)) : + bytecode_arithop (arg1, arg2, opcode); + break; + } - case Bmin: - DISCARD (1); - TOP = Fmin (2, &TOP); - break; + case Bdiff: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = TOP; + TOP = INTP (arg1) && INTP (arg2) ? + make_int (XINT (arg1) - XINT (arg2)) : + bytecode_arithop (arg1, arg2, opcode); + break; + } case Bmult: - DISCARD (1); - TOP = Ftimes (2, &TOP); - break; - case Bquo: - DISCARD (1); - TOP = Fquo (2, &TOP); + case Bmax: + case Bmin: + { + Lisp_Object arg = POP; + TOP = bytecode_arithop (TOP, arg, opcode); + break; + } + + case Bpoint: + PUSH (make_int (BUF_PT (current_buffer))); break; - case Brem: - v1 = POP; - TOP = Frem (TOP, v1); + case Binsert: + TOP = Finsert (1, &TOP); break; - case Bpoint: - v1 = make_int (BUF_PT (current_buffer)); - PUSH (v1); + case BinsertN: + n = READ_UINT_1; + DISCARD (n - 1); + TOP = Finsert (n, &TOP); break; + case Baref: + { + Lisp_Object arg = POP; + TOP = Faref (TOP, arg); + break; + } + + case Bmemq: + { + Lisp_Object arg = POP; + TOP = Fmemq (TOP, arg); + break; + } + + + case Bset: + { + Lisp_Object arg = POP; + TOP = Fset (TOP, arg); + break; + } + + case Bequal: + { + Lisp_Object arg = POP; + TOP = Fequal (TOP, arg); + break; + } + + case Bnthcdr: + { + Lisp_Object arg = POP; + TOP = Fnthcdr (TOP, arg); + break; + } + + case Belt: + { + Lisp_Object arg = POP; + TOP = Felt (TOP, arg); + break; + } + + case Bmember: + { + Lisp_Object arg = POP; + TOP = Fmember (TOP, arg); + break; + } + case Bgoto_char: TOP = Fgoto_char (TOP, Qnil); break; - case Binsert: - TOP = Finsert (1, &TOP); - break; + case Bcurrent_buffer: + { + Lisp_Object buffer; + XSETBUFFER (buffer, current_buffer); + PUSH (buffer); + break; + } - case BinsertN: - op = FETCH; - DISCARD (op - 1); - TOP = Finsert (op, &TOP); + case Bset_buffer: + TOP = Fset_buffer (TOP); break; case Bpoint_max: - v1 = make_int (BUF_ZV (current_buffer)); - PUSH (v1); + PUSH (make_int (BUF_ZV (current_buffer))); break; case Bpoint_min: - v1 = make_int (BUF_BEGV (current_buffer)); - PUSH (v1); + PUSH (make_int (BUF_BEGV (current_buffer))); break; - case Bchar_after: - TOP = Fchar_after (TOP, Qnil); - break; + case Bskip_chars_forward: + { + Lisp_Object arg = POP; + TOP = Fskip_chars_forward (TOP, arg, Qnil); + break; + } - case Bfollowing_char: - v1 = Ffollowing_char (Qnil); - PUSH (v1); - break; + case Bassq: + { + Lisp_Object arg = POP; + TOP = Fassq (TOP, arg); + break; + } - case Bpreceding_char: - v1 = Fpreceding_char (Qnil); - PUSH (v1); - break; + case Bsetcar: + { + Lisp_Object arg = POP; + TOP = Fsetcar (TOP, arg); + break; + } - case Bcurrent_column: - v1 = make_int (current_column (current_buffer)); - PUSH (v1); - break; + case Bsetcdr: + { + Lisp_Object arg = POP; + TOP = Fsetcdr (TOP, arg); + break; + } - case Bindent_to: - TOP = Findent_to (TOP, Qnil, Qnil); + case Bnreverse: + TOP = bytecode_nreverse (TOP); break; - case Beolp: - PUSH (Feolp (Qnil)); + case Bcar_safe: + TOP = CONSP (TOP) ? XCAR (TOP) : Qnil; break; - case Beobp: - PUSH (Feobp (Qnil)); + case Bcdr_safe: + TOP = CONSP (TOP) ? XCDR (TOP) : Qnil; break; - case Bbolp: - PUSH (Fbolp (Qnil)); - break; + } + } +} - case Bbobp: - PUSH (Fbobp (Qnil)); - break; +/* It makes a worthwhile performance difference (5%) to shunt + lesser-used opcodes off to a subroutine, to keep the switch in + execute_optimized_program small. If you REALLY care about + performance, you want to keep your heavily executed code away from + rarely executed code, to minimize cache misses. + + Don't make this function static, since then the compiler might inline it. */ +Lisp_Object * +execute_rare_opcode (Lisp_Object *stack_ptr, + CONST Opbyte *program_ptr, + Opcode opcode) +{ + switch (opcode) + { - case Bcurrent_buffer: - PUSH (Fcurrent_buffer ()); - break; + case Bsave_excursion: + record_unwind_protect (save_excursion_restore, + save_excursion_save ()); + break; + + case Bsave_window_excursion: + { + int count = specpdl_depth (); + record_unwind_protect (save_window_excursion_unwind, + Fcurrent_window_configuration (Qnil)); + TOP = Fprogn (TOP); + unbind_to (count, Qnil); + break; + } - case Bset_buffer: - TOP = Fset_buffer (TOP); - break; + case Bsave_restriction: + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + break; - case Bsave_current_buffer: - record_unwind_protect (save_current_buffer_restore, - Fcurrent_buffer ()); - break; + case Bcatch: + { + Lisp_Object arg = POP; + TOP = internal_catch (TOP, Feval, arg, 0); + break; + } - case Binteractive_p: - PUSH (Finteractive_p ()); - break; + case Bskip_chars_backward: + { + Lisp_Object arg = POP; + TOP = Fskip_chars_backward (TOP, arg, Qnil); + break; + } - case Bforward_char: - TOP = Fforward_char (TOP, Qnil); - break; + case Bunwind_protect: + record_unwind_protect (Fprogn, POP); + break; - case Bforward_word: - TOP = Fforward_word (TOP, Qnil); - break; + case Bcondition_case: + { + Lisp_Object arg2 = POP; /* handlers */ + Lisp_Object arg1 = POP; /* bodyform */ + TOP = condition_case_3 (arg1, TOP, arg2); + break; + } - case Bskip_chars_forward: - v1 = POP; - TOP = Fskip_chars_forward (TOP, v1, Qnil); - break; + case Bset_marker: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = POP; + TOP = Fset_marker (TOP, arg1, arg2); + break; + } - case Bskip_chars_backward: - v1 = POP; - TOP = Fskip_chars_backward (TOP, v1, Qnil); - break; + case Brem: + { + Lisp_Object arg = POP; + TOP = Frem (TOP, arg); + break; + } - case Bforward_line: - TOP = Fforward_line (TOP, Qnil); - break; + case Bmatch_beginning: + TOP = Fmatch_beginning (TOP); + break; - case Bchar_syntax: -#if 0 - CHECK_CHAR_COERCE_INT (TOP); - TOP = make_char (syntax_code_spec - [(int) SYNTAX - (XCHAR_TABLE - (current_buffer->mirror_syntax_table), - XCHAR (TOP))]); -#endif - /*v1 = POP;*/ - TOP = Fchar_syntax(TOP, Qnil); - break; + case Bmatch_end: + TOP = Fmatch_end (TOP); + break; - case Bbuffer_substring: - v1 = POP; - TOP = Fbuffer_substring (TOP, v1, Qnil); - break; + case Bupcase: + TOP = Fupcase (TOP, Qnil); + break; - case Bdelete_region: - v1 = POP; - TOP = Fdelete_region (TOP, v1, Qnil); - break; + case Bdowncase: + TOP = Fdowncase (TOP, Qnil); + break; - case Bnarrow_to_region: - v1 = POP; - TOP = Fnarrow_to_region (TOP, v1, Qnil); - break; + case Bfset: + { + Lisp_Object arg = POP; + TOP = Ffset (TOP, arg); + break; + } - case Bwiden: - PUSH (Fwiden (Qnil)); - break; + case Bstring_equal: + { + Lisp_Object arg = POP; + TOP = Fstring_equal (TOP, arg); + break; + } - case Bend_of_line: - TOP = Fend_of_line (TOP, Qnil); - break; + case Bstring_lessp: + { + Lisp_Object arg = POP; + TOP = Fstring_lessp (TOP, arg); + break; + } - case Bset_marker: - v1 = POP; - v2 = POP; - TOP = Fset_marker (TOP, v2, v1); - break; + case Bsubstring: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = POP; + TOP = Fsubstring (TOP, arg1, arg2); + break; + } - case Bmatch_beginning: - TOP = Fmatch_beginning (TOP); - break; + case Bcurrent_column: + PUSH (make_int (current_column (current_buffer))); + break; - case Bmatch_end: - TOP = Fmatch_end (TOP); - break; + case Bchar_after: + TOP = Fchar_after (TOP, Qnil); + break; - case Bupcase: - TOP = Fupcase (TOP, Qnil); - break; + case Bindent_to: + TOP = Findent_to (TOP, Qnil, Qnil); + break; + + case Bwiden: + PUSH (Fwiden (Qnil)); + break; + + case Bfollowing_char: + PUSH (Ffollowing_char (Qnil)); + break; + + case Bpreceding_char: + PUSH (Fpreceding_char (Qnil)); + break; + + case Beolp: + PUSH (Feolp (Qnil)); + break; + + case Beobp: + PUSH (Feobp (Qnil)); + break; + + case Bbolp: + PUSH (Fbolp (Qnil)); + break; + + case Bbobp: + PUSH (Fbobp (Qnil)); + break; + + case Bsave_current_buffer: + record_unwind_protect (save_current_buffer_restore, + Fcurrent_buffer ()); + break; - case Bdowncase: - TOP = Fdowncase (TOP, Qnil); + case Binteractive_p: + PUSH (Finteractive_p ()); + break; + + case Bforward_char: + TOP = Fforward_char (TOP, Qnil); + break; + + case Bforward_word: + TOP = Fforward_word (TOP, Qnil); + break; + + case Bforward_line: + TOP = Fforward_line (TOP, Qnil); + break; + + case Bchar_syntax: + TOP = Fchar_syntax (TOP, Qnil); + break; + + case Bbuffer_substring: + { + Lisp_Object arg = POP; + TOP = Fbuffer_substring (TOP, arg, Qnil); break; + } - case Bstringeqlsign: - v1 = POP; - TOP = Fstring_equal (TOP, v1); + case Bdelete_region: + { + Lisp_Object arg = POP; + TOP = Fdelete_region (TOP, arg, Qnil); + break; + } + + case Bnarrow_to_region: + { + Lisp_Object arg = POP; + TOP = Fnarrow_to_region (TOP, arg, Qnil); + break; + } + + case Bend_of_line: + TOP = Fend_of_line (TOP, Qnil); + break; + + case Btemp_output_buffer_setup: + temp_output_buffer_setup (TOP); + TOP = Vstandard_output; + break; + + case Btemp_output_buffer_show: + { + Lisp_Object arg = POP; + temp_output_buffer_show (TOP, Qnil); + TOP = arg; + /* GAG ME!! */ + /* pop binding of standard-output */ + unbind_to (specpdl_depth() - 1, Qnil); + break; + } + + case Bold_eq: + { + Lisp_Object arg = POP; + TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; + break; + } + + case Bold_memq: + { + Lisp_Object arg = POP; + TOP = Fold_memq (TOP, arg); + break; + } + + case Bold_equal: + { + Lisp_Object arg = POP; + TOP = Fold_equal (TOP, arg); + break; + } + + case Bold_member: + { + Lisp_Object arg = POP; + TOP = Fold_member (TOP, arg); + break; + } + + case Bold_assq: + { + Lisp_Object arg = POP; + TOP = Fold_assq (TOP, arg); + break; + } + + default: + abort(); + break; + } + return stack_ptr; +} + + +static void +invalid_byte_code_error (char *error_message, ...) +{ + Lisp_Object obj; + va_list args; + char *buf = alloca_array (char, strlen (error_message) + 128); + + sprintf (buf, "%s", error_message); + va_start (args, error_message); + obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1, + args); + va_end (args); + + signal_error (Qinvalid_byte_code, list1 (obj)); +} + +/* Check for valid opcodes. Change this when adding new opcodes. */ +static void +check_opcode (Opcode opcode) +{ + if ((opcode < Bvarref) || + (opcode == 0251) || + (opcode > Bassq && opcode < Bconstant)) + invalid_byte_code_error + ("invalid opcode %d in instruction stream", opcode); +} + +/* Check that IDX is a valid offset into the `constants' vector */ +static void +check_constants_index (int idx, Lisp_Object constants) +{ + if (idx < 0 || idx >= XVECTOR_LENGTH (constants)) + invalid_byte_code_error + ("reference %d to constants array out of range 0, %d", + idx, XVECTOR_LENGTH (constants) - 1); +} + +/* Get next character from Lisp instructions string. */ +#define READ_INSTRUCTION_CHAR(lvalue) do { \ + (lvalue) = charptr_emchar (ptr); \ + INC_CHARPTR (ptr); \ + *icounts_ptr++ = program_ptr - program; \ + if (lvalue > UCHAR_MAX) \ + invalid_byte_code_error \ + ("Invalid character %c in byte code string"); \ +} while (0) + +/* Get opcode from Lisp instructions string. */ +#define READ_OPCODE do { \ + unsigned int c; \ + READ_INSTRUCTION_CHAR (c); \ + opcode = (Opcode) c; \ +} while (0) + +/* Get next operand, a uint8, from Lisp instructions string. */ +#define READ_OPERAND_1 do { \ + READ_INSTRUCTION_CHAR (arg); \ + argsize = 1; \ +} while (0) + +/* Get next operand, a uint16, from Lisp instructions string. */ +#define READ_OPERAND_2 do { \ + unsigned int arg1, arg2; \ + READ_INSTRUCTION_CHAR (arg1); \ + READ_INSTRUCTION_CHAR (arg2); \ + arg = arg1 + (arg2 << 8); \ + argsize = 2; \ +} while (0) + +/* Write 1 byte to PTR, incrementing PTR */ +#define WRITE_INT8(value, ptr) do { \ + *((ptr)++) = (value); \ +} while (0) + +/* Write 2 bytes to PTR, incrementing PTR */ +#define WRITE_INT16(value, ptr) do { \ + WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \ + WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \ +} while (0) + +/* We've changed our minds about the opcode we've already written. */ +#define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode)) + +/* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */ +#define WRITE_NARGS(base_opcode) do { \ + if (arg <= 5) \ + { \ + REWRITE_OPCODE (base_opcode + arg); \ + } \ + else if (arg <= UCHAR_MAX) \ + { \ + REWRITE_OPCODE (base_opcode + 6); \ + WRITE_INT8 (arg, program_ptr); \ + } \ + else \ + { \ + REWRITE_OPCODE (base_opcode + 7); \ + WRITE_INT16 (arg, program_ptr); \ + } \ +} while (0) + +/* Encode a constants reference within the opcode, or as a 2-byte operand. */ +#define WRITE_CONSTANT do { \ + check_constants_index(arg, constants); \ + if (arg <= UCHAR_MAX - Bconstant) \ + { \ + REWRITE_OPCODE (Bconstant + arg); \ + } \ + else \ + { \ + REWRITE_OPCODE (Bconstant2); \ + WRITE_INT16 (arg, program_ptr); \ + } \ +} while (0) + +#define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr) + +/* Compile byte code instructions into free space provided by caller, with + size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte). + Returns length of compiled code. */ +static void +optimize_byte_code (/* in */ + Lisp_Object instructions, + Lisp_Object constants, + /* out */ + Opbyte * CONST program, + int * CONST program_length, + int * CONST varbind_count) +{ + size_t instructions_length = XSTRING_LENGTH (instructions); + size_t comfy_size = 2 * instructions_length; + + int * CONST icounts = alloca_array (int, comfy_size); + int * icounts_ptr = icounts; + + /* We maintain a table of jumps in the source code. */ + struct jump + { + int from; + int to; + }; + struct jump * CONST jumps = alloca_array (struct jump, comfy_size); + struct jump *jumps_ptr = jumps; + + Opbyte *program_ptr = program; + + CONST Bufbyte *ptr = XSTRING_DATA (instructions); + CONST Bufbyte * CONST end = ptr + instructions_length; + + *varbind_count = 0; + + while (ptr < end) + { + Opcode opcode; + int arg; + int argsize = 0; + READ_OPCODE; + WRITE_OPCODE; + + switch (opcode) + { + Lisp_Object val; + + case Bvarref+7: READ_OPERAND_2; goto do_varref; + case Bvarref+6: READ_OPERAND_1; goto do_varref; + case Bvarref: case Bvarref+1: case Bvarref+2: + case Bvarref+3: case Bvarref+4: case Bvarref+5: + arg = opcode - Bvarref; + do_varref: + check_constants_index (arg, constants); + val = XVECTOR_DATA (constants) [arg]; + if (!SYMBOLP (val)) + invalid_byte_code_error ("variable reference to non-symbol %S", val); + if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) + invalid_byte_code_error ("variable reference to constant symbol %s", + string_data (XSYMBOL (val)->name)); + WRITE_NARGS (Bvarref); + break; + + case Bvarset+7: READ_OPERAND_2; goto do_varset; + case Bvarset+6: READ_OPERAND_1; goto do_varset; + case Bvarset: case Bvarset+1: case Bvarset+2: + case Bvarset+3: case Bvarset+4: case Bvarset+5: + arg = opcode - Bvarset; + do_varset: + check_constants_index (arg, constants); + val = XVECTOR_DATA (constants) [arg]; + if (!SYMBOLP (val)) + invalid_byte_code_error ("attempt to set non-symbol %S", val); + if (EQ (val, Qnil) || EQ (val, Qt)) + invalid_byte_code_error ("attempt to set constant symbol %s", + string_data (XSYMBOL (val)->name)); + /* Ignore assignments to keywords by converting to Bdiscard. + For backward compatibility only - we'd like to make this an error. */ + if (SYMBOL_IS_KEYWORD (val)) + REWRITE_OPCODE (Bdiscard); + else + WRITE_NARGS (Bvarset); + break; + + case Bvarbind+7: READ_OPERAND_2; goto do_varbind; + case Bvarbind+6: READ_OPERAND_1; goto do_varbind; + case Bvarbind: case Bvarbind+1: case Bvarbind+2: + case Bvarbind+3: case Bvarbind+4: case Bvarbind+5: + arg = opcode - Bvarbind; + do_varbind: + (*varbind_count)++; + check_constants_index (arg, constants); + val = XVECTOR_DATA (constants) [arg]; + if (!SYMBOLP (val)) + invalid_byte_code_error ("attempt to let-bind non-symbol %S", val); + if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) + invalid_byte_code_error ("attempt to let-bind constant symbol %s", + string_data (XSYMBOL (val)->name)); + WRITE_NARGS (Bvarbind); + break; + + case Bcall+7: READ_OPERAND_2; goto do_call; + case Bcall+6: READ_OPERAND_1; goto do_call; + case Bcall: case Bcall+1: case Bcall+2: + case Bcall+3: case Bcall+4: case Bcall+5: + arg = opcode - Bcall; + do_call: + WRITE_NARGS (Bcall); + break; + + case Bunbind+7: READ_OPERAND_2; goto do_unbind; + case Bunbind+6: READ_OPERAND_1; goto do_unbind; + case Bunbind: case Bunbind+1: case Bunbind+2: + case Bunbind+3: case Bunbind+4: case Bunbind+5: + arg = opcode - Bunbind; + do_unbind: + WRITE_NARGS (Bunbind); break; - case Bstringlss: - v1 = POP; - TOP = Fstring_lessp (TOP, v1); + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + READ_OPERAND_2; + /* Make program_ptr-relative */ + arg += icounts - (icounts_ptr - argsize); + goto do_jump; + + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + READ_OPERAND_1; + /* Make program_ptr-relative */ + arg -= 127; + do_jump: + /* Record program-relative goto addresses in `jumps' table */ + jumps_ptr->from = icounts_ptr - icounts - argsize; + jumps_ptr->to = jumps_ptr->from + arg; + jumps_ptr++; + if (arg >= -1 && arg <= argsize) + invalid_byte_code_error + ("goto instruction is its own target"); + if (arg <= SCHAR_MIN || + arg > SCHAR_MAX) + { + if (argsize == 1) + REWRITE_OPCODE (opcode + Bgoto - BRgoto); + WRITE_INT16 (arg, program_ptr); + } + else + { + if (argsize == 2) + REWRITE_OPCODE (opcode + BRgoto - Bgoto); + WRITE_INT8 (arg, program_ptr); + } break; - case Bequal: - v1 = POP; - TOP = Fequal (TOP, v1); + case Bconstant2: + READ_OPERAND_2; + WRITE_CONSTANT; break; - case Bold_equal: - v1 = POP; - TOP = Fold_equal (TOP, v1); + case BlistN: + case BconcatN: + case BinsertN: + READ_OPERAND_1; + WRITE_INT8 (arg, program_ptr); break; - case Bnthcdr: - v1 = POP; - v2 = TOP; - CHECK_NATNUM (v2); - for (op = XINT (v2); op; op--) + default: + if (opcode < Bconstant) + check_opcode (opcode); + else { - if (CONSP (v1)) - v1 = XCDR (v1); - else if (NILP (v1)) - break; - else - { - v1 = wrong_type_argument (Qlistp, v1); - op++; - } + arg = opcode - Bconstant; + WRITE_CONSTANT; } - TOP = v1; break; + } + } - case Belt: -#if 0 - /* probably this code is OK, but nth_entry is commented - out above --ben */ - /* #### will not work if cons type is an lrecord. */ - if (XTYPE (TOP) == Lisp_Type_Cons) + /* Fix up jumps table to refer to NEW offsets. */ + { + struct jump *j; + for (j = jumps; j < jumps_ptr; j++) + { +#ifdef ERROR_CHECK_BYTE_CODE + assert (j->from < icounts_ptr - icounts); + assert (j->to < icounts_ptr - icounts); +#endif + j->from = icounts[j->from]; + j->to = icounts[j->to]; +#ifdef ERROR_CHECK_BYTE_CODE + assert (j->from < program_ptr - program); + assert (j->to < program_ptr - program); + check_opcode ((Opcode) (program[j->from-1])); +#endif + check_opcode ((Opcode) (program[j->to])); + } + } + + /* Fixup jumps in byte-code until no more fixups needed */ + { + int more_fixups_needed = 1; + + while (more_fixups_needed) + { + struct jump *j; + more_fixups_needed = 0; + for (j = jumps; j < jumps_ptr; j++) + { + int from = j->from; + int to = j->to; + int jump = to - from; + Opbyte *p = program + from; + Opcode opcode = (Opcode) p[-1]; + if (!more_fixups_needed) + check_opcode ((Opcode) p[jump]); + assert (to >= 0 && program + to < program_ptr); + switch (opcode) { - /* Exchange args and then do nth. */ - v2 = POP; - v1 = TOP; - goto nth_entry; + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + WRITE_INT16 (jump, p); + break; + + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + if (jump > SCHAR_MIN && + jump <= SCHAR_MAX) + { + WRITE_INT8 (jump, p); + } + else /* barf */ + { + struct jump *jj; + for (jj = jumps; jj < jumps_ptr; jj++) + { + assert (jj->from < program_ptr - program); + assert (jj->to < program_ptr - program); + if (jj->from > from) jj->from++; + if (jj->to > from) jj->to++; + } + p[-1] += Bgoto - BRgoto; + more_fixups_needed = 1; + memmove (p+1, p, program_ptr++ - p); + WRITE_INT16 (jump, p); + } + break; + + default: + abort(); + break; } + } + } + } + + /* *program_ptr++ = 0; */ + *program_length = program_ptr - program; +} + +/* Optimize the byte code and store the optimized program, only + understood by bytecode.c, in an opaque object in the + instructions slot of the Compiled_Function object. */ +void +optimize_compiled_function (Lisp_Object compiled_function) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); + int program_length; + int varbind_count; + Opbyte *program; + + /* If we have not actually read the bytecode string + and constants vector yet, fetch them from the file. */ + if (CONSP (f->instructions)) + Ffetch_bytecode (compiled_function); + + if (STRINGP (f->instructions)) + { + /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(), + which would be slightly more `proper' */ + program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); + optimize_byte_code (f->instructions, f->constants, + program, &program_length, &varbind_count); + f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count; + f->instructions = + Fpurecopy (make_opaque (program_length * sizeof (Opbyte), + (CONST void *) program)); + } + + assert (OPAQUEP (f->instructions)); +} + +/************************************************************************/ +/* The compiled-function object type */ +/************************************************************************/ +static void +print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, + int escapeflag) +{ + /* This function can GC */ + Lisp_Compiled_Function *f = + XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ + int docp = f->flags.documentationp; + int intp = f->flags.interactivep; + struct gcpro gcpro1, gcpro2; + char buf[100]; + GCPRO2 (obj, printcharfun); + + write_c_string (print_readably ? "#[" : "#", printcharfun); +} + + +static Lisp_Object +mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); + + markobj (f->instructions); + markobj (f->arglist); + markobj (f->doc_and_interactive); +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + markobj (f->annotated); #endif - v1 = POP; - TOP = Felt (TOP, v1); - break; + /* tail-recurse on constants */ + return f->constants; +} - case Bmember: - v1 = POP; - TOP = Fmember (TOP, v1); - break; +static int +compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1); + Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2); + return + (f1->flags.documentationp == f2->flags.documentationp && + f1->flags.interactivep == f2->flags.interactivep && + f1->flags.domainp == f2->flags.domainp && /* I18N3 */ + internal_equal (compiled_function_instructions (f1), + compiled_function_instructions (f2), depth + 1) && + internal_equal (f1->constants, f2->constants, depth + 1) && + internal_equal (f1->arglist, f2->arglist, depth + 1) && + internal_equal (f1->doc_and_interactive, + f2->doc_and_interactive, depth + 1)); +} - case Bold_member: - v1 = POP; - TOP = Fold_member (TOP, v1); - break; +static unsigned long +compiled_function_hash (Lisp_Object obj, int depth) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); + return HASH3 ((f->flags.documentationp << 2) + + (f->flags.interactivep << 1) + + f->flags.domainp, + internal_hash (f->instructions, depth + 1), + internal_hash (f->constants, depth + 1)); +} - case Bassq: - v1 = POP; - TOP = Fassq (TOP, v1); - break; +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, + mark_compiled_function, + print_compiled_function, 0, + compiled_function_equal, + compiled_function_hash, + Lisp_Compiled_Function); + +DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* +Return t if OBJECT is a byte-compiled function object. +*/ + (object)) +{ + return COMPILED_FUNCTIONP (object) ? Qt : Qnil; +} - case Bold_assq: - v1 = POP; - TOP = Fold_assq (TOP, v1); - break; +/************************************************************************/ +/* compiled-function object accessor functions */ +/************************************************************************/ - case Bnreverse: - TOP = Fnreverse (TOP); - break; +Lisp_Object +compiled_function_arglist (Lisp_Compiled_Function *f) +{ + return f->arglist; +} - case Bsetcar: - v1 = POP; - TOP = Fsetcar (TOP, v1); - break; +Lisp_Object +compiled_function_instructions (Lisp_Compiled_Function *f) +{ + if (! OPAQUEP (f->instructions)) + return f->instructions; - case Bsetcdr: - v1 = POP; - TOP = Fsetcdr (TOP, v1); - break; + { + /* Invert action performed by optimize_byte_code() */ + Lisp_Opaque *opaque = XOPAQUE (f->instructions); + + Bufbyte * CONST buffer = + alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN); + Bufbyte *bp = buffer; + + CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque); + CONST Opbyte *program_ptr = program; + CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque); + + while (program_ptr < program_end) + { + Opcode opcode = (Opcode) READ_UINT_1; + bp += set_charptr_emchar (bp, opcode); + switch (opcode) + { + case Bvarref+7: + case Bvarset+7: + case Bvarbind+7: + case Bcall+7: + case Bunbind+7: + case Bconstant2: + bp += set_charptr_emchar (bp, READ_UINT_1); + bp += set_charptr_emchar (bp, READ_UINT_1); + break; + + case Bvarref+6: + case Bvarset+6: + case Bvarbind+6: + case Bcall+6: + case Bunbind+6: + case BlistN: + case BconcatN: + case BinsertN: + bp += set_charptr_emchar (bp, READ_UINT_1); + break; + + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + { + int jump = READ_INT_2; + Opbyte buf2[2]; + Opbyte *buf2p = buf2; + /* Convert back to program-relative address */ + WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p); + bp += set_charptr_emchar (bp, buf2[0]); + bp += set_charptr_emchar (bp, buf2[1]); + break; + } - case Bcar_safe: - v1 = TOP; - if (CONSP (v1)) - TOP = XCAR (v1); - else - TOP = Qnil; - break; + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + bp += set_charptr_emchar (bp, READ_INT_1 + 127); + break; + + default: + break; + } + } + return make_string (buffer, bp - buffer); + } +} - case Bcdr_safe: - v1 = TOP; - if (CONSP (v1)) - TOP = XCDR (v1); - else - TOP = Qnil; - break; +Lisp_Object +compiled_function_constants (Lisp_Compiled_Function *f) +{ + return f->constants; +} - case Bnconc: - DISCARD (1); - TOP = Fnconc (2, &TOP); - break; +int +compiled_function_stack_depth (Lisp_Compiled_Function *f) +{ + return f->stack_depth; +} - case Bnumberp: - TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; - break; +/* The compiled_function->doc_and_interactive slot uses the minimal + number of conses, based on compiled_function->flags; it may take + any of the following forms: + + doc + interactive + domain + (doc . interactive) + (doc . domain) + (interactive . domain) + (doc . (interactive . domain)) + */ - case Bintegerp: - TOP = INTP (TOP) ? Qt : Qnil; - break; +/* Caller must check flags.interactivep first */ +Lisp_Object +compiled_function_interactive (Lisp_Compiled_Function *f) +{ + assert (f->flags.interactivep); + if (f->flags.documentationp && f->flags.domainp) + return XCAR (XCDR (f->doc_and_interactive)); + else if (f->flags.documentationp) + return XCDR (f->doc_and_interactive); + else if (f->flags.domainp) + return XCAR (f->doc_and_interactive); + else + return f->doc_and_interactive; +} + +/* Caller need not check flags.documentationp first */ +Lisp_Object +compiled_function_documentation (Lisp_Compiled_Function *f) +{ + if (! f->flags.documentationp) + return Qnil; + else if (f->flags.interactivep && f->flags.domainp) + return XCAR (f->doc_and_interactive); + else if (f->flags.interactivep) + return XCAR (f->doc_and_interactive); + else if (f->flags.domainp) + return XCAR (f->doc_and_interactive); + else + return f->doc_and_interactive; +} + +/* Caller need not check flags.domainp first */ +Lisp_Object +compiled_function_domain (Lisp_Compiled_Function *f) +{ + if (! f->flags.domainp) + return Qnil; + else if (f->flags.documentationp && f->flags.interactivep) + return XCDR (XCDR (f->doc_and_interactive)); + else if (f->flags.documentationp) + return XCDR (f->doc_and_interactive); + else if (f->flags.interactivep) + return XCDR (f->doc_and_interactive); + else + return f->doc_and_interactive; +} + +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + +Lisp_Object +compiled_function_annotation (Lisp_Compiled_Function *f) +{ + return f->annotated; +} - default: -#ifdef BYTE_CODE_SAFE - if (op < Bconstant) - error ("unknown bytecode %d (byte compiler bug)", op); - if ((op -= Bconstant) >= const_length) - error ("no constant number %d (byte compiler bug)", op); - PUSH (vectorp[op]); -#else - PUSH (vectorp[op - Bconstant]); #endif - } + +/* used only by Snarf-documentation; there must be doc already. */ +void +set_compiled_function_documentation (Lisp_Compiled_Function *f, + Lisp_Object new_doc) +{ + assert (f->flags.documentationp); + assert (INTP (new_doc) || STRINGP (new_doc)); + + if (f->flags.interactivep && f->flags.domainp) + XCAR (f->doc_and_interactive) = new_doc; + else if (f->flags.interactivep) + XCAR (f->doc_and_interactive) = new_doc; + else if (f->flags.domainp) + XCAR (f->doc_and_interactive) = new_doc; + else + f->doc_and_interactive = new_doc; +} + + +DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* +Return the argument list of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_arglist (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* +Return the byte-opcode string of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_instructions (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* +Return the constants vector of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_constants (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* +Return the max stack depth of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function))); +} + +DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* +Return the doc string of the compiled-function object FUNCTION, if available. +Functions that had their doc strings snarfed into the DOC file will have +an integer returned instead of a string. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_documentation (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* +Return the interactive spec of the compiled-function object FUNCTION, or nil. +If non-nil, the return value will be a list whose first element is +`interactive' and whose second element is the interactive spec. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return XCOMPILED_FUNCTION (function)->flags.interactivep + ? list2 (Qinteractive, + compiled_function_interactive (XCOMPILED_FUNCTION (function))) + : Qnil; +} + +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + +/* Remove the `xx' if you wish to restore this feature */ +xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* +Return the annotation of the compiled-function object FUNCTION, or nil. +The annotation is a piece of information indicating where this +compiled-function object came from. Generally this will be +a symbol naming a function; or a string naming a file, if the +compiled-function object was not defined in a function; or nil, +if the compiled-function object was not created as a result of +a `load'. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_annotation (XCOMPILED_FUNCTION (function)); +} + +#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ + +DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* +Return the domain of the compiled-function object FUNCTION, or nil. +This is only meaningful if I18N3 was enabled when emacs was compiled. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return XCOMPILED_FUNCTION (function)->flags.domainp + ? compiled_function_domain (XCOMPILED_FUNCTION (function)) + : Qnil; +} + + + +DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* +If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now. +*/ + (function)) +{ + Lisp_Compiled_Function *f; + CHECK_COMPILED_FUNCTION (function); + f = XCOMPILED_FUNCTION (function); + + if (OPAQUEP (f->instructions) || STRINGP (f->instructions)) + return function; + + if (CONSP (f->instructions)) + { + Lisp_Object tem = read_doc_string (f->instructions); + if (!CONSP (tem)) + signal_simple_error ("Invalid lazy-loaded byte code", tem); + /* v18 or v19 bytecode file. Need to Ebolify. */ + if (f->flags.ebolified && VECTORP (XCDR (tem))) + ebolify_bytecode_constants (XCDR (tem)); + /* VERY IMPORTANT to purecopy here!!!!! + See load_force_doc_string_unwind. */ + f->instructions = Fpurecopy (XCAR (tem)); + f->constants = Fpurecopy (XCDR (tem)); + return function; } + abort (); + return Qnil; /* not reached */ +} - exit: - UNGCPRO; - /* Binds and unbinds are supposed to be compiled balanced. */ - if (specpdl_depth() != speccount) - /* FSF: abort() if BYTE_CODE_SAFE not defined */ - error ("binding stack not balanced (serious byte compiler bug)"); - return v1; +DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /* +Convert compiled function FUNCTION into an optimized internal form. +*/ + (function)) +{ + Lisp_Compiled_Function *f; + CHECK_COMPILED_FUNCTION (function); + f = XCOMPILED_FUNCTION (function); + + if (OPAQUEP (f->instructions)) /* Already optimized? */ + return Qnil; + + optimize_compiled_function (function); + return Qnil; +} + +DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* +Function used internally in byte-compiled code. +First argument INSTRUCTIONS is a string of byte code. +Second argument CONSTANTS is a vector of constants. +Third argument STACK-DEPTH is the maximum stack depth used in this function. +If STACK-DEPTH is incorrect, Emacs may crash. +*/ + (instructions, constants, stack_depth)) +{ + /* This function can GC */ + int varbind_count; + int program_length; + Opbyte *program; + + CHECK_STRING (instructions); + CHECK_VECTOR (constants); + CHECK_NATNUM (stack_depth); + + /* Optimize the `instructions' string, just like when executing a + regular compiled function, but don't save it for later since this is + likely to only be executed once. */ + program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); + optimize_byte_code (instructions, constants, program, + &program_length, &varbind_count); + SPECPDL_RESERVE (varbind_count); + return execute_optimized_program (program, + XINT (stack_depth), + XVECTOR_DATA (constants)); } + void syms_of_bytecode (void) { + deferror (&Qinvalid_byte_code, "invalid-byte-code", + "Invalid byte code", Qerror); defsymbol (&Qbyte_code, "byte-code"); + defsymbol (&Qcompiled_functionp, "compiled-function-p"); + DEFSUBR (Fbyte_code); + DEFSUBR (Ffetch_bytecode); + DEFSUBR (Foptimize_compiled_function); + + DEFSUBR (Fcompiled_function_p); + DEFSUBR (Fcompiled_function_instructions); + DEFSUBR (Fcompiled_function_constants); + DEFSUBR (Fcompiled_function_stack_depth); + DEFSUBR (Fcompiled_function_arglist); + DEFSUBR (Fcompiled_function_interactive); + DEFSUBR (Fcompiled_function_doc_string); + DEFSUBR (Fcompiled_function_domain); +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + DEFSUBR (Fcompiled_function_annotation); +#endif + #ifdef BYTE_CODE_METER defsymbol (&Qbyte_code_meter, "byte-code-meter"); #endif @@ -1197,7 +2434,7 @@ vars_of_bytecode (void) #ifdef BYTE_CODE_METER DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* -A vector of vectors which holds a histogram of byte-code usage. +A vector of vectors which holds a histogram of byte code usage. \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte opcode CODE has been executed. \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, @@ -1206,7 +2443,7 @@ executed in succession. */ ); DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /* If non-nil, keep profiling information on byte code usage. -The variable byte-code-meter indicates how often each byte opcode is used. +The variable `byte-code-meter' indicates how often each byte opcode is used. If a symbol has a property named `byte-code-meter' whose value is an integer, it is incremented each time that symbol's function is called. */ ); @@ -1216,8 +2453,7 @@ integer, it is incremented each time that symbol's function is called. { int i = 256; while (i--) - XVECTOR_DATA (Vbyte_code_meter)[i] = - make_vector (256, Qzero); + XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); } -#endif +#endif /* BYTE_CODE_METER */ }