From 36f7ba0a1e3ee4a5ae38e1bea50dbee5d953e992 Mon Sep 17 00:00:00 2001 From: Jim Blandy Date: Tue, 2 Jul 1991 22:37:47 +0000 Subject: [PATCH] Initial revision --- src/bytecode.c | 1051 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1051 insertions(+) create mode 100644 src/bytecode.c diff --git a/src/bytecode.c b/src/bytecode.c new file mode 100644 index 00000000000..f888a68b7f6 --- /dev/null +++ b/src/bytecode.c @@ -0,0 +1,1051 @@ +/* Execution of byte code produced by bytecomp.el. + Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 1, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +hacked on by jwz 17-jun-91 + o added a compile-time switch to turn on simple sanity checking; + o put back the obsolete byte-codes for error-detection; + o put back fset, symbol-function, and read-char because I don't + see any reason for them to have been removed; + o added a new instruction, unbind_all, which I will use for + tail-recursion elimination; + o made temp_output_buffer_show() be called with the right number + of args; + o made the new bytecodes be called with args in the right order; + o added metering support. + +by Hallvard: + o added relative jump instructions; + o all conditionals now only do QUIT if they jump. + */ + + +#include "config.h" +#include "lisp.h" +#include "buffer.h" +#include "syntax.h" + +/* Define this to enable some minor sanity checking + (useful for debugging the byte compiler...) + */ +#define BYTE_CODE_SAFE + +/* Define this to enable generation of a histogram of byte-op usage. + */ +#define BYTE_CODE_METER + + +#ifdef BYTE_CODE_METER + +Lisp_Object Vbyte_code_meter; +int byte_metering_on; + +# define METER_2(code1,code2) \ + XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \ + ->contents[(code2)]) + +# 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<contents; +#ifdef BYTE_CODE_SAFE + register int const_length = XVECTOR (vector)->size; +#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; + + CHECK_STRING (bytestr, 0); + if (XTYPE (vector) != Lisp_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; + + while (1) + { +#ifdef BYTE_CODE_SAFE + if (stackp > stacke) + error ( + "Stack overflow in byte code (byte compiler bug), pc = %d, depth = %d", + pc - XSTRING (string_saved)->data, stacke - stackp); + if (stackp < stack) + error ("Stack underflow in byte code (byte compiler bug), pc = %d", + pc - XSTRING (string_saved)->data); +#endif + + if (string_saved != bytestr) + { + pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data; + string_saved = bytestr; + } + +#ifdef BYTE_CODE_METER + prev_op = this_op; + this_op = op = FETCH; + METER_CODE (prev_op, op); + switch (op) +#else + switch (op = FETCH) +#endif + { + 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 (XTYPE (v1) != Lisp_Symbol) + v2 = Fsymbol_value (v1); + else + { + v2 = XSYMBOL (v1)->value; +#ifdef SWITCH_ENUM_BUG + switch ((int) XTYPE (v2)) +#else + switch (XTYPE (v2)) +#endif + { + case Lisp_Symbol: + if (!EQ (v2, Qunbound)) + break; + case Lisp_Intfwd: + case Lisp_Boolfwd: + case Lisp_Objfwd: + case Lisp_Buffer_Local_Value: + case Lisp_Some_Buffer_Local_Value: + case Lisp_Buffer_Objfwd: + case Lisp_Void: + v2 = Fsymbol_value (v1); + } + } + PUSH (v2); + 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); + 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: + op -= Bvarbind; + varbind: + specbind (vectorp[op], POP); + break; + + 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); + TOP = Ffuncall (op + 1, &TOP); + break; + + case Bunbind+6: + op = FETCH; + goto dounbind; + + case Bunbind+7: + op = FETCH2; + goto dounbind; + + case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3: + case Bunbind+4: case Bunbind+5: + op -= Bunbind; + dounbind: + unbind_to (specpdl_ptr - specpdl - op, Qnil); + break; + + case Bunbind_all: + /* To unbind back to the beginning of this frame. Not used yet, + but wil be needed for tail-recursion elimination. + */ + unbind_to (count, Qnil); + break; + + case Bgoto: + QUIT; + op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */ + pc = XSTRING (string_saved)->data + op; + break; + + case Bgotoifnil: + op = FETCH2; + if (NULL (POP)) + { + QUIT; + pc = XSTRING (string_saved)->data + op; + } + break; + + case Bgotoifnonnil: + op = FETCH2; + if (!NULL (POP)) + { + QUIT; + pc = XSTRING (string_saved)->data + op; + } + break; + + case Bgotoifnilelsepop: + op = FETCH2; + if (NULL (TOP)) + { + QUIT; + pc = XSTRING (string_saved)->data + op; + } + else DISCARD(1); + break; + + case Bgotoifnonnilelsepop: + op = FETCH2; + if (!NULL (TOP)) + { + QUIT; + pc = XSTRING (string_saved)->data + op; + } + else DISCARD(1); + break; + + case Breturn: + v1 = POP; + goto exit; + + case Bdiscard: + DISCARD(1); + break; + + case Bdup: + v1 = TOP; + PUSH (v1); + break; + + case Bconstant2: + PUSH (vectorp[FETCH2]); + break; + + case Bsave_excursion: + record_unwind_protect (save_excursion_restore, save_excursion_save ()); + break; + + case Bsave_window_excursion: + TOP = Fsave_window_excursion (TOP); + break; + + case Bsave_restriction: + record_unwind_protect (save_restriction_restore, save_restriction_save ()); + break; + + case Bcatch: + v1 = POP; + TOP = internal_catch (TOP, Feval, v1); + break; + + case Bunwind_protect: + record_unwind_protect (0, POP); + (specpdl_ptr - 1)->symbol = Qnil; + break; + + case Bcondition_case: + v1 = POP; + v1 = Fcons (POP, v1); + TOP = Fcondition_case (Fcons (TOP, v1)); + break; + + case Btemp_output_buffer_setup: + temp_output_buffer_setup (XSTRING (TOP)->data); + TOP = Vstandard_output; + break; + + case Btemp_output_buffer_show: + v1 = POP; + temp_output_buffer_show (TOP, Qnil); + TOP = v1; + /* pop binding of standard-output */ + unbind_to (specpdl_ptr - specpdl - 1, Qnil); + break; + + case Bnth: + v1 = POP; + v2 = TOP; + nth_entry: + CHECK_NUMBER (v2, 0); + op = XINT (v2); + immediate_quit = 1; + while (--op >= 0) + { + if (CONSP (v1)) + v1 = XCONS (v1)->cdr; + else if (!NULL (v1)) + { + immediate_quit = 0; + v1 = wrong_type_argument (Qlistp, v1); + immediate_quit = 1; + op++; + } + } + immediate_quit = 0; + goto docar; + + case Bsymbolp: + TOP = XTYPE (TOP) == Lisp_Symbol ? Qt : Qnil; + break; + + case Bconsp: + TOP = CONSP (TOP) ? Qt : Qnil; + break; + + case Bstringp: + TOP = XTYPE (TOP) == Lisp_String ? Qt : Qnil; + break; + + case Blistp: + TOP = CONSP (TOP) || NULL (TOP) ? Qt : Qnil; + break; + + case Beq: + v1 = POP; + TOP = EQ (v1, TOP) ? Qt : Qnil; + break; + + case Bmemq: + v1 = POP; + TOP = Fmemq (TOP, v1); + break; + + case Bnot: + TOP = NULL (TOP) ? Qt : Qnil; + break; + + case Bcar: + v1 = TOP; + docar: + if (CONSP (v1)) TOP = XCONS (v1)->car; + else if (NULL (v1)) TOP = Qnil; + else Fcar (wrong_type_argument (Qlistp, v1)); + break; + + case Bcdr: + v1 = TOP; + if (CONSP (v1)) TOP = XCONS (v1)->cdr; + else if (NULL (v1)) TOP = Qnil; + else Fcdr (wrong_type_argument (Qlistp, v1)); + break; + + case Bcons: + v1 = POP; + TOP = Fcons (TOP, v1); + break; + + case Blist1: + TOP = Fcons (TOP, Qnil); + break; + + case Blist2: + v1 = POP; + TOP = Fcons (TOP, Fcons (v1, Qnil)); + break; + + case Blist3: + DISCARD(2); + TOP = Flist (3, &TOP); + break; + + case Blist4: + DISCARD(3); + TOP = Flist (4, &TOP); + break; + + case Blength: + TOP = Flength (TOP); + break; + + case Baref: + v1 = POP; + TOP = Faref (TOP, v1); + break; + + case Baset: + v2 = POP; v1 = POP; + TOP = Faset (TOP, v1, v2); + break; + + case Bsymbol_value: + TOP = Fsymbol_value (TOP); + break; + + case Bsymbol_function: + TOP = Fsymbol_function (TOP); + break; + + case Bset: + v1 = POP; + TOP = Fset (TOP, v1); + break; + + case Bfset: + v1 = POP; + TOP = Ffset (TOP, v1); + break; + + case Bget: + v1 = POP; + TOP = Fget (TOP, v1); + break; + + case Bsubstring: + v2 = POP; v1 = POP; + TOP = Fsubstring (TOP, v1, v2); + break; + + case Bconcat2: + DISCARD(1); + TOP = Fconcat (2, &TOP); + break; + + case Bconcat3: + DISCARD(2); + TOP = Fconcat (3, &TOP); + break; + + case Bconcat4: + DISCARD(3); + TOP = Fconcat (4, &TOP); + break; + + case Bsub1: + v1 = TOP; + if (XTYPE (v1) == Lisp_Int) + { + XSETINT (v1, XINT (v1) - 1); + TOP = v1; + } + else + TOP = Fsub1 (v1); + break; + + case Badd1: + v1 = TOP; + if (XTYPE (v1) == Lisp_Int) + { + XSETINT (v1, XINT (v1) + 1); + TOP = v1; + } + else + TOP = Fadd1 (v1); + break; + + case Beqlsign: + v2 = POP; v1 = TOP; + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1, 0); + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2, 0); + TOP = (XFLOATINT (v1) == XFLOATINT (v2)) ? Qt : Qnil; + break; + + case Bgtr: + v1 = POP; + TOP = Fgtr (TOP, v1); + break; + + case Blss: + v1 = POP; + TOP = Flss (TOP, v1); + break; + + case Bleq: + v1 = POP; + TOP = Fleq (TOP, v1); + break; + + case Bgeq: + v1 = POP; + TOP = Fgeq (TOP, v1); + break; + + case Bdiff: + DISCARD(1); + TOP = Fminus (2, &TOP); + break; + + case Bnegate: + v1 = TOP; + if (XTYPE (v1) == Lisp_Int) + { + XSETINT (v1, - XINT (v1)); + TOP = v1; + } + else + TOP = Fminus (1, &TOP); + break; + + case Bplus: + DISCARD(1); + TOP = Fplus (2, &TOP); + break; + + case Bmax: + DISCARD(1); + TOP = Fmax (2, &TOP); + break; + + case Bmin: + DISCARD(1); + TOP = Fmin (2, &TOP); + break; + + case Bmult: + DISCARD(1); + TOP = Ftimes (2, &TOP); + break; + + case Bquo: + DISCARD(1); + TOP = Fquo (2, &TOP); + break; + + case Brem: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Frem (TOP, v1); + break; + + case Bpoint: + XFASTINT (v1) = point; + PUSH (v1); + break; + + case Bgoto_char: + TOP = Fgoto_char (TOP); + break; + + case Binsert: + TOP = Finsert (1, &TOP); + break; + + case Bpoint_max: + XFASTINT (v1) = ZV; + PUSH (v1); + break; + + case Bpoint_min: + XFASTINT (v1) = BEGV; + PUSH (v1); + break; + + case Bchar_after: + TOP = Fchar_after (TOP); + break; + + case Bfollowing_char: + XFASTINT (v1) = PT == ZV ? 0 : FETCH_CHAR (point); + PUSH (v1); + break; + + case Bpreceding_char: + XFASTINT (v1) = point <= BEGV ? 0 : FETCH_CHAR (point - 1); + PUSH (v1); + break; + + case Bcurrent_column: + XFASTINT (v1) = current_column (); + PUSH (v1); + break; + + case Bindent_to: + TOP = Findent_to (TOP, Qnil); + break; + + case Beolp: + PUSH (Feolp ()); + break; + + case Beobp: + PUSH (Feobp ()); + break; + + case Bbolp: + PUSH (Fbolp ()); + break; + + case Bbobp: + PUSH (Fbobp ()); + break; + + case Bcurrent_buffer: + PUSH (Fcurrent_buffer ()); + break; + + case Bset_buffer: + TOP = Fset_buffer (TOP); + break; + + case Bread_char: + PUSH (Fread_char ()); + QUIT; + break; + + case Binteractive_p: + PUSH (Finteractive_p ()); + break; + + case Bforward_char: + /* This was wrong! --jwz */ + TOP = Fforward_char (TOP); + break; + + case Bforward_word: + /* This was wrong! --jwz */ + TOP = Fforward_word (TOP); + break; + + case Bskip_chars_forward: + /* This was wrong! --jwz */ + v1 = POP; + TOP = Fskip_chars_forward (TOP, v1); + break; + + case Bskip_chars_backward: + /* This was wrong! --jwz */ + v1 = POP; + TOP = Fskip_chars_backward (TOP, v1); + break; + + case Bforward_line: + /* This was wrong! --jwz */ + TOP = Fforward_line (TOP); + break; + + case Bchar_syntax: + CHECK_NUMBER (TOP, 0); + XFASTINT (TOP) = syntax_code_spec[(int) SYNTAX (0xFF & XINT (TOP))]; + break; + + case Bbuffer_substring: + v1 = POP; + TOP = Fbuffer_substring (TOP, v1); + break; + + case Bdelete_region: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fdelete_region (TOP, v1); + break; + + case Bnarrow_to_region: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fnarrow_to_region (TOP, v1); + break; + + case Bwiden: + PUSH (Fwiden ()); + break; + + case Bstringeqlsign: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fstring_equal (TOP, v1); + break; + + case Bstringlss: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fstring_lessp (TOP, v1); + break; + + case Bequal: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fequal (TOP, v1); + break; + + case Bnthcdr: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fnthcdr (TOP, v1); + break; + + case Belt: + if (XTYPE (TOP) == Lisp_Cons) + { + /* Exchange args and then do nth. */ + v2 = POP; + v1 = TOP; + goto nth_entry; + } + v1 = POP; + TOP = Felt (TOP, v1); + break; + + case Bmember: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fmember (TOP, v1); + break; + + case Bassq: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fassq (TOP, v1); + break; + + case Bnreverse: + TOP = Fnreverse (TOP); + break; + + case Bsetcar: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fsetcar (TOP, v1); + break; + + case Bsetcdr: + v1 = POP; + /* This had args in the wrong order. -- jwz */ + TOP = Fsetcdr (TOP, v1); + break; + + case Bcar_safe: + v1 = TOP; + if (XTYPE (v1) == Lisp_Cons) + TOP = XCONS (v1)->car; + else + TOP = Qnil; + break; + + case Bcdr_safe: + v1 = TOP; + if (XTYPE (v1) == Lisp_Cons) + TOP = XCONS (v1)->cdr; + else + TOP = Qnil; + break; + + case Bnconc: + DISCARD(1); + TOP = Fnconc (2, &TOP); + break; + + case Bnumberp: + TOP = (XTYPE (TOP) == Lisp_Int || XTYPE (TOP) == Lisp_Float + ? Qt : Qnil); + break; + + case Bintegerp: + TOP = XTYPE (TOP) == Lisp_Int ? Qt : Qnil; + break; + +#ifdef BYTE_CODE_SAFE + case Bset_mark: + error ("set-mark is an obsolete bytecode"); + break; + case Bscan_buffer: + error ("scan-buffer is an obsolete bytecode"); + break; + case Bmark: + error("mark is an obsolete bytecode"); + break; +#endif + + 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 + } + } + + exit: + UNGCPRO; + /* Binds and unbinds are supposed to be compiled balanced. */ + if (specpdl_ptr - specpdl != count) +#ifdef BYTE_CODE_SAFE + error ("binding stack not balanced (serious byte compiler bug)"); +#else + abort (); +#endif + return v1; +} + +syms_of_bytecode () +{ + Qbytecode = intern ("byte-code"); + staticpro (&Qbytecode); + + defsubr (&Sbyte_code); + +#ifdef BYTE_CODE_METER + + DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter, + "a vector of vectors which holds a histogram of byte-code usage."); + DEFVAR_BOOL ("byte-metering-on", &byte_metering_on, ""); + + byte_metering_on = 0; + Vbyte_code_meter = Fmake_vector(make_number(256), make_number(0)); + + { + int i = 256; + while (i--) + XVECTOR(Vbyte_code_meter)->contents[i] = + Fmake_vector(make_number(256), make_number(0)); + } +#endif +}