cgit.sxemacs.org Git - sxemacs/blob - src/bytecode.c

   1 /* Execution of byte code produced by bytecomp.el.
   2    Implementation of compiled-function objects.
   3    Copyright (C) 1992, 1993 Free Software Foundation, Inc.
   4
   5 This file is part of SXEmacs
   6
   7 SXEmacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 SXEmacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  19
  20
  21 /* Synched up with: Mule 2.0, FSF 19.30. */
  22
  23 /* This file has been Mule-ized. */
  24
  25 /* Authorship:
  26
  27    FSF: long ago.
  28
  29 hacked on by jwz@jwz.org 1991-06
  30   o  added a compile-time switch to turn on simple sanity checking;
  31   o  put back the obsolete byte-codes for error-detection;
  32   o  added a new instruction, unbind_all, which I will use for
  33      tail-recursion elimination;
  34   o  made temp_output_buffer_show be called with the right number
  35      of args;
  36   o  made the new bytecodes be called with args in the right order;
  37   o  added metering support.
  38
  39 by Hallvard:
  40   o  added relative jump instructions;
  41   o  all conditionals now only do QUIT if they jump.
  42
  43    Ben Wing: some changes for Mule, 1995-06.
  44
  45    Martin Buchholz: performance hacking, 1998-09.
  46    See Internals Manual, Evaluation.
  47  */
  48
  49 #include <config.h>
  50 #include "lisp.h"
  51 #include "backtrace.h"
  52 #include "buffer.h"
  53 #include "bytecode.h"
  54 #include "opaque.h"
  55 #include "syntax.h"
  56
  57 EXFUN(Ffetch_bytecode, 1);
  58
  59 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
  60
  61 enum Opcode {                   /* Byte codes */
  62         Bvarref = 010,
  63         Bvarset = 020,
  64         Bvarbind = 030,
  65         Bcall = 040,
  66         Bunbind = 050,
  67
  68         Bnth = 070,
  69         Bsymbolp = 071,
  70         Bconsp = 072,
  71         Bstringp = 073,
  72         Blistp = 074,
  73         Bold_eq = 075,
  74         Bold_memq = 076,
  75         Bnot = 077,
  76         Bcar = 0100,
  77         Bcdr = 0101,
  78         Bcons = 0102,
  79         Blist1 = 0103,
  80         Blist2 = 0104,
  81         Blist3 = 0105,
  82         Blist4 = 0106,
  83         Blength = 0107,
  84         Baref = 0110,
  85         Baset = 0111,
  86         Bsymbol_value = 0112,
  87         Bsymbol_function = 0113,
  88         Bset = 0114,
  89         Bfset = 0115,
  90         Bget = 0116,
  91         Bsubstring = 0117,
  92         Bconcat2 = 0120,
  93         Bconcat3 = 0121,
  94         Bconcat4 = 0122,
  95         Bsub1 = 0123,
  96         Badd1 = 0124,
  97         Beqlsign = 0125,
  98         Bgtr = 0126,
  99         Blss = 0127,
 100         Bleq = 0130,
 101         Bgeq = 0131,
 102         Bdiff = 0132,
 103         Bnegate = 0133,
 104         Bplus = 0134,
 105         Bmax = 0135,
 106         Bmin = 0136,
 107         Bmult = 0137,
 108
 109         Bpoint = 0140,
 110         Beq = 0141,             /* was Bmark,
 111                                    but no longer generated as of v18 */
 112         Bgoto_char = 0142,
 113         Binsert = 0143,
 114         Bpoint_max = 0144,
 115         Bpoint_min = 0145,
 116         Bchar_after = 0146,
 117         Bfollowing_char = 0147,
 118         Bpreceding_char = 0150,
 119         Bcurrent_column = 0151,
 120         Bindent_to = 0152,
 121         Bequal = 0153,          /* was Bscan_buffer,
 122                                    but no longer generated as of v18 */
 123         Beolp = 0154,
 124         Beobp = 0155,
 125         Bbolp = 0156,
 126         Bbobp = 0157,
 127         Bcurrent_buffer = 0160,
 128         Bset_buffer = 0161,
 129         Bsave_current_buffer = 0162,    /* was Bread_char,
 130                                            but no longer generated as of v19 */
 131         Bmemq = 0163,           /* was Bset_mark,
 132                                    but no longer generated as of v18 */
 133         Binteractive_p = 0164,  /* Needed since interactive-p takes
 134                                    unevalled args */
 135         Bforward_char = 0165,
 136         Bforward_word = 0166,
 137         Bskip_chars_forward = 0167,
 138         Bskip_chars_backward = 0170,
 139         Bforward_line = 0171,
 140         Bchar_syntax = 0172,
 141         Bbuffer_substring = 0173,
 142         Bdelete_region = 0174,
 143         Bnarrow_to_region = 0175,
 144         Bwiden = 0176,
 145         Bend_of_line = 0177,
 146
 147         Bconstant2 = 0201,
 148         Bgoto = 0202,
 149         Bgotoifnil = 0203,
 150         Bgotoifnonnil = 0204,
 151         Bgotoifnilelsepop = 0205,
 152         Bgotoifnonnilelsepop = 0206,
 153         Breturn = 0207,
 154         Bdiscard = 0210,
 155         Bdup = 0211,
 156
 157         Bsave_excursion = 0212,
 158         Bsave_window_excursion = 0213,
 159         Bsave_restriction = 0214,
 160         Bcatch = 0215,
 161
 162         Bunwind_protect = 0216,
 163         Bcondition_case = 0217,
 164         Btemp_output_buffer_setup = 0220,
 165         Btemp_output_buffer_show = 0221,
 166
 167         Bunbind_all = 0222,
 168
 169         Bset_marker = 0223,
 170         Bmatch_beginning = 0224,
 171         Bmatch_end = 0225,
 172         Bupcase = 0226,
 173         Bdowncase = 0227,
 174
 175         Bstring_equal = 0230,
 176         Bstring_lessp = 0231,
 177         Bold_equal = 0232,
 178         Bnthcdr = 0233,
 179         Belt = 0234,
 180         Bold_member = 0235,
 181         Bold_assq = 0236,
 182         Bnreverse = 0237,
 183         Bsetcar = 0240,
 184         Bsetcdr = 0241,
 185         Bcar_safe = 0242,
 186         Bcdr_safe = 0243,
 187         Bnconc = 0244,
 188         Bquo = 0245,
 189         Brem = 0246,
 190         Bnumberp = 0247,
 191         Bintegerp = 0250,
 192
 193         BRgoto = 0252,
 194         BRgotoifnil = 0253,
 195         BRgotoifnonnil = 0254,
 196         BRgotoifnilelsepop = 0255,
 197         BRgotoifnonnilelsepop = 0256,
 198
 199         BlistN = 0257,
 200         BconcatN = 0260,
 201         BinsertN = 0261,
 202         Bmember = 0266,         /* new in v20 */
 203         Bassq = 0267,           /* new in v20 */
 204
 205         Bcl_macro = 0270,               /* only if modules/cl is there */
 206
 207         BLAST_BEFORE_THREE_O_O = Bcl_macro,
 208
 209         Bconstant = 0300
 210 };
 211 typedef enum Opcode Opcode;
 212 typedef unsigned char Opbyte;
 213 \f
 214 static void check_opcode(Opcode opcode);
 215 static void invalid_byte_code_error(char *error_message, ...);
 216
 217 static Lisp_Object*
 218 execute_rare_opcode(Lisp_Object *stk, const Opbyte *prg, Opcode opcode)
 219         __attribute__((noinline));
 220
 221 static Lisp_Object execute_optimized_program(const Opbyte * program,
 222                                              int stack_depth,
 223                                              Lisp_Object * constants_data);
 224
 225 extern Lisp_Object Qand_rest, Qand_optional;
 226
 227 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
 228    This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
 229 /* #define BYTE_CODE_METER */
 230 \f
 231 #ifdef BYTE_CODE_METER
 232
 233 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
 234 int byte_metering_on;
 235
 236 static void meter_code(Opcode prev_opcode, Opcode this_opcode)
 237 {
 238         if (byte_metering_on) {
 239                 Lisp_Object *p =
 240                     XVECTOR_DATA(XVECTOR_DATA(Vbyte_code_meter)[this_opcode]);
 241                 p[0] = INT_PLUS1(p[0]);
 242                 if (prev_opcode)
 243                         p[prev_opcode] = INT_PLUS1(p[prev_opcode]);
 244         }
 245 }
 246
 247 #endif                          /* BYTE_CODE_METER */
 248 \f
 249 static Lisp_Object bytecode_nreverse(Lisp_Object list)
 250 {
 251         REGISTER Lisp_Object prev = Qnil;
 252         REGISTER Lisp_Object tail = list;
 253
 254         while (!NILP(tail)) {
 255                 REGISTER Lisp_Object next;
 256                 CHECK_CONS(tail);
 257                 next = XCDR(tail);
 258                 XCDR(tail) = prev;
 259                 prev = tail;
 260                 tail = next;
 261         }
 262         return prev;
 263 }
 264
 265 /* Apply compiled-function object FUN to the NARGS evaluated arguments
 266    in ARGS, and return the result of evaluation. */
 267 Lisp_Object
 268 funcall_compiled_function(Lisp_Object fun, int nargs, Lisp_Object args[])
 269 {
 270         /* This function can GC */
 271         int speccount = specpdl_depth();
 272         REGISTER int i = 0;
 273         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
 274         int optional = 0;
 275
 276         if (!OPAQUEP(f->instructions))
 277                 /* Lazily munge the instructions into a more efficient form */
 278                 optimize_compiled_function(fun);
 279
 280         /* optimize_compiled_function() guaranteed that f->specpdl_depth is
 281            the required space on the specbinding stack for binding the args
 282            and local variables of fun.   So just reserve it once. */
 283         SPECPDL_RESERVE(f->specpdl_depth);
 284
 285         {
 286                 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
 287                    containing only non-constant symbols. */
 288                 LIST_LOOP_3(symbol, f->arglist, tail) {
 289                         if (EQ(symbol, Qand_rest)) {
 290                                 tail = XCDR(tail);
 291                                 symbol = XCAR(tail);
 292                                 SPECBIND_FAST_UNSAFE(symbol,
 293                                                      Flist(nargs - i,
 294                                                            &args[i]));
 295                                 goto run_code;
 296                         } else if (EQ(symbol, Qand_optional))
 297                                 optional = 1;
 298                         else if (i == nargs && !optional)
 299                                 goto wrong_number_of_arguments;
 300                         else
 301                                 SPECBIND_FAST_UNSAFE(symbol,
 302                                                      i <
 303                                                      nargs ? args[i++] : Qnil);
 304                 }
 305         }
 306
 307         if (i < nargs)
 308                 goto wrong_number_of_arguments;
 309
 310       run_code:
 311
 312         {
 313                 Lisp_Object value =
 314                     execute_optimized_program((Opbyte *)
 315                                               XOPAQUE_DATA(f->instructions),
 316                                               f->stack_depth,
 317                                               XVECTOR_DATA(f->constants));
 318
 319                 /* The attempt to optimize this by only unbinding variables failed
 320                    because using buffer-local variables as function parameters
 321                    leads to specpdl_ptr->func != 0 */
 322                 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
 323                 UNBIND_TO_GCPRO(speccount, value);
 324                 return value;
 325         }
 326
 327       wrong_number_of_arguments:
 328         /* The actual printed compiled_function object is incomprehensible.
 329            Check the backtrace to see if we can get a more meaningful symbol. */
 330         if (EQ(fun, indirect_function(*backtrace_list->function, 0)))
 331                 fun = *backtrace_list->function;
 332         return Fsignal(Qwrong_number_of_arguments, list2(fun, make_int(nargs)));
 333 }
 334 \f
 335 /* Read next uint8 from the instruction stream. */
 336 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
 337
 338 /* Read next uint16 from the instruction stream. */
 339 #define READ_UINT_2                                             \
 340   (program_ptr += 2,                                            \
 341    (((unsigned int) (unsigned char) program_ptr[-1]) * 256 +    \
 342     ((unsigned int) (unsigned char) program_ptr[-2])))
 343
 344 /* Read next int8 from the instruction stream. */
 345 #define READ_INT_1 ((int) (signed char) *program_ptr++)
 346
 347 /* Read next int16 from the instruction stream. */
 348 #define READ_INT_2                                      \
 349   (program_ptr += 2,                                    \
 350    (((int) (  signed char) program_ptr[-1]) * 256 +     \
 351     ((int) (unsigned char) program_ptr[-2])))
 352
 353 /* Read next int8 from instruction stream; don't advance program_pointer */
 354 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
 355
 356 /* Read next int16 from instruction stream; don't advance program_pointer */
 357 #define PEEK_INT_2                                      \
 358   ((((int) (  signed char) program_ptr[1]) * 256) |     \
 359     ((int) (unsigned char) program_ptr[0]))
 360
 361 /* Do relative jumps from the current location.
 362    We only do a QUIT if we jump backwards, for efficiency.
 363    No infloops without backward jumps! */
 364 #define JUMP_RELATIVE(jump) do {        \
 365   int JR_jump = (jump);                 \
 366   if (JR_jump < 0) QUIT;                \
 367   program_ptr += JR_jump;               \
 368 } while (0)
 369
 370 #define JUMP  JUMP_RELATIVE (PEEK_INT_2)
 371 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
 372
 373 #define JUMP_NEXT  ((void) (program_ptr += 2))
 374 #define JUMPR_NEXT ((void) (program_ptr += 1))
 375
 376 /* Push x onto the execution stack. */
 377 #define PUSH(x) (*++stack_ptr = (x))
 378
 379 /* Pop a value off the execution stack. */
 380 #define POP (*stack_ptr--)
 381
 382 /* Discard n values from the execution stack.  */
 383 #define DISCARD(n) (stack_ptr -= (n))
 384
 385 /* Get the value which is at the top of the execution stack,
 386    but don't pop it. */
 387 #define TOP (*stack_ptr)
 388
 389 /* See comment before the big switch in execute_optimized_program(). */
 390 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
 391 #define GCPRO_STACK
 392 #else  /* !BDWGC */
 393 #define GCPRO_STACK  (gcpro1.nvars = stack_ptr - stack_beg)
 394 #endif  /* BDWGC */
 395
 396 /* The actual interpreter for byte code.
 397    This function has been seriously optimized for performance.
 398    Don't change the constructs unless you are willing to do
 399    real benchmarking and profiling work -- martin */
 400
 401 static Lisp_Object
 402 execute_optimized_program(const Opbyte *program,
 403                           int stack_depth, Lisp_Object *constants_data)
 404 {
 405         /* This function can GC */
 406         REGISTER const Opbyte *program_ptr = program;
 407         /* C99 here we come */
 408         Lisp_Object stack_beg[stack_depth + 1];
 409         REGISTER Lisp_Object *stack_ptr = stack_beg;
 410         int speccount = specpdl_depth();
 411         struct gcpro gcpro1;
 412
 413 #ifdef BYTE_CODE_METER
 414         Opcode this_opcode = 0;
 415         Opcode prev_opcode;
 416 #endif
 417
 418 #ifdef ERROR_CHECK_BYTE_CODE
 419         Lisp_Object *stack_end = stack_beg + stack_depth;
 420 #endif
 421
 422         /* We used to GCPRO the whole interpreter stack before entering this while
 423            loop (21.5.14 and before), but that interferes with collection of weakly
 424            referenced objects.  Although strictly speaking there's no promise that
 425            weak references will disappear by any given point in time, they should
 426            be collected at the first opportunity.  Waiting until exit from the
 427            function caused test failures because "stale" objects "above" the top of
 428            the stack were still GCPROed, and they were not getting collected until
 429            after exit from the (byte-compiled) test!
 430
 431            Now the idea is to dynamically adjust the array of GCPROed objects to
 432            include only the "active" region of the stack.
 433
 434            We use the "GCPRO1 the array base and set the nvars member" method.  It
 435            would be slightly inefficient but correct to use GCPRO1_ARRAY here.  It
 436            would just redundantly set nvars.
 437            #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK
 438            after the switch?
 439
 440            GCPRO_STACK is something of a misnomer, because it suggests that a
 441            struct gcpro is initialized each time.  This is false; only the nvars
 442            member of a single struct gcpro is being adjusted.  This works because
 443            each time a new object is assigned to a stack location, the old object
 444            loses its reference and is effectively UNGCPROed, and the new object is
 445            automatically GCPROed as long as nvars is correct.  Only when we
 446            return from the interpreter do we need to finalize the struct gcpro
 447            itself, and that's done at case Breturn.
 448         */
 449         GCPRO1 (stack_ptr[1]);
 450
 451         while (1) {
 452                 REGISTER Opcode opcode = READ_UINT_1;
 453
 454                 /* Get nvars right before maybe signaling. */
 455                 GCPRO_STACK;
 456 #ifdef ERROR_CHECK_BYTE_CODE
 457                 if (stack_ptr > stack_end)
 458                         invalid_byte_code_error("byte code stack overflow");
 459                 if (stack_ptr < stack_beg)
 460                         invalid_byte_code_error("byte code stack underflow");
 461                 check_opcode(opcode);
 462 #endif
 463
 464 #ifdef BYTE_CODE_METER
 465                 prev_opcode = this_opcode;
 466                 this_opcode = opcode;
 467                 meter_code(prev_opcode, this_opcode);
 468 #endif
 469
 470                 switch ((unsigned int)opcode) {
 471                         REGISTER int n;
 472
 473                 default:
 474                         if (opcode >= Bconstant)
 475                                 PUSH(constants_data[opcode - Bconstant]);
 476                         else
 477                                 stack_ptr = execute_rare_opcode(
 478                                         stack_ptr, program_ptr, opcode);
 479                         break;
 480
 481                 case Bvarref:
 482                 case Bvarref + 1:
 483                 case Bvarref + 2:
 484                 case Bvarref + 3:
 485                 case Bvarref + 4:
 486                 case Bvarref + 5:
 487                         n = opcode - Bvarref;
 488                         goto do_varref;
 489                 case Bvarref + 7:
 490                         n = READ_UINT_2;
 491                         goto do_varref;
 492                 case Bvarref + 6:
 493                         n = READ_UINT_1;        /* most common */
 494                 do_varref:
 495                         {
 496                                 Lisp_Object symbol = constants_data[n];
 497                                 Lisp_Object value = XSYMBOL(symbol)->value;
 498                                 if (SYMBOL_VALUE_MAGIC_P(value))
 499                                         value = Fsymbol_value(symbol);
 500                                 PUSH(value);
 501                                 break;
 502                         }
 503
 504                 case Bvarset:
 505                 case Bvarset + 1:
 506                 case Bvarset + 2:
 507                 case Bvarset + 3:
 508                 case Bvarset + 4:
 509                 case Bvarset + 5:
 510                         n = opcode - Bvarset;
 511                         goto do_varset;
 512                 case Bvarset + 7:
 513                         n = READ_UINT_2;
 514                         goto do_varset;
 515                 case Bvarset + 6:
 516                         n = READ_UINT_1;        /* most common */
 517                 do_varset:
 518                         {
 519                                 Lisp_Object symbol = constants_data[n];
 520                                 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
 521                                 Lisp_Object old_value = symbol_ptr->value;
 522                                 Lisp_Object new_value = POP;
 523                                 if (!SYMBOL_VALUE_MAGIC_P(old_value)
 524                                     || UNBOUNDP(old_value))
 525                                         symbol_ptr->value = new_value;
 526                                 else
 527                                         Fset(symbol, new_value);
 528                                 break;
 529                         }
 530
 531                 case Bvarbind:
 532                 case Bvarbind + 1:
 533                 case Bvarbind + 2:
 534                 case Bvarbind + 3:
 535                 case Bvarbind + 4:
 536                 case Bvarbind + 5:
 537                         n = opcode - Bvarbind;
 538                         goto do_varbind;
 539                 case Bvarbind + 7:
 540                         n = READ_UINT_2;
 541                         goto do_varbind;
 542                 case Bvarbind + 6:
 543                         n = READ_UINT_1;        /* most common */
 544                 do_varbind:
 545                         {
 546                                 Lisp_Object symbol = constants_data[n];
 547                                 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
 548                                 Lisp_Object old_value = symbol_ptr->value;
 549                                 Lisp_Object new_value = POP;
 550                                 if (!SYMBOL_VALUE_MAGIC_P(old_value)
 551                                     || UNBOUNDP(old_value)) {
 552                                         specpdl_ptr->symbol = symbol;
 553                                         specpdl_ptr->old_value = old_value;
 554                                         specpdl_ptr->func = 0;
 555                                         specpdl_ptr++;
 556                                         specpdl_depth_counter++;
 557
 558                                         symbol_ptr->value = new_value;
 559
 560 #ifdef ERROR_CHECK_CATCH
 561                                         check_specbind_stack_sanity ();
 562 #endif
 563                                 } else
 564                                         specbind_magic(symbol, new_value);
 565                                 break;
 566                         }
 567
 568
 569                 case Bcall:
 570                 case Bcall + 1:
 571                 case Bcall + 2:
 572                 case Bcall + 3:
 573                 case Bcall + 4:
 574                 case Bcall + 5:
 575                 case Bcall + 6:
 576                 case Bcall + 7:
 577                         n = (opcode < Bcall + 6 ? opcode - Bcall :
 578                              opcode == Bcall + 6 ? READ_UINT_1 : READ_UINT_2);
 579                         DISCARD(n);
 580 #ifdef BYTE_CODE_METER
 581                         if (byte_metering_on && SYMBOLP(TOP)) {
 582                                 Lisp_Object val =
 583                                         Fget(TOP, Qbyte_code_meter, Qnil);
 584                                 if (INTP(val))
 585                                         Fput(TOP, Qbyte_code_meter,
 586                                              make_int(XINT(val) + 1));
 587                         }
 588 #endif
 589                         TOP = Ffuncall(n + 1, &TOP);
 590                         break;
 591
 592                 case Bunbind:
 593                 case Bunbind + 1:
 594                 case Bunbind + 2:
 595                 case Bunbind + 3:
 596                 case Bunbind + 4:
 597                 case Bunbind + 5:
 598                 case Bunbind + 6:
 599                 case Bunbind + 7:
 600                         UNBIND_TO(specpdl_depth() -
 601                                   (opcode < Bunbind + 6 ? opcode - Bunbind :
 602                                    opcode ==
 603                                    Bunbind + 6 ? READ_UINT_1 : READ_UINT_2));
 604                         break;
 605
 606                 case Bgoto:
 607                         JUMP;
 608                         break;
 609
 610                 case Bgotoifnil:
 611                         if (NILP(POP))
 612                                 JUMP;
 613                         else
 614                                 JUMP_NEXT;
 615                         break;
 616
 617                 case Bgotoifnonnil:
 618                         if (!NILP(POP))
 619                                 JUMP;
 620                         else
 621                                 JUMP_NEXT;
 622                         break;
 623
 624                 case Bgotoifnilelsepop:
 625                         if (NILP(TOP))
 626                                 JUMP;
 627                         else {
 628                                 DISCARD(1);
 629                                 JUMP_NEXT;
 630                         }
 631                         break;
 632
 633                 case Bgotoifnonnilelsepop:
 634                         if (!NILP(TOP))
 635                                 JUMP;
 636                         else {
 637                                 DISCARD(1);
 638                                 JUMP_NEXT;
 639                         }
 640                         break;
 641
 642                 case BRgoto:
 643                         JUMPR;
 644                         break;
 645
 646                 case BRgotoifnil:
 647                         if (NILP(POP))
 648                                 JUMPR;
 649                         else
 650                                 JUMPR_NEXT;
 651                         break;
 652
 653                 case BRgotoifnonnil:
 654                         if (!NILP(POP))
 655                                 JUMPR;
 656                         else
 657                                 JUMPR_NEXT;
 658                         break;
 659
 660                 case BRgotoifnilelsepop:
 661                         if (NILP(TOP))
 662                                 JUMPR;
 663                         else {
 664                                 DISCARD(1);
 665                                 JUMPR_NEXT;
 666                         }
 667                         break;
 668
 669                 case BRgotoifnonnilelsepop:
 670                         if (!NILP(TOP))
 671                                 JUMPR;
 672                         else {
 673                                 DISCARD(1);
 674                                 JUMPR_NEXT;
 675                         }
 676                         break;
 677
 678                 case Breturn:
 679                         UNGCPRO;
 680 #ifdef ERROR_CHECK_BYTE_CODE
 681                         /* Binds and unbinds are supposed to be compiled balanced.  */
 682                         if (specpdl_depth() != speccount)
 683                                 invalid_byte_code_error
 684                                         ("unbalanced specbinding stack");
 685 #endif
 686                         return TOP;
 687
 688                 case Bdiscard:
 689                         DISCARD(1);
 690                         break;
 691
 692                 case Bdup:
 693                 {
 694                         Lisp_Object arg = TOP;
 695                         PUSH(arg);
 696                         break;
 697                 }
 698
 699                 case Bconstant2:
 700                         PUSH(constants_data[READ_UINT_2]);
 701                         break;
 702
 703                 case Bcar:
 704                         TOP = CONSP(TOP) ? XCAR(TOP) : Fcar(TOP);
 705                         break;
 706
 707                 case Bcdr:
 708                         TOP = CONSP(TOP) ? XCDR(TOP) : Fcdr(TOP);
 709                         break;
 710
 711                 case Bunbind_all:
 712                         /* To unbind back to the beginning of this frame.  Not
 713                            used yet, but will be needed for tail-recursion
 714                            elimination. */
 715                         unbind_to(speccount, Qnil);
 716                         break;
 717
 718                 case Bnth: {
 719                         Lisp_Object arg = POP;
 720                         TOP = Fcar(Fnthcdr(TOP, arg));
 721                         break;
 722                 }
 723
 724                 case Bsymbolp:
 725                         TOP = SYMBOLP(TOP) ? Qt : Qnil;
 726                         break;
 727
 728                 case Bconsp:
 729                         TOP = CONSP(TOP) ? Qt : Qnil;
 730                         break;
 731
 732                 case Bstringp:
 733                         TOP = STRINGP(TOP) ? Qt : Qnil;
 734                         break;
 735
 736                 case Blistp:
 737                         TOP = LISTP(TOP) ? Qt : Qnil;
 738                         break;
 739
 740                 case Bnumberp:
 741                         TOP = NUMBERP(TOP) ? Qt : Qnil;
 742                         break;
 743
 744                 case Bintegerp:
 745 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 746                         TOP = INTEGERP(TOP) ? Qt : Qnil;
 747 #else
 748                         TOP = INTP(TOP) ? Qt : Qnil;
 749 #endif
 750                         break;
 751
 752                 case Beq: {
 753                         Lisp_Object arg = POP;
 754                         TOP = EQ_WITH_EBOLA_NOTICE(TOP, arg) ? Qt : Qnil;
 755                         break;
 756                 }
 757
 758                 case Bnot:
 759                         TOP = NILP(TOP) ? Qt : Qnil;
 760                         break;
 761
 762                 case Bcons: {
 763                         Lisp_Object arg = POP;
 764                         TOP = Fcons(TOP, arg);
 765                         break;
 766                 }
 767
 768                 case Blist1:
 769                         TOP = Fcons(TOP, Qnil);
 770                         break;
 771
 772                 case BlistN:
 773                         n = READ_UINT_1;
 774                         goto do_list;
 775
 776                 case Blist2:
 777                 case Blist3:
 778                 case Blist4:
 779                         /* common case */
 780                         n = opcode - (Blist1 - 1);
 781                 do_list:
 782                         {
 783                                 Lisp_Object list = Qnil;
 784                         list_loop:
 785                                 list = Fcons(TOP, list);
 786                                 if (--n) {
 787                                         DISCARD(1);
 788                                         goto list_loop;
 789                                 }
 790                                 TOP = list;
 791                                 break;
 792                         }
 793
 794                 case Bconcat2:
 795                 case Bconcat3:
 796                 case Bconcat4:
 797                         n = opcode - (Bconcat2 - 2);
 798                         goto do_concat;
 799
 800                 case BconcatN:
 801                         /* common case */
 802                         n = READ_UINT_1;
 803                 do_concat:
 804                         DISCARD(n - 1);
 805                         TOP = Fconcat(n, &TOP);
 806                         break;
 807
 808                 case Blength:
 809                         TOP = Flength(TOP);
 810                         break;
 811
 812                 case Baset: {
 813                         Lisp_Object arg2 = POP;
 814                         Lisp_Object arg1 = POP;
 815                         TOP = Faset(TOP, arg1, arg2);
 816                         break;
 817                 }
 818
 819                 case Bsymbol_value:
 820                         TOP = Fsymbol_value(TOP);
 821                         break;
 822
 823                 case Bsymbol_function:
 824                         TOP = Fsymbol_function(TOP);
 825                         break;
 826
 827                 case Bget: {
 828                         Lisp_Object arg = POP;
 829                         TOP = Fget(TOP, arg, Qnil);
 830                         break;
 831                 }
 832
 833                 case Bsub1:
 834                         TOP = Fsub1(TOP);
 835                         break;
 836
 837                 case Badd1:
 838                         TOP = Fadd1(TOP);
 839                         break;
 840
 841                 case Beqlsign: {
 842                         Lisp_Object arg = POP;
 843                         if (ent_binrel(ASE_BINARY_REL_EQUALP, TOP, arg))
 844                                 TOP = Qt;
 845                         else
 846                                 TOP = Qnil;
 847                         break;
 848                 }
 849
 850                 case Bgtr: {
 851                         Lisp_Object arg = POP;
 852                         if (ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
 853                                 TOP = Qt;
 854                         else
 855                                 TOP = Qnil;
 856                         break;
 857                 }
 858
 859                 case Blss: {
 860                         Lisp_Object arg = POP;
 861                         if (ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
 862                                 TOP = Qt;
 863                         else
 864                                 TOP = Qnil;
 865                         break;
 866                 }
 867
 868                 case Bleq: {
 869                         Lisp_Object arg = POP;
 870                         if (ent_binrel2(ASE_BINARY_REL_LESSP,
 871                                         ASE_BINARY_REL_EQUALP, TOP, arg))
 872                                 TOP = Qt;
 873                         else
 874                                 TOP = Qnil;
 875                         break;
 876                 }
 877
 878                 case Bgeq: {
 879                         Lisp_Object arg = POP;
 880                         if (ent_binrel2(ASE_BINARY_REL_GREATERP,
 881                                         ASE_BINARY_REL_EQUALP, TOP, arg))
 882                                 TOP = Qt;
 883                         else
 884                                 TOP = Qnil;
 885                         break;
 886                 }
 887
 888                 case Bnegate:
 889                         TOP = ent_unop_neg(TOP);
 890                         break;
 891
 892                 case Bnconc:
 893                         DISCARD(1);
 894                         TOP = bytecode_nconc2(&TOP);
 895                         break;
 896
 897                 case Bplus: {
 898                         Lisp_Object arg = POP;
 899                         TOP = ent_binop(ASE_BINARY_OP_SUM, TOP, arg);
 900                         break;
 901                 }
 902                 case Bdiff: {
 903                         Lisp_Object arg = POP;
 904                         TOP = ent_binop(ASE_BINARY_OP_DIFF, TOP, arg);
 905                         break;
 906                 }
 907                 case Bmult: {
 908                         Lisp_Object arg = POP;
 909                         TOP = ent_binop(ASE_BINARY_OP_PROD, TOP, arg);
 910                         break;
 911                 }
 912                 case Bquo: {
 913                         Lisp_Object arg = POP;
 914                         TOP = ent_binop(ASE_BINARY_OP_DIV, TOP, arg);
 915                         break;
 916                 }
 917                 case Bmax: {
 918                         Lisp_Object arg = POP;
 919                         if (!ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
 920                                 TOP = arg;
 921                         break;
 922                 }
 923                 case Bmin: {
 924                         Lisp_Object arg = POP;
 925                         if (!ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
 926                                 TOP = arg;
 927                         break;
 928                 }
 929
 930                 case Bpoint:
 931                         PUSH(make_int(BUF_PT(current_buffer)));
 932                         break;
 933
 934                 case Binsert:
 935                         TOP = Finsert(1, &TOP);
 936                         break;
 937
 938                 case BinsertN:
 939                         n = READ_UINT_1;
 940                         DISCARD(n - 1);
 941                         TOP = Finsert(n, &TOP);
 942                         break;
 943
 944                 case Baref: {
 945                         Lisp_Object arg = POP;
 946                         TOP = Faref(TOP, arg);
 947                         break;
 948                 }
 949
 950                 case Bmemq: {
 951                         Lisp_Object arg = POP;
 952                         TOP = Fmemq(TOP, arg);
 953                         break;
 954                 }
 955
 956                 case Bset: {
 957                         Lisp_Object arg = POP;
 958                         TOP = Fset(TOP, arg);
 959                         break;
 960                 }
 961
 962                 case Bequal: {
 963                         Lisp_Object arg = POP;
 964                         TOP = Fequal(TOP, arg);
 965                         break;
 966                 }
 967
 968                 case Bnthcdr: {
 969                         Lisp_Object arg = POP;
 970                         TOP = Fnthcdr(TOP, arg);
 971                         break;
 972                 }
 973
 974                 case Belt: {
 975                         Lisp_Object arg = POP;
 976                         TOP = Felt(TOP, arg);
 977                         break;
 978                 }
 979
 980                 case Bmember: {
 981                         Lisp_Object arg = POP;
 982                         TOP = Fmember(TOP, arg);
 983                         break;
 984                 }
 985
 986                 case Bgoto_char:
 987                         TOP = Fgoto_char(TOP, Qnil);
 988                         break;
 989
 990                 case Bcurrent_buffer: {
 991                         Lisp_Object buffer;
 992                         XSETBUFFER(buffer, current_buffer);
 993                         PUSH(buffer);
 994                         break;
 995                 }
 996
 997                 case Bset_buffer:
 998                         TOP = Fset_buffer(TOP);
 999                         break;
1000
1001                 case Bpoint_max:
1002                         PUSH(make_int(BUF_ZV(current_buffer)));
1003                         break;
1004
1005                 case Bpoint_min:
1006                         PUSH(make_int(BUF_BEGV(current_buffer)));
1007                         break;
1008
1009                 case Bskip_chars_forward: {
1010                         Lisp_Object arg = POP;
1011                         TOP = Fskip_chars_forward(TOP, arg, Qnil);
1012                         break;
1013                 }
1014
1015                 case Bassq: {
1016                         Lisp_Object arg = POP;
1017                         TOP = Fassq(TOP, arg);
1018                         break;
1019                 }
1020
1021                 case Bsetcar: {
1022                         Lisp_Object arg = POP;
1023                         TOP = Fsetcar(TOP, arg);
1024                         break;
1025                 }
1026
1027                 case Bsetcdr: {
1028                         Lisp_Object arg = POP;
1029                         TOP = Fsetcdr(TOP, arg);
1030                         break;
1031                 }
1032
1033                 case Bnreverse:
1034                         TOP = bytecode_nreverse(TOP);
1035                         break;
1036
1037                 case Bcar_safe:
1038                         TOP = CONSP(TOP) ? XCAR(TOP) : Qnil;
1039                         break;
1040
1041                 case Bcdr_safe:
1042                         TOP = CONSP(TOP) ? XCDR(TOP) : Qnil;
1043                         break;
1044
1045                 case Bcl_macro: {
1046                         Lisp_Object op = TOP;
1047                         Lisp_Object orig_fun, fun;
1048                         Lisp_Object args;
1049
1050                         orig_fun = fun = XCAR(op);
1051                         args = XCDR(op);
1052                         if (SYMBOLP (fun) && !EQ(fun, Qunbound) &&
1053                             (fun = XSYMBOL(fun)->function, SYMBOLP(fun)))
1054                                 fun = indirect_function(fun, 1);
1055                         if (SUBRP(fun) && XSUBR(fun)->max_args == UNEVALLED) {
1056                                 Lisp_Object(*subr)(Lisp_Object) =
1057                                         (Lisp_Object(*)(Lisp_Object))
1058                                         subr_function(XSUBR(fun));
1059                                 TOP = subr(args);
1060                         } else {
1061                                 fprintf(stderr, "Uh-oh!\nSuicide?\n");
1062                                 if (random() & 1) {
1063                                         fprintf(stderr, "YESSSSSS!\n");
1064                                         abort();
1065                                 }
1066                                 fprintf(stderr, "tomorrow maybe\n");
1067                         }
1068                         break;
1069                 }
1070                 }
1071         }
1072 }
1073
1074 /* It makes a worthwhile performance difference (5%) to shunt
1075    lesser-used opcodes off to a subroutine, to keep the switch in
1076    execute_optimized_program small.  If you REALLY care about
1077    performance, you want to keep your heavily executed code away from
1078    rarely executed code, to minimize cache misses.
1079
1080    Don't make this function static, since then the compiler might inline it.
1081
1082    How about __attribute__((noinline)) then? -hrop */
1083 static Lisp_Object*
1084 execute_rare_opcode(Lisp_Object *stack_ptr,
1085                     const Opbyte *program_ptr, Opcode opcode)
1086 {
1087         switch ((unsigned int)opcode) {
1088
1089         case Bsave_excursion:
1090                 record_unwind_protect(save_excursion_restore,
1091                                       save_excursion_save());
109