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 #include "ent/ent.h"
  57
  58 EXFUN(Ffetch_bytecode, 1);
  59
  60 Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
  61
  62 enum Opcode {                   /* Byte codes */
  63         Bvarref = 010,
  64         Bvarset = 020,
  65         Bvarbind = 030,
  66         Bcall = 040,
  67         Bunbind = 050,
  68
  69         Bnth = 070,
  70         Bsymbolp = 071,
  71         Bconsp = 072,
  72         Bstringp = 073,
  73         Blistp = 074,
  74         Bold_eq = 075,
  75         Bold_memq = 076,
  76         Bnot = 077,
  77         Bcar = 0100,
  78         Bcdr = 0101,
  79         Bcons = 0102,
  80         Blist1 = 0103,
  81         Blist2 = 0104,
  82         Blist3 = 0105,
  83         Blist4 = 0106,
  84         Blength = 0107,
  85         Baref = 0110,
  86         Baset = 0111,
  87         Bsymbol_value = 0112,
  88         Bsymbol_function = 0113,
  89         Bset = 0114,
  90         Bfset = 0115,
  91         Bget = 0116,
  92         Bsubstring = 0117,
  93         Bconcat2 = 0120,
  94         Bconcat3 = 0121,
  95         Bconcat4 = 0122,
  96         Bsub1 = 0123,
  97         Badd1 = 0124,
  98         Beqlsign = 0125,
  99         Bgtr = 0126,
 100         Blss = 0127,
 101         Bleq = 0130,
 102         Bgeq = 0131,
 103         Bdiff = 0132,
 104         Bnegate = 0133,
 105         Bplus = 0134,
 106         Bmax = 0135,
 107         Bmin = 0136,
 108         Bmult = 0137,
 109
 110         Bpoint = 0140,
 111         Beq = 0141,             /* was Bmark,
 112                                    but no longer generated as of v18 */
 113         Bgoto_char = 0142,
 114         Binsert = 0143,
 115         Bpoint_max = 0144,
 116         Bpoint_min = 0145,
 117         Bchar_after = 0146,
 118         Bfollowing_char = 0147,
 119         Bpreceding_char = 0150,
 120         Bcurrent_column = 0151,
 121         Bindent_to = 0152,
 122         Bequal = 0153,          /* was Bscan_buffer,
 123                                    but no longer generated as of v18 */
 124         Beolp = 0154,
 125         Beobp = 0155,
 126         Bbolp = 0156,
 127         Bbobp = 0157,
 128         Bcurrent_buffer = 0160,
 129         Bset_buffer = 0161,
 130         Bsave_current_buffer = 0162,    /* was Bread_char,
 131                                            but no longer generated as of v19 */
 132         Bmemq = 0163,           /* was Bset_mark,
 133                                    but no longer generated as of v18 */
 134         Binteractive_p = 0164,  /* Needed since interactive-p takes
 135                                    unevalled args */
 136         Bforward_char = 0165,
 137         Bforward_word = 0166,
 138         Bskip_chars_forward = 0167,
 139         Bskip_chars_backward = 0170,
 140         Bforward_line = 0171,
 141         Bchar_syntax = 0172,
 142         Bbuffer_substring = 0173,
 143         Bdelete_region = 0174,
 144         Bnarrow_to_region = 0175,
 145         Bwiden = 0176,
 146         Bend_of_line = 0177,
 147
 148         Bconstant2 = 0201,
 149         Bgoto = 0202,
 150         Bgotoifnil = 0203,
 151         Bgotoifnonnil = 0204,
 152         Bgotoifnilelsepop = 0205,
 153         Bgotoifnonnilelsepop = 0206,
 154         Breturn = 0207,
 155         Bdiscard = 0210,
 156         Bdup = 0211,
 157
 158         Bsave_excursion = 0212,
 159         Bsave_window_excursion = 0213,
 160         Bsave_restriction = 0214,
 161         Bcatch = 0215,
 162
 163         Bunwind_protect = 0216,
 164         Bcondition_case = 0217,
 165         Btemp_output_buffer_setup = 0220,
 166         Btemp_output_buffer_show = 0221,
 167
 168         Bunbind_all = 0222,
 169
 170         Bset_marker = 0223,
 171         Bmatch_beginning = 0224,
 172         Bmatch_end = 0225,
 173         Bupcase = 0226,
 174         Bdowncase = 0227,
 175
 176         Bstring_equal = 0230,
 177         Bstring_lessp = 0231,
 178         Bold_equal = 0232,
 179         Bnthcdr = 0233,
 180         Belt = 0234,
 181         Bold_member = 0235,
 182         Bold_assq = 0236,
 183         Bnreverse = 0237,
 184         Bsetcar = 0240,
 185         Bsetcdr = 0241,
 186         Bcar_safe = 0242,
 187         Bcdr_safe = 0243,
 188         Bnconc = 0244,
 189         Bquo = 0245,
 190         Brem = 0246,
 191         Bnumberp = 0247,
 192         Bintegerp = 0250,
 193
 194         BRgoto = 0252,
 195         BRgotoifnil = 0253,
 196         BRgotoifnonnil = 0254,
 197         BRgotoifnilelsepop = 0255,
 198         BRgotoifnonnilelsepop = 0256,
 199
 200         BlistN = 0257,
 201         BconcatN = 0260,
 202         BinsertN = 0261,
 203         Bmember = 0266,         /* new in v20 */
 204         Bassq = 0267,           /* new in v20 */
 205
 206         Bcl_macro = 0270,               /* only if modules/cl is there */
 207
 208         BLAST_BEFORE_THREE_O_O = Bcl_macro,
 209
 210         Bconstant = 0300
 211 };
 212 typedef enum Opcode Opcode;
 213 typedef unsigned char Opbyte;
 214 \f
 215 static void check_opcode(Opcode opcode);
 216 static void invalid_byte_code_error(char *error_message, ...);
 217
 218 static Lisp_Object*
 219 execute_rare_opcode(Lisp_Object *stk, const Opbyte *prg, Opcode opcode)
 220         __attribute__((noinline));
 221
 222 static Lisp_Object execute_optimized_program(const Opbyte * program,
 223                                              int stack_depth,
 224                                              Lisp_Object * constants_data);
 225
 226 extern Lisp_Object Qand_rest, Qand_optional;
 227
 228 /* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
 229    This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
 230 /* #define BYTE_CODE_METER */
 231 \f
 232 #ifdef BYTE_CODE_METER
 233
 234 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
 235 int byte_metering_on;
 236
 237 static void meter_code(Opcode prev_opcode, Opcode this_opcode)
 238 {
 239         if (byte_metering_on) {
 240                 Lisp_Object *p =
 241                     XVECTOR_DATA(XVECTOR_DATA(Vbyte_code_meter)[this_opcode]);
 242                 p[0] = INT_PLUS1(p[0]);
 243                 if (prev_opcode)
 244                         p[prev_opcode] = INT_PLUS1(p[prev_opcode]);
 245         }
 246 }
 247
 248 #endif                          /* BYTE_CODE_METER */
 249 \f
 250 static Lisp_Object bytecode_nreverse(Lisp_Object list)
 251 {
 252         REGISTER Lisp_Object prev = Qnil;
 253         REGISTER Lisp_Object tail = list;
 254
 255         while (!NILP(tail)) {
 256                 REGISTER Lisp_Object next;
 257                 CHECK_CONS(tail);
 258                 next = XCDR(tail);
 259                 XCDR(tail) = prev;
 260                 prev = tail;
 261                 tail = next;
 262         }
 263         return prev;
 264 }
 265
 266 /* Apply compiled-function object FUN to the NARGS evaluated arguments
 267    in ARGS, and return the result of evaluation. */
 268 Lisp_Object
 269 funcall_compiled_function(Lisp_Object fun, int nargs, Lisp_Object args[])
 270 {
 271         /* This function can GC */
 272         int speccount = specpdl_depth();
 273         REGISTER int i = 0;
 274         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(fun);
 275         int optional = 0;
 276
 277         if (!OPAQUEP(f->instructions))
 278                 /* Lazily munge the instructions into a more efficient form */
 279                 optimize_compiled_function(fun);
 280
 281         /* optimize_compiled_function() guaranteed that f->specpdl_depth is
 282            the required space on the specbinding stack for binding the args
 283            and local variables of fun.   So just reserve it once. */
 284         SPECPDL_RESERVE(f->specpdl_depth);
 285
 286         {
 287                 /* Fmake_byte_code() guaranteed that f->arglist is a valid list
 288                    containing only non-constant symbols. */
 289                 LIST_LOOP_3(symbol, f->arglist, tail) {
 290                         if (EQ(symbol, Qand_rest)) {
 291                                 tail = XCDR(tail);
 292                                 symbol = XCAR(tail);
 293                                 SPECBIND_FAST_UNSAFE(symbol,
 294                                                      Flist(nargs - i,
 295                                                            &args[i]));
 296                                 goto run_code;
 297                         } else if (EQ(symbol, Qand_optional))
 298                                 optional = 1;
 299                         else if (i == nargs && !optional)
 300                                 goto wrong_number_of_arguments;
 301                         else
 302                                 SPECBIND_FAST_UNSAFE(symbol,
 303                                                      i <
 304                                                      nargs ? args[i++] : Qnil);
 305                 }
 306         }
 307
 308         if (i < nargs)
 309                 goto wrong_number_of_arguments;
 310
 311       run_code:
 312
 313         {
 314                 Lisp_Object value =
 315                     execute_optimized_program((Opbyte *)
 316                                               XOPAQUE_DATA(f->instructions),
 317                                               f->stack_depth,
 318                                               XVECTOR_DATA(f->constants));
 319
 320                 /* The attempt to optimize this by only unbinding variables failed
 321                    because using buffer-local variables as function parameters
 322                    leads to specpdl_ptr->func != 0 */
 323                 /* UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); */
 324                 UNBIND_TO_GCPRO(speccount, value);
 325                 return value;
 326         }
 327
 328       wrong_number_of_arguments:
 329         /* The actual printed compiled_function object is incomprehensible.
 330            Check the backtrace to see if we can get a more meaningful symbol. */
 331         if (EQ(fun, indirect_function(*backtrace_list->function, 0)))
 332                 fun = *backtrace_list->function;
 333         return Fsignal(Qwrong_number_of_arguments, list2(fun, make_int(nargs)));
 334 }
 335 \f
 336 /* Read next uint8 from the instruction stream. */
 337 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
 338
 339 /* Read next uint16 from the instruction stream. */
 340 #define READ_UINT_2                                             \
 341   (program_ptr += 2,                                            \
 342    (((unsigned int) (unsigned char) program_ptr[-1]) * 256 +    \
 343     ((unsigned int) (unsigned char) program_ptr[-2])))
 344
 345 /* Read next int8 from the instruction stream. */
 346 #define READ_INT_1 ((int) (signed char) *program_ptr++)
 347
 348 /* Read next int16 from the instruction stream. */
 349 #define READ_INT_2                                      \
 350   (program_ptr += 2,                                    \
 351    (((int) (  signed char) program_ptr[-1]) * 256 +     \
 352     ((int) (unsigned char) program_ptr[-2])))
 353
 354 /* Read next int8 from instruction stream; don't advance program_pointer */
 355 #define PEEK_INT_1 ((int) (signed char) program_ptr[0])
 356
 357 /* Read next int16 from instruction stream; don't advance program_pointer */
 358 #define PEEK_INT_2                                      \
 359   ((((int) (  signed char) program_ptr[1]) * 256) |     \
 360     ((int) (unsigned char) program_ptr[0]))
 361
 362 /* Do relative jumps from the current location.
 363    We only do a QUIT if we jump backwards, for efficiency.
 364    No infloops without backward jumps! */
 365 #define JUMP_RELATIVE(jump) do {        \
 366   int JR_jump = (jump);                 \
 367   if (JR_jump < 0) QUIT;                \
 368   program_ptr += JR_jump;               \
 369 } while (0)
 370
 371 #define JUMP  JUMP_RELATIVE (PEEK_INT_2)
 372 #define JUMPR JUMP_RELATIVE (PEEK_INT_1)
 373
 374 #define JUMP_NEXT  ((void) (program_ptr += 2))
 375 #define JUMPR_NEXT ((void) (program_ptr += 1))
 376
 377 /* Push x onto the execution stack. */
 378 #define PUSH(x) (*++stack_ptr = (x))
 379
 380 /* Pop a value off the execution stack. */
 381 #define POP (*stack_ptr--)
 382
 383 /* Discard n values from the execution stack.  */
 384 #define DISCARD(n) (stack_ptr -= (n))
 385
 386 /* Get the value which is at the top of the execution stack,
 387    but don't pop it. */
 388 #define TOP (*stack_ptr)
 389
 390 /* See comment before the big switch in execute_optimized_program(). */
 391 #if defined HAVE_BDWGC && defined EF_USE_BDWGC
 392 #define GCPRO_STACK
 393 #else  /* !BDWGC */
 394 #define GCPRO_STACK  (gcpro1.nvars = stack_ptr - stack_beg)
 395 #endif  /* BDWGC */
 396
 397 /* The actual interpreter for byte code.
 398    This function has been seriously optimized for performance.
 399    Don't change the constructs unless you are willing to do
 400    real benchmarking and profiling work -- martin */
 401
 402 static Lisp_Object
 403 execute_optimized_program(const Opbyte *program,
 404                           int stack_depth, Lisp_Object *constants_data)
 405 {
 406         /* This function can GC */
 407         REGISTER const Opbyte *program_ptr = program;
 408         /* C99 here we come */
 409         Lisp_Object stack_beg[stack_depth + 1];
 410         REGISTER Lisp_Object *stack_ptr = stack_beg;
 411         int speccount = specpdl_depth();
 412         struct gcpro gcpro1;
 413
 414 #ifdef BYTE_CODE_METER
 415         Opcode this_opcode = 0;
 416         Opcode prev_opcode;
 417 #endif
 418
 419 #ifdef ERROR_CHECK_BYTE_CODE
 420         Lisp_Object *stack_end = stack_beg + stack_depth;
 421 #endif
 422
 423         /* We used to GCPRO the whole interpreter stack before entering this while
 424            loop (21.5.14 and before), but that interferes with collection of weakly
 425            referenced objects.  Although strictly speaking there's no promise that
 426            weak references will disappear by any given point in time, they should
 427            be collected at the first opportunity.  Waiting until exit from the
 428            function caused test failures because "stale" objects "above" the top of
 429            the stack were still GCPROed, and they were not getting collected until
 430            after exit from the (byte-compiled) test!
 431
 432            Now the idea is to dynamically adjust the array of GCPROed objects to
 433            include only the "active" region of the stack.
 434
 435            We use the "GCPRO1 the array base and set the nvars member" method.  It
 436            would be slightly inefficient but correct to use GCPRO1_ARRAY here.  It
 437            would just redundantly set nvars.
 438            #### Maybe it would be clearer to use GCPRO1_ARRAY and do GCPRO_STACK
 439            after the switch?
 440
 441            GCPRO_STACK is something of a misnomer, because it suggests that a
 442            struct gcpro is initialized each time.  This is false; only the nvars
 443            member of a single struct gcpro is being adjusted.  This works because
 444            each time a new object is assigned to a stack location, the old object
 445            loses its reference and is effectively UNGCPROed, and the new object is
 446            automatically GCPROed as long as nvars is correct.  Only when we
 447            return from the interpreter do we need to finalize the struct gcpro
 448            itself, and that's done at case Breturn.
 449         */
 450         GCPRO1 (stack_ptr[1]);
 451
 452         while (1) {
 453                 REGISTER Opcode opcode = READ_UINT_1;
 454
 455                 /* Get nvars right before maybe signaling. */
 456                 GCPRO_STACK;
 457 #ifdef ERROR_CHECK_BYTE_CODE
 458                 if (stack_ptr > stack_end)
 459                         invalid_byte_code_error("byte code stack overflow");
 460                 if (stack_ptr < stack_beg)
 461                         invalid_byte_code_error("byte code stack underflow");
 462                 check_opcode(opcode);
 463 #endif
 464
 465 #ifdef BYTE_CODE_METER
 466                 prev_opcode = this_opcode;
 467                 this_opcode = opcode;
 468                 meter_code(prev_opcode, this_opcode);
 469 #endif
 470
 471                 switch ((unsigned int)opcode) {
 472                         REGISTER int n;
 473
 474                 default:
 475                         if (opcode >= Bconstant)
 476                                 PUSH(constants_data[opcode - Bconstant]);
 477                         else
 478                                 stack_ptr = execute_rare_opcode(
 479                                         stack_ptr, program_ptr, opcode);
 480                         break;
 481
 482                 case Bvarref:
 483                 case Bvarref + 1:
 484                 case Bvarref + 2:
 485                 case Bvarref + 3:
 486                 case Bvarref + 4:
 487                 case Bvarref + 5:
 488                         n = opcode - Bvarref;
 489                         goto do_varref;
 490                 case Bvarref + 7:
 491                         n = READ_UINT_2;
 492                         goto do_varref;
 493                 case Bvarref + 6:
 494                         n = READ_UINT_1;        /* most common */
 495                 do_varref:
 496                         {
 497                                 Lisp_Object symbol = constants_data[n];
 498                                 Lisp_Object value = XSYMBOL(symbol)->value;
 499                                 if (SYMBOL_VALUE_MAGIC_P(value))
 500                                         value = Fsymbol_value(symbol);
 501                                 PUSH(value);
 502                                 break;
 503                         }
 504
 505                 case Bvarset:
 506                 case Bvarset + 1:
 507                 case Bvarset + 2:
 508                 case Bvarset + 3:
 509                 case Bvarset + 4:
 510                 case Bvarset + 5:
 511                         n = opcode - Bvarset;
 512                         goto do_varset;
 513                 case Bvarset + 7:
 514                         n = READ_UINT_2;
 515                         goto do_varset;
 516                 case Bvarset + 6:
 517                         n = READ_UINT_1;        /* most common */
 518                 do_varset:
 519                         {
 520                                 Lisp_Object symbol = constants_data[n];
 521                                 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
 522                                 Lisp_Object old_value = symbol_ptr->value;
 523                                 Lisp_Object new_value = POP;
 524                                 if (!SYMBOL_VALUE_MAGIC_P(old_value)
 525                                     || UNBOUNDP(old_value))
 526                                         symbol_ptr->value = new_value;
 527                                 else
 528                                         Fset(symbol, new_value);
 529                                 break;
 530                         }
 531
 532                 case Bvarbind:
 533                 case Bvarbind + 1:
 534                 case Bvarbind + 2:
 535                 case Bvarbind + 3:
 536                 case Bvarbind + 4:
 537                 case Bvarbind + 5:
 538                         n = opcode - Bvarbind;
 539                         goto do_varbind;
 540                 case Bvarbind + 7:
 541                         n = READ_UINT_2;
 542                         goto do_varbind;
 543                 case Bvarbind + 6:
 544                         n = READ_UINT_1;        /* most common */
 545                 do_varbind:
 546                         {
 547                                 Lisp_Object symbol = constants_data[n];
 548                                 Lisp_Symbol *symbol_ptr = XSYMBOL(symbol);
 549                                 Lisp_Object old_value = symbol_ptr->value;
 550                                 Lisp_Object new_value = POP;
 551                                 if (!SYMBOL_VALUE_MAGIC_P(old_value)
 552                                     || UNBOUNDP(old_value)) {
 553                                         specpdl_ptr->symbol = symbol;
 554                                         specpdl_ptr->old_value = old_value;
 555                                         specpdl_ptr->func = 0;
 556                                         specpdl_ptr++;
 557                                         specpdl_depth_counter++;
 558
 559                                         symbol_ptr->value = new_value;
 560
 561 #ifdef ERROR_CHECK_CATCH
 562                                         check_specbind_stack_sanity ();
 563 #endif
 564                                 } else
 565                                         specbind_magic(symbol, new_value);
 566                                 break;
 567                         }
 568
 569
 570                 case Bcall:
 571                 case Bcall + 1:
 572                 case Bcall + 2:
 573                 case Bcall + 3:
 574                 case Bcall + 4:
 575                 case Bcall + 5:
 576                 case Bcall + 6:
 577                 case Bcall + 7:
 578                         n = (opcode < Bcall + 6 ? opcode - Bcall :
 579                              opcode == Bcall + 6 ? READ_UINT_1 : READ_UINT_2);
 580                         DISCARD(n);
 581 #ifdef BYTE_CODE_METER
 582                         if (byte_metering_on && SYMBOLP(TOP)) {
 583                                 Lisp_Object val =
 584                                         Fget(TOP, Qbyte_code_meter, Qnil);
 585                                 if (INTP(val))
 586                                         Fput(TOP, Qbyte_code_meter,
 587                                              make_int(XINT(val) + 1));
 588                         }
 589 #endif
 590                         TOP = Ffuncall(n + 1, &TOP);
 591                         break;
 592
 593                 case Bunbind:
 594                 case Bunbind + 1:
 595                 case Bunbind + 2:
 596                 case Bunbind + 3:
 597                 case Bunbind + 4:
 598                 case Bunbind + 5:
 599                 case Bunbind + 6:
 600                 case Bunbind + 7:
 601                         UNBIND_TO(specpdl_depth() -
 602                                   (opcode < Bunbind + 6 ? opcode - Bunbind :
 603                                    opcode ==
 604                                    Bunbind + 6 ? READ_UINT_1 : READ_UINT_2));
 605                         break;
 606
 607                 case Bgoto:
 608                         JUMP;
 609                         break;
 610
 611                 case Bgotoifnil:
 612                         if (NILP(POP))
 613                                 JUMP;
 614                         else
 615                                 JUMP_NEXT;
 616                         break;
 617
 618                 case Bgotoifnonnil:
 619                         if (!NILP(POP))
 620                                 JUMP;
 621                         else
 622                                 JUMP_NEXT;
 623                         break;
 624
 625                 case Bgotoifnilelsepop:
 626                         if (NILP(TOP))
 627                                 JUMP;
 628                         else {
 629                                 DISCARD(1);
 630                                 JUMP_NEXT;
 631                         }
 632                         break;
 633
 634                 case Bgotoifnonnilelsepop:
 635                         if (!NILP(TOP))
 636                                 JUMP;
 637                         else {
 638                                 DISCARD(1);
 639                                 JUMP_NEXT;
 640                         }
 641                         break;
 642
 643                 case BRgoto:
 644                         JUMPR;
 645                         break;
 646
 647                 case BRgotoifnil:
 648                         if (NILP(POP))
 649                                 JUMPR;
 650                         else
 651                                 JUMPR_NEXT;
 652                         break;
 653
 654                 case BRgotoifnonnil:
 655                         if (!NILP(POP))
 656                                 JUMPR;
 657                         else
 658                                 JUMPR_NEXT;
 659                         break;
 660
 661                 case BRgotoifnilelsepop:
 662                         if (NILP(TOP))
 663                                 JUMPR;
 664                         else {
 665                                 DISCARD(1);
 666                                 JUMPR_NEXT;
 667                         }
 668                         break;
 669
 670                 case BRgotoifnonnilelsepop:
 671                         if (!NILP(TOP))
 672                                 JUMPR;
 673                         else {
 674                                 DISCARD(1);
 675                                 JUMPR_NEXT;
 676                         }
 677                         break;
 678
 679                 case Breturn:
 680                         UNGCPRO;
 681 #ifdef ERROR_CHECK_BYTE_CODE
 682                         /* Binds and unbinds are supposed to be compiled balanced.  */
 683                         if (specpdl_depth() != speccount)
 684                                 invalid_byte_code_error
 685                                         ("unbalanced specbinding stack");
 686 #endif
 687                         return TOP;
 688
 689                 case Bdiscard:
 690                         DISCARD(1);
 691                         break;
 692
 693                 case Bdup:
 694                 {
 695                         Lisp_Object arg = TOP;
 696                         PUSH(arg);
 697                         break;
 698                 }
 699
 700                 case Bconstant2:
 701                         PUSH(constants_data[READ_UINT_2]);
 702                         break;
 703
 704                 case Bcar:
 705                         TOP = CONSP(TOP) ? XCAR(TOP) : Fcar(TOP);
 706                         break;
 707
 708                 case Bcdr:
 709                         TOP = CONSP(TOP) ? XCDR(TOP) : Fcdr(TOP);
 710                         break;
 711
 712                 case Bunbind_all:
 713                         /* To unbind back to the beginning of this frame.  Not
 714                            used yet, but will be needed for tail-recursion
 715                            elimination. */
 716                         unbind_to(speccount, Qnil);
 717                         break;
 718
 719                 case Bnth: {
 720                         Lisp_Object arg = POP;
 721                         TOP = Fcar(Fnthcdr(TOP, arg));
 722                         break;
 723                 }
 724
 725                 case Bsymbolp:
 726                         TOP = SYMBOLP(TOP) ? Qt : Qnil;
 727                         break;
 728
 729                 case Bconsp:
 730                         TOP = CONSP(TOP) ? Qt : Qnil;
 731                         break;
 732
 733                 case Bstringp:
 734                         TOP = STRINGP(TOP) ? Qt : Qnil;
 735                         break;
 736
 737                 case Blistp:
 738                         TOP = LISTP(TOP) ? Qt : Qnil;
 739                         break;
 740
 741                 case Bnumberp:
 742                         TOP = NUMBERP(TOP) ? Qt : Qnil;
 743                         break;
 744
 745                 case Bintegerp:
 746 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
 747                         TOP = INTEGERP(TOP) ? Qt : Qnil;
 748 #else
 749                         TOP = INTP(TOP) ? Qt : Qnil;
 750 #endif
 751                         break;
 752
 753                 case Beq: {
 754                         Lisp_Object arg = POP;
 755                         TOP = EQ_WITH_EBOLA_NOTICE(TOP, arg) ? Qt : Qnil;
 756                         break;
 757                 }
 758
 759                 case Bnot:
 760                         TOP = NILP(TOP) ? Qt : Qnil;
 761                         break;
 762
 763                 case Bcons: {
 764                         Lisp_Object arg = POP;
 765                         TOP = Fcons(TOP, arg);
 766                         break;
 767                 }
 768
 769                 case Blist1:
 770                         TOP = Fcons(TOP, Qnil);
 771                         break;
 772
 773                 case BlistN:
 774                         n = READ_UINT_1;
 775                         goto do_list;
 776
 777                 case Blist2:
 778                 case Blist3:
 779                 case Blist4:
 780                         /* common case */
 781                         n = opcode - (Blist1 - 1);
 782                 do_list:
 783                         {
 784                                 Lisp_Object list = Qnil;
 785                         list_loop:
 786                                 list = Fcons(TOP, list);
 787                                 if (--n) {
 788                                         DISCARD(1);
 789                                         goto list_loop;
 790                                 }
 791                                 TOP = list;
 792                                 break;
 793                         }
 794
 795                 case Bconcat2:
 796                 case Bconcat3:
 797                 case Bconcat4:
 798                         n = opcode - (Bconcat2 - 2);
 799                         goto do_concat;
 800
 801                 case BconcatN:
 802                         /* common case */
 803                         n = READ_UINT_1;
 804                 do_concat:
 805                         DISCARD(n - 1);
 806                         TOP = Fconcat(n, &TOP);
 807                         break;
 808
 809                 case Blength:
 810                         TOP = Flength(TOP);
 811                         break;
 812
 813                 case Baset: {
 814                         Lisp_Object arg2 = POP;
 815                         Lisp_Object arg1 = POP;
 816                         TOP = Faset(TOP, arg1, arg2);
 817                         break;
 818                 }
 819
 820                 case Bsymbol_value:
 821                         TOP = Fsymbol_value(TOP);
 822                         break;
 823
 824                 case Bsymbol_function:
 825                         TOP = Fsymbol_function(TOP);
 826                         break;
 827
 828                 case Bget: {
 829                         Lisp_Object arg = POP;
 830                         TOP = Fget(TOP, arg, Qnil);
 831                         break;
 832                 }
 833
 834                 case Bsub1:
 835                         TOP = Fsub1(TOP);
 836                         break;
 837
 838                 case Badd1:
 839                         TOP = Fadd1(TOP);
 840                         break;
 841
 842                 case Beqlsign: {
 843                         Lisp_Object arg = POP;
 844                         if (ent_binrel(ASE_BINARY_REL_EQUALP, TOP, arg))
 845                                 TOP = Qt;
 846                         else
 847                                 TOP = Qnil;
 848                         break;
 849                 }
 850
 851                 case Bgtr: {
 852                         Lisp_Object arg = POP;
 853                         if (ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
 854                                 TOP = Qt;
 855                         else
 856                                 TOP = Qnil;
 857                         break;
 858                 }
 859
 860                 case Blss: {
 861                         Lisp_Object arg = POP;
 862                         if (ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
 863                                 TOP = Qt;
 864                         else
 865                                 TOP = Qnil;
 866                         break;
 867                 }
 868
 869                 case Bleq: {
 870                         Lisp_Object arg = POP;
 871                         if (ent_binrel2(ASE_BINARY_REL_LESSP,
 872                                         ASE_BINARY_REL_EQUALP, TOP, arg))
 873                                 TOP = Qt;
 874                         else
 875                                 TOP = Qnil;
 876                         break;
 877                 }
 878
 879                 case Bgeq: {
 880                         Lisp_Object arg = POP;
 881                         if (ent_binrel2(ASE_BINARY_REL_GREATERP,
 882                                         ASE_BINARY_REL_EQUALP, TOP, arg))
 883                                 TOP = Qt;
 884                         else
 885                                 TOP = Qnil;
 886                         break;
 887                 }
 888
 889                 case Bnegate:
 890                         TOP = ent_unop_neg(TOP);
 891                         break;
 892
 893                 case Bnconc:
 894                         DISCARD(1);
 895                         TOP = bytecode_nconc2(&TOP);
 896                         break;
 897
 898                 case Bplus: {
 899                         Lisp_Object arg = POP;
 900                         TOP = ent_binop(ASE_BINARY_OP_SUM, TOP, arg);
 901                         break;
 902                 }
 903                 case Bdiff: {
 904                         Lisp_Object arg = POP;
 905                         TOP = ent_binop(ASE_BINARY_OP_DIFF, TOP, arg);
 906                         break;
 907                 }
 908                 case Bmult: {
 909                         Lisp_Object arg = POP;
 910                         TOP = ent_binop(ASE_BINARY_OP_PROD, TOP, arg);
 911                         break;
 912                 }
 913                 case Bquo: {
 914                         Lisp_Object arg = POP;
 915                         TOP = ent_binop(ASE_BINARY_OP_DIV, TOP, arg);
 916                         break;
 917                 }
 918                 case Bmax: {
 919                         Lisp_Object arg = POP;
 920                         if (!ent_binrel(ASE_BINARY_REL_GREATERP, TOP, arg))
 921                                 TOP = arg;
 922                         break;
 923                 }
 924                 case Bmin: {
 925                         Lisp_Object arg = POP;
 926                         if (!ent_binrel(ASE_BINARY_REL_LESSP, TOP, arg))
 927                                 TOP = arg;
 928                         break;
 929                 }
 930
 931                 case Bpoint:
 932                         PUSH(make_int(BUF_PT(current_buffer)));
 933                         break;
 934
 935                 case Binsert:
 936                         TOP = Finsert(1, &TOP);
 937                         break;
 938
 939                 case BinsertN:
 940                         n = READ_UINT_1;
 941                         DISCARD(n - 1);
 942                         TOP = Finsert(n, &TOP);
 943                         break;
 944
 945                 case Baref: {
 946                         Lisp_Object arg = POP;
 947                         TOP = Faref(TOP, arg);
 948                         break;
 949                 }
 950
 951                 case Bmemq: {
 952                         Lisp_Object arg = POP;
 953                         TOP = Fmemq(TOP, arg);
 954                         break;
 955                 }
 956
 957                 case Bset: {
 958                         Lisp_Object arg = POP;
 959                         TOP = Fset(TOP, arg);
 960                         break;
 961                 }
 962
 963                 case Bequal: {
 964                         Lisp_Object arg = POP;
 965                         TOP = Fequal(TOP, arg);
 966                         break;
 967                 }
 968
 969                 case Bnthcdr: {
 970                         Lisp_Object arg = POP;
 971                         TOP = Fnthcdr(TOP, arg);
 972                         break;
 973                 }
 974
 975                 case Belt: {
 976                         Lisp_Object arg = POP;
 977                         TOP = Felt(TOP, arg);
 978                         break;
 979                 }
 980
 981                 case Bmember: {
 982                         Lisp_Object arg = POP;
 983                         TOP = Fmember(TOP, arg);
 984                         break;
 985                 }
 986
 987                 case Bgoto_char:
 988                         TOP = Fgoto_char(TOP, Qnil);
 989                         break;
 990
 991                 case Bcurrent_buffer: {
 992                         Lisp_Object buffer;
 993                         XSETBUFFER(buffer, current_buffer);
 994                         PUSH(buffer);
 995                         break;
 996                 }
 997
 998                 case Bset_buffer:
 999                         TOP = Fset_buffer(TOP);
1000                         break;
1001
1002                 case Bpoint_max:
1003                         PUSH(make_int(BUF_ZV(current_buffer)));
1004                         break;
1005
1006                 case Bpoint_min:
1007                         PUSH(make_int(BUF_BEGV(current_buffer)));
1008                         break;
1009
1010                 case Bskip_chars_forward: {
1011                         Lisp_Object arg = POP;
1012                         TOP = Fskip_chars_forward(TOP, arg, Qnil);
1013                         break;
1014                 }
1015
1016                 case Bassq: {
1017                         Lisp_Object arg = POP;
1018                         TOP = Fassq(TOP, arg);
1019                         break;
1020                 }
1021
1022                 case Bsetcar: {
1023                         Lisp_Object arg = POP;
1024                         TOP = Fsetcar(TOP, arg);
1025                         break;
1026                 }
1027
1028                 case Bsetcdr: {
1029                         Lisp_Object arg = POP;
1030                         TOP = Fsetcdr(TOP, arg);
1031                         break;
1032                 }
1033
1034                 case Bnreverse:
1035                         TOP = bytecode_nreverse(TOP);
1036                         break;
1037
1038                 case Bcar_safe:
1039                         TOP = CONSP(TOP) ? XCAR(TOP) : Qnil;
1040                         break;
1041
1042                 case Bcdr_safe:
1043                         TOP = CONSP(TOP) ? XCDR(TOP) : Qnil;
1044                         break;
1045
1046                 case Bcl_macro: {
1047                         Lisp_Object op = TOP;
1048                         Lisp_Object orig_fun, fun;
1049                         Lisp_Object args;
1050
1051                         orig_fun = fun = XCAR(op);
1052                         SXE_SET_UNUSED(orig_fun);
1053
1054                         args = XCDR(op);
1055                         if (SYMBOLP (fun) && !EQ(fun, Qunbound) &&
1056                             (fun = XSYMBOL(fun)->function, SYMBOLP(fun)))
1057                                 fun = indirect_function(fun, 1);
1058                         if (SUBRP(fun) && XSUBR(fun)->max_args == UNEVALLED) {
1059                                 Lisp_Object(*subr)(Lisp_Object) =
1060                                         (Lisp_Object(*)(Lisp_Object))
1061                                         subr_function(XSUBR(fun));
1062                                 TOP = subr(args);
1063                         } else {
1064                                 fprintf(stderr, "Uh-oh!\nSuicide?\n");
1065                                 if (random() & 1) {
1066                                         fprintf(stderr, "YESSSSSS!\n");
1067                                         abort();
1068                                 }
1069                                 fprintf(stderr, "tomorrow maybe\n");
1070                         }
1071                         break;
1072                 }
1073                 }
1074         }
1075 }
1076
1077 /* It makes a worthwhile performance difference (5%) to shunt
1078    lesser-used opcodes off to a subroutine, to keep the switch in
1079    execute_optimized_program small.  If you REALLY care about
1080    performance, you want to keep your heavily executed code away from
1081    rarely executed code, to minimize cache misses.
1082
1083    Don't make this function static, since then the compiler might inline it.
1084
1085    How about __attribute__((noinline)) then? -hrop */
1086 static Lisp_Object*
1087 execute_rare_opcode(Lisp_Object *stack_ptr,
1088                     const Opbyte *program_ptr, Opcode opcode)
1089 {
1090         switch ((unsigned int)opcode) {
1091
1092         case Bsave_excursion:
1093                 record_unwind_protect(save_excursion_restore,
1094                                       save_excursion_save());
1095                 break;
1096
1097         case Bsave_window_excursion: {
1098                 int count = specpdl_depth();
1099                 record_unwind_protect(save_window_excursion_unwind,
1100                                       Fcurrent_window_configuration
1101                                       (Qnil));
1102                 TOP = Fprogn(TOP);
1103                 unbind_to(count, Qnil);
1104                 break;
1105         }
1106
1107         case Bsave_restriction:
1108                 record_unwind_protect(save_restriction_restore,
1109                                       save_restriction_save());
1110                 break;
1111
1112         case Bcatch: {
1113                 Lisp_Object arg = POP;
1114                 TOP = internal_catch(TOP, Feval, arg, 0);
1115                 break;
1116         }
1117
1118         case Bskip_chars_backward: {
1119                 Lisp_Object arg = POP;
1120                 TOP = Fskip_chars_backward(TOP, arg, Qnil);
1121                 break;
1122         }
1123
1124         case Bunwind_protect:
1125                 record_unwind_protect(Fprogn, POP);
1126                 break;
1127
1128         case Bcondition_case: {
1129                 Lisp_Object arg2 = POP; /* handlers */
1130                 Lisp_Object arg1 = POP; /* bodyform */
1131                 TOP = condition_case_3(arg1, TOP, arg2);
1132                 break;
1133         }
1134
1135         case Bset_marker: {
1136                 Lisp_Object arg2 = POP;
1137                 Lisp_Object arg1 = POP;
1138                 TOP = Fset_marker(TOP, arg1, arg2);
1139                 break;
1140         }
1141
1142         case Brem: {
1143                 Lisp_Object arg = POP;
1144                 TOP = ent_binop(ASE_BINARY_OP_REM, TOP, arg);
1145                 break;
1146         }
1147
1148         case Bmatch_beginning:
1149                 TOP = Fmatch_beginning(TOP);
1150                 break;
1151
1152         case Bmatch_end:
1153                 TOP = Fmatch_end(TOP);
1154                 break;
1155
1156         case Bupcase:
1157                 TOP = Fupcase(TOP, Qnil);
1158                 break;
1159
1160         case Bdowncase:
1161                 TOP = Fdowncase(TOP, Qnil);
1162                 break;
1163
1164         case Bfset: {
1165                 Lisp_Object arg = POP;
1166                 TOP = Ffset(TOP, arg);
1167                 break;
1168         }
1169
1170         case Bstring_equal: {
1171                 Lisp_Object arg = POP;
1172                 TOP = Fstring_equal(TOP, arg);
1173                 break;
1174         }
1175
1176         case Bstring_lessp: {
1177                 Lisp_Object arg = POP;
1178                 TOP = Fstring_lessp(TOP, arg);
1179                 break;
1180         }
1181
1182         case Bsubstring: {
1183                 Lisp_Object arg2 = POP;
1184                 Lisp_Object arg1 = POP;
1185                 TOP = Fsubstring(TOP, arg1, arg2);
1186                 break;
1187         }
1188
1189         case Bcurrent_column:
1190                 PUSH(make_int(current_column(current_buffer)));
1191                 break;
1192
1193         case Bchar_after:
1194                 TOP = Fchar_after(TOP, Qnil);
1195                 break;
1196
1197         case Bindent_to:
1198                 TOP = Findent_to(TOP, Qnil, Qnil);
1199                 break;
1200
1201         case Bwiden:
1202                 PUSH(Fwiden(Qnil));
1203                 break;
1204
1205         case Bfollowing_char:
1206                 PUSH(Ffollowing_char(Qnil));
1207                 break;
1208
1209         case Bpreceding_char:
1210                 PUSH(Fpreceding_char(Qnil));
1211                 break;
1212
1213         case Beolp:
1214                 PUSH(Feolp(Qnil));
1215                 break;
1216
1217         case Beobp:
1218                 PUSH(Feobp(Qnil));
1219                 break;
1220
1221         case Bbolp:
1222                 PUSH(Fbolp(Qnil));
1223                 break;
1224
1225         case Bbobp:
1226                 PUSH(Fbobp(Qnil));
1227                 break;
1228
1229         case Bsave_current_buffer:
1230                 record_unwind_protect(save_current_buffer_restore,
1231                                       Fcurrent_buffer());
1232                 break;
1233
1234         case Binteractive_p:
1235                 PUSH(Finteractive_p());
1236                 break;
1237
1238         case Bforward_char:
1239                 TOP = Fforward_char(TOP, Qnil);
1240                 break;
1241
1242         case Bforward_word:
1243                 TOP = Fforward_word(TOP, Qnil);
1244                 break;
1245
1246         case Bforward_line:
1247                 TOP = Fforward_line(TOP, Qnil);
1248                 break;
1249
1250         case Bchar_syntax:
1251                 TOP = Fchar_syntax(TOP, Qnil);
1252                 break;
1253
1254         case Bbuffer_substring: {
1255                 Lisp_Object arg = POP;
1256                 TOP = Fbuffer_substring(TOP, arg, Qnil);
1257                 break;
1258         }
1259
1260         case Bdelete_region: {
1261                 Lisp_Object arg = POP;
1262                 TOP = Fdelete_region(TOP, arg, Qnil);
1263                 break;
1264         }
1265
1266         case Bnarrow_to_region: {
1267                 Lisp_Object arg = POP;
1268                 TOP = Fnarrow_to_region(TOP, arg, Qnil);
1269                 break;
1270         }
1271
1272         case Bend_of_line:
1273                 TOP = Fend_of_line(TOP, Qnil);
1274                 break;
1275
1276         case Btemp_output_buffer_setup:
1277                 temp_output_buffer_setup(TOP);
1278                 TOP = Vstandard_output;
1279                 break;
1280
1281         case Btemp_output_buffer_show: {
1282                 Lisp_Object arg = POP;
1283                 temp_output_buffer_show(TOP, Qnil);
1284                 TOP = arg;
1285                 /* GAG ME!! */
1286                 /* pop binding of standard-output */
1287                 unbind_to(specpdl_depth() - 1, Qnil);
1288                 break;
1289         }
1290
1291
1292         case Bold_eq: {
1293                 Lisp_Object arg = POP;
1294                 TOP = HACKEQ_UNSAFE(TOP, arg) ? Qt : Qnil;
1295                 break;
1296         }
1297
1298         case Bold_memq: {
1299                 Lisp_Object arg = POP;
1300                 TOP = Fold_memq(TOP, arg);
1301                 break;
1302         }
1303
1304         case Bold_equal: {
1305                 Lisp_Object arg = POP;
1306                 TOP = Fold_equal(TOP, arg);
1307                 break;
1308         }
1309
1310         case Bold_member: {
1311                 Lisp_Object arg = POP;
1312                 TOP = Fold_member(TOP, arg);
1313                 break;
1314         }
1315
1316         case Bold_assq: {
1317                 Lisp_Object arg = POP;
1318                 TOP = Fold_assq(TOP, arg);
1319                 break;
1320         }
1321
1322         default:
1323                 abort();
1324                 break;
1325         }
1326         return stack_ptr;
1327 }
1328
1329 \f
1330 static void invalid_byte_code_error(char *error_message, ...)
1331 {
1332         Lisp_Object obj;
1333         va_list args;
1334         int maxsz = strlen(error_message) + 128;
1335         char *buf = alloca_array(char, maxsz);
1336
1337         int sz=snprintf(buf, maxsz, "%s", error_message);
1338         assert(sz>=0 && sz<maxsz);
1339         va_start(args, error_message);
1340         obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(buf), Qnil, -1,
1341                                      args);
1342         va_end(args);
1343
1344         signal_error(Qinvalid_byte_code, list1(obj));
1345 }
1346
1347 /* Check for valid opcodes.  Change this when adding new opcodes.  */
1348 static void check_opcode(Opcode opcode)
1349 {
1350         if ((opcode < Bvarref) ||
1351             (opcode == 0251) ||
1352             (opcode > BLAST_BEFORE_THREE_O_O && opcode < Bconstant))
1353                 invalid_byte_code_error
1354                     ("invalid opcode %d in instruction stream", opcode);
1355 }
1356
1357 /* Check that IDX is a valid offset into the `constants' vector */
1358 static void check_constants_index(int idx, Lisp_Object constants)
1359 {
1360         if (idx < 0 || idx >= XVECTOR_LENGTH(constants))
1361                 invalid_byte_code_error
1362                     ("reference %d to constants array out of range 0, %d",
1363                      idx, XVECTOR_LENGTH(constants) - 1);
1364 }
1365
1366 /* Get next character from Lisp instructions string. */
1367 #define READ_INSTRUCTION_CHAR(lvalue) do {              \
1368   (lvalue) = charptr_emchar (ptr);                      \
1369   INC_CHARPTR (ptr);                                    \
1370   *icounts_ptr++ = program_ptr - program;               \
1371   if (lvalue > UCHAR_MAX)                               \
1372     invalid_byte_code_error                             \
1373       ("Invalid character %c in byte code string");     \
1374 } while (0)
1375
1376 /* Get opcode from Lisp instructions string. */
1377 #define READ_OPCODE do {                \
1378   unsigned int c;                       \
1379   READ_INSTRUCTION_CHAR (c);            \
1380   opcode = (Opcode) c;                  \
1381 } while (0)
1382
1383 /* Get next operand, a uint8, from Lisp instructions string. */
1384 #define READ_OPERAND_1 do {             \
1385   READ_INSTRUCTION_CHAR (arg);          \
1386   argsize = 1;                          \
1387 } while (0)
1388
1389 /* Get next operand, a uint16, from Lisp instructions string. */
1390 #define READ_OPERAND_2 do {             \
1391   unsigned int arg1, arg2;              \
1392   READ_INSTRUCTION_CHAR (arg1);         \
1393   READ_INSTRUCTION_CHAR (arg2);         \
1394   arg = arg1 + (arg2 << 8);             \
1395   argsize = 2;                          \
1396 } while (0)
1397
1398 /* Write 1 byte to PTR, incrementing PTR */
1399 #define WRITE_INT8(value, ptr) do {     \
1400   *((ptr)++) = (value);                 \
1401 } while (0)
1402
1403 /* Write 2 bytes to PTR, incrementing PTR */
1404 #define WRITE_INT16(value, ptr) do {                    \
1405   WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr));    \
1406   WRITE_INT8 (((unsigned) (value)) >> 8    , (ptr));    \
1407 } while (0)
1408
1409 /* We've changed our minds about the opcode we've already written. */
1410 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1411
1412 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1413 #define WRITE_NARGS(base_opcode) do {           \
1414   if (arg <= 5)                                 \
1415     {                                           \
1416       REWRITE_OPCODE (base_opcode + arg);       \
1417     }                                           \
1418   else if (arg <= UCHAR_MAX)                    \
1419     {                                           \
1420       REWRITE_OPCODE (base_opcode + 6);         \
1421       WRITE_INT8 (arg, program_ptr);            \
1422     }                                           \
1423   else                                          \
1424     {                                           \
1425       REWRITE_OPCODE (base_opcode + 7);         \
1426       WRITE_INT16 (arg, program_ptr);           \
1427     }                                           \
1428 } while (0)
1429
1430 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1431 #define WRITE_CONSTANT do {                     \
1432   check_constants_index(arg, constants);        \
1433   if (arg <= UCHAR_MAX - Bconstant)             \
1434     {                                           \
1435       REWRITE_OPCODE (Bconstant + arg);         \
1436     }                                           \
1437   else                                          \
1438     {                                           \
1439       REWRITE_OPCODE (Bconstant2);              \
1440       WRITE_INT16 (arg, program_ptr);           \
1441     }                                           \
1442 } while (0)
1443
1444 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1445
1446 /* Compile byte code instructions into free space provided by caller, with
1447    size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1448    Returns length of compiled code. */
1449 static void optimize_byte_code(
1450         /* in */
1451         Lisp_Object instructions,
1452         Lisp_Object constants,
1453         /* out */
1454         Opbyte * const program,
1455         int *const program_length,
1456         int *const varbind_count)
1457 {
1458         size_t instructions_length = XSTRING_LENGTH(instructions);
1459         size_t comfy_size = 2 * instructions_length;
1460
1461         int *const icounts = alloca_array(int, comfy_size);
1462         int *icounts_ptr = icounts;
1463
1464         /* We maintain a table of jumps in the source code. */
1465         struct jump {
1466                 int from;
1467                 int to;
1468         };
1469         struct jump *const jumps = alloca_array(struct jump, comfy_size);
1470         struct jump *jumps_ptr = jumps;
1471
1472         Opbyte *program_ptr = program;
1473
1474         /* const means constant! */
1475         Bufbyte *ptr = XSTRING_DATA(instructions);
1476         const Bufbyte *const end = ptr + instructions_length;
1477
1478         *varbind_count = 0;
1479
1480         while (ptr < end) {
1481                 Opcode opcode;
1482                 int arg;
1483                 int argsize = 0;
1484                 READ_OPCODE;
1485                 WRITE_OPCODE;
1486
1487                 switch ((unsigned int)opcode) {
1488                         Lisp_Object val;
1489
1490                 case Bvarref + 7:
1491                         READ_OPERAND_2;
1492                         goto do_varref;
1493                 case Bvarref + 6:
1494                         READ_OPERAND_1;
1495                         goto do_varref;
1496                 case Bvarref:
1497                 case Bvarref + 1:
1498                 case Bvarref + 2:
1499                 case Bvarref + 3:
1500                 case Bvarref + 4:
1501                 case Bvarref + 5:
1502                         arg = opcode - Bvarref;
1503                       do_varref:
1504                         check_constants_index(arg, constants);
1505                         val = XVECTOR_DATA(constants)[arg];
1506                         if (!SYMBOLP(val))
1507                                 invalid_byte_code_error
1508                                     ("variable reference to non-symbol %S",
1509                                      val);
1510                         if (EQ(val, Qnil) || EQ(val, Qt)
1511                             || (SYMBOL_IS_KEYWORD(val)))
1512                                 invalid_byte_code_error
1513                                     ("variable reference to constant symbol %s",
1514                                      string_data(XSYMBOL(val)->name));
1515                         WRITE_NARGS(Bvarref);
1516                         break;
1517
1518                 case Bvarset + 7:
1519                         READ_OPERAND_2;
1520                         goto do_varset;
1521                 case Bvarset + 6:
1522                         READ_OPERAND_1;
1523                         goto do_varset;
1524                 case Bvarset:
1525                 case Bvarset + 1:
1526                 case Bvarset + 2:
1527                 case Bvarset + 3:
1528                 case Bvarset + 4:
1529                 case Bvarset + 5:
1530                         arg = opcode - Bvarset;
1531                       do_varset:
1532                         check_constants_index(arg, constants);
1533                         val = XVECTOR_DATA(constants)[arg];
1534                         if (!SYMBOLP(val))
1535                                 invalid_byte_code_error
1536                                     ("attempt to set non-symbol %S", val);
1537                         if (EQ(val, Qnil) || EQ(val, Qt))
1538                                 invalid_byte_code_error
1539                                     ("attempt to set constant symbol %s",
1540                                      string_data(XSYMBOL(val)->name));
1541                         /* Ignore assignments to keywords by converting to Bdiscard.
1542                            For backward compatibility only - we'd like to make this an error.  */
1543                         if (SYMBOL_IS_KEYWORD(val))
1544                                 REWRITE_OPCODE(Bdiscard);
1545                         else
1546                                 WRITE_NARGS(Bvarset);
1547                         break;
1548
1549                 case Bvarbind + 7:
1550                         READ_OPERAND_2;
1551                         goto do_varbind;
1552                 case Bvarbind + 6:
1553                         READ_OPERAND_1;
1554                         goto do_varbind;
1555                 case Bvarbind:
1556                 case Bvarbind + 1:
1557                 case Bvarbind + 2:
1558                 case Bvarbind + 3:
1559                 case Bvarbind + 4:
1560                 case Bvarbind + 5:
1561                         arg = opcode - Bvarbind;
1562                       do_varbind:
1563                         (*varbind_count)++;
1564                         check_constants_index(arg, constants);
1565                         val = XVECTOR_DATA(constants)[arg];
1566                         if (!SYMBOLP(val))
1567                                 invalid_byte_code_error
1568                                     ("attempt to let-bind non-symbol %S", val);
1569                         if (EQ(val, Qnil) || EQ(val, Qt)
1570                             || (SYMBOL_IS_KEYWORD(val)))
1571                                 invalid_byte_code_error
1572                                     ("attempt to let-bind constant symbol %s",
1573                                      string_data(XSYMBOL(val)->name));
1574                         WRITE_NARGS(Bvarbind);
1575                         break;
1576
1577                 case Bcall + 7:
1578                         READ_OPERAND_2;
1579                         goto do_call;
1580                 case Bcall + 6:
1581                         READ_OPERAND_1;
1582                         goto do_call;
1583                 case Bcall:
1584                 case Bcall + 1:
1585                 case Bcall + 2:
1586                 case Bcall + 3:
1587                 case Bcall + 4:
1588                 case Bcall + 5:
1589                         arg = opcode - Bcall;
1590                       do_call:
1591                         WRITE_NARGS(Bcall);
1592                         break;
1593
1594                 case Bunbind + 7:
1595                         READ_OPERAND_2;
1596                         goto do_unbind;
1597                 case Bunbind + 6:
1598                         READ_OPERAND_1;
1599                         goto do_unbind;
1600                 case Bunbind:
1601                 case Bunbind + 1:
1602                 case Bunbind + 2:
1603                 case Bunbind + 3:
1604                 case Bunbind + 4:
1605                 case Bunbind + 5:
1606                         arg = opcode - Bunbind;
1607                       do_unbind:
1608                         WRITE_NARGS(Bunbind);
1609                         break;
1610
1611                 case Bgoto:
1612                 case Bgotoifnil:
1613                 case Bgotoifnonnil:
1614                 case Bgotoifnilelsepop:
1615                 case Bgotoifnonnilelsepop:
1616                         READ_OPERAND_2;
1617                         /* Make program_ptr-relative */
1618                         arg += icounts - (icounts_ptr - argsize);
1619                         goto do_jump;
1620
1621                 case BRgoto:
1622                 case BRgotoifnil:
1623                 case BRgotoifnonnil:
1624                 case BRgotoifnilelsepop:
1625                 case BRgotoifnonnilelsepop:
1626                         READ_OPERAND_1;
1627                         /* Make program_ptr-relative */
1628                         arg -= 127;
1629                       do_jump:
1630                         /* Record program-relative goto addresses in `jumps' table */
1631                         jumps_ptr->from = icounts_ptr - icounts - argsize;
1632                         jumps_ptr->to = jumps_ptr->from + arg;
1633                         jumps_ptr++;
1634                         if (arg >= -1 && arg <= argsize)
1635                                 invalid_byte_code_error
1636                                     ("goto instruction is its own target");
1637                         if (arg <= SCHAR_MIN || arg > SCHAR_MAX) {
1638                                 if (argsize == 1)
1639                                         REWRITE_OPCODE(opcode + Bgoto - BRgoto);
1640                                 WRITE_INT16(arg, program_ptr);
1641                         } else {
1642                                 if (argsize == 2)
1643                                         REWRITE_OPCODE(opcode + BRgoto - Bgoto);
1644                                 WRITE_INT8(arg, program_ptr);
1645                         }
1646                         break;
1647
1648                 case Bconstant2:
1649                         READ_OPERAND_2;
1650                         WRITE_CONSTANT;
1651                         break;
1652
1653                 case BlistN:
1654                 case BconcatN:
1655                 case BinsertN:
1656                         READ_OPERAND_1;
1657                         WRITE_INT8(arg, program_ptr);
1658                         break;
1659
1660                 default:
1661                         if (opcode < Bconstant)
1662                                 check_opcode(opcode);
1663                         else {
1664                                 arg = opcode - Bconstant;
1665                                 WRITE_CONSTANT;
1666                         }
1667                         break;
1668                 }
1669         }
1670
1671         /* Fix up jumps table to refer to NEW offsets. */
1672         for (struct jump *j = jumps; j < jumps_ptr; j++) {
1673 #ifdef ERROR_CHECK_BYTE_CODE
1674                 assert(j->from < icounts_ptr - icounts);
1675                 assert(j->to < icounts_ptr - icounts);
1676 #endif
1677                 j->from = icounts[j->from];
1678                 j->to = icounts[j->to];
1679 #ifdef ERROR_CHECK_BYTE_CODE
1680                 assert(j->from < program_ptr - program);
1681                 assert(j->to < program_ptr - program);
1682                 check_opcode((Opcode) (program[j->from - 1]));
1683 #endif
1684                 check_opcode((Opcode) (program[j->to]));
1685         }
1686
1687         /* Fixup jumps in byte-code until no more fixups needed */
1688         for (bool more_fixups_needed = true; more_fixups_needed; ) {
1689                 struct jump *j;
1690
1691                 /* assume we don't need more hiccups */
1692                 more_fixups_needed = false;
1693                 for (j = jumps; j < jumps_ptr; j++) {
1694                         int from = j->from;
1695                         int to = j->to;
1696                         int jump = to - from;
1697                         Opbyte *p = program + from;
1698                         Opcode opcode = (Opcode)p[-1];
1699
1700                         if (!more_fixups_needed) {
1701                                 check_opcode((Opcode) p[jump]);
1702                         }
1703                         assert(to >= 0 && program + to < program_ptr);
1704
1705                         switch ((unsigned int)opcode) {
1706                         case Bgoto:
1707                         case Bgotoifnil:
1708                         case Bgotoifnonnil:
1709                         case Bgotoifnilelsepop:
1710                         case Bgotoifnonnilelsepop:
1711                                 WRITE_INT16(jump, p);
1712                                 break;
1713
1714                         case BRgoto:
1715                         case BRgotoifnil:
1716                         case BRgotoifnonnil:
1717                         case BRgotoifnilelsepop:
1718                         case BRgotoifnonnilelsepop:
1719                                 if (jump > SCHAR_MIN && jump <= SCHAR_MAX) {
1720                                         WRITE_INT8(jump, p);
1721                                 } else {
1722                                         /* barf */
1723                                         struct jump *jj;
1724
1725                                         for (jj = jumps; jj < jumps_ptr; jj++) {
1726                                                 assert(jj->from <
1727                                                        program_ptr - program);
1728                                                 assert(jj->to <
1729                                                        program_ptr - program);
1730                                                 if (jj->from > from) {
1731                                                         jj->from++;
1732                                                 }
1733                                                 if (jj->to > from) {
1734                                                         jj->to++;
1735                                                 }
1736                                         }
1737                                         p[-1] += Bgoto - BRgoto;
1738                                         more_fixups_needed = true;
1739                                         memmove(p + 1, p, program_ptr++ - p);
1740                                         WRITE_INT16(jump, p);
1741                                 }
1742                                 break;
1743
1744                         default:
1745                                 abort();
1746                                 break;
1747                         }
1748                 }
1749         }
1750
1751         /* *program_ptr++ = 0; */
1752         *program_length = program_ptr - program;
1753 }
1754
1755 /* Optimize the byte code and store the optimized program, only
1756    understood by bytecode.c, in an opaque object in the
1757    instructions slot of the Compiled_Function object. */
1758 void optimize_compiled_function(Lisp_Object compiled_function)
1759 {
1760         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(compiled_function);
1761         int program_length;
1762         int varbind_count;
1763         Opbyte *program;
1764
1765         /* If we have not actually read the bytecode string
1766            and constants vector yet, fetch them from the file.  */
1767         if (CONSP(f->instructions))
1768                 Ffetch_bytecode(compiled_function);
1769
1770         if (STRINGP(f->instructions)) {
1771                 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1772                    which would be slightly more `proper' */
1773                 program =
1774                     alloca_array(Opbyte,
1775                                  1 + 2 * XSTRING_LENGTH(f->instructions));
1776                 optimize_byte_code(f->instructions, f->constants, program,
1777                                    &program_length, &varbind_count);
1778                 f->specpdl_depth = XINT(Flength(f->arglist)) + varbind_count;
1779                 f->instructions =
1780                     make_opaque(program, program_length * sizeof(Opbyte));
1781         }
1782
1783         assert(OPAQUEP(f->instructions));
1784 }
1785 \f
1786 /************************************************************************/
1787 /*              The compiled-function object type                       */
1788 /************************************************************************/
1789 static void
1790 print_compiled_function(Lisp_Object obj, Lisp_Object printcharfun,
1791                         int escapeflag)
1792 {
1793         /* This function can GC */
1794         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);    /* GC doesn't relocate */
1795         int docp = f->flags.documentationp;
1796         int intp = f->flags.interactivep;
1797         struct gcpro gcpro1, gcpro2;
1798         GCPRO2(obj, printcharfun);
1799
1800         write_c_string(print_readably ? "#[" : "#<compiled-function ",
1801                        printcharfun);
1802 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1803         if (!print_readably) {
1804                 Lisp_Object ann = compiled_function_annotation(f);
1805                 if (!NILP(ann)) {
1806                         write_c_string("(from ", printcharfun);
1807                         print_internal(ann, printcharfun, 1);
1808                         write_c_string(") ", printcharfun);
1809                 }
1810         }
1811 #endif                          /* COMPILED_FUNCTION_ANNOTATION_HACK */
1812         /* COMPILED_ARGLIST = 0 */
1813         print_internal(compiled_function_arglist(f), printcharfun, escapeflag);
1814
1815         /* COMPILED_INSTRUCTIONS = 1 */
1816         write_c_string(" ", printcharfun);
1817         {
1818                 struct gcpro ngcpro1;
1819                 Lisp_Object instructions = compiled_function_instructions(f);
1820                 NGCPRO1(instructions);
1821                 if (STRINGP(instructions) && !print_readably) {
1822                         /* We don't usually want to see that junk in the bytecode. */
1823                         write_fmt_str(printcharfun, "\"...(%ld)\"",
1824                                       (long)XSTRING_CHAR_LENGTH(instructions));
1825                 } else
1826                         print_internal(instructions, printcharfun, escapeflag);
1827                 NUNGCPRO;
1828         }
1829
1830         /* COMPILED_CONSTANTS = 2 */
1831         write_c_string(" ", printcharfun);
1832         print_internal(compiled_function_constants(f), printcharfun,
1833                        escapeflag);
1834
1835         /* COMPILED_STACK_DEPTH = 3 */
1836         write_fmt_str(printcharfun, " %d", compiled_function_stack_depth(f));
1837
1838         /* COMPILED_DOC_STRING = 4 */
1839         if (docp || intp) {
1840                 write_c_string(" ", printcharfun);
1841                 print_internal(compiled_function_documentation(f), printcharfun,
1842                                escapeflag);
1843         }
1844
1845         /* COMPILED_INTERACTIVE = 5 */
1846         if (intp) {
1847                 write_c_string(" ", printcharfun);
1848                 print_internal(compiled_function_interactive(f), printcharfun,
1849                                escapeflag);
1850         }
1851
1852         UNGCPRO;
1853         write_c_string(print_readably ? "]" : ">", printcharfun);
1854 }
1855
1856 static Lisp_Object mark_compiled_function(Lisp_Object obj)
1857 {
1858         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1859
1860         mark_object(f->instructions);
1861         mark_object(f->arglist);
1862         mark_object(f->doc_and_interactive);
1863 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1864         mark_object(f->annotated);
1865 #endif
1866         /* tail-recurse on constants */
1867         return f->constants;
1868 }
1869
1870 static int
1871 compiled_function_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1872 {
1873         Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION(obj1);
1874         Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION(obj2);
1875         return (f1->flags.documentationp == f2->flags.documentationp && f1->flags.interactivep == f2->flags.interactivep && f1->flags.domainp == f2->flags.domainp &&   /* I18N3 */
1876                 internal_equal(compiled_function_instructions(f1),
1877                                compiled_function_instructions(f2), depth + 1) &&
1878                 internal_equal(f1->constants, f2->constants, depth + 1) &&
1879                 internal_equal(f1->arglist, f2->arglist, depth + 1) &&
1880                 internal_equal(f1->doc_and_interactive,
1881                                f2->doc_and_interactive, depth + 1));
1882 }
1883
1884 static unsigned long compiled_function_hash(Lisp_Object obj, int depth)
1885 {
1886         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1887         return HASH3((f->flags.documentationp << 2) +
1888                      (f->flags.interactivep << 1) +
1889                      f->flags.domainp,
1890                      internal_hash(f->instructions, depth + 1),
1891                      internal_hash(f->constants, depth + 1));
1892 }
1893
1894 static const struct lrecord_description compiled_function_description[] = {
1895         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, instructions)},
1896         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, constants)},
1897         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, arglist)},
1898         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, doc_and_interactive)},
1899 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1900         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, annotated)},
1901 #endif
1902         {XD_END}
1903 };
1904
1905 DEFINE_BASIC_LRECORD_IMPLEMENTATION("compiled-function", compiled_function,
1906                                     mark_compiled_function,
1907                                     print_compiled_function, 0,
1908                                     compiled_function_equal,
1909                                     compiled_function_hash,
1910                                     compiled_function_description,
1911                                     Lisp_Compiled_Function);
1912 \f
1913 DEFUN("compiled-function-p", Fcompiled_function_p, 1, 1, 0,     /*
1914 Return t if OBJECT is a byte-compiled function object.
1915 */
1916       (object))
1917 {
1918         return COMPILED_FUNCTIONP(object) ? Qt : Qnil;
1919 }
1920
1921 /************************************************************************/
1922 /*              compiled-function object accessor functions             */
1923 /************************************************************************/
1924
1925 Lisp_Object compiled_function_arglist(Lisp_Compiled_Function * f)
1926 {
1927         return f->arglist;
1928 }
1929
1930 Lisp_Object compiled_function_instructions(Lisp_Compiled_Function * f)
1931 {
1932         if (!OPAQUEP(f->instructions))
1933                 return f->instructions;
1934
1935         {
1936                 /* Invert action performed by optimize_byte_code() */
1937                 Lisp_Opaque *opaque = XOPAQUE(f->instructions);
1938
1939                 Bufbyte *const buffer =
1940                     alloca_array(Bufbyte, OPAQUE_SIZE(opaque) * MAX_EMCHAR_LEN);
1941                 Bufbyte *bp = buffer;
1942
1943                 const Opbyte *const program =
1944                     (const Opbyte *)OPAQUE_DATA(opaque);
1945                 const Opbyte *program_ptr = program;
1946                 const Opbyte *const program_end =
1947                     program_ptr + OPAQUE_SIZE(opaque);
1948
1949                 while (program_ptr < program_end) {
1950                         Opcode opcode = (Opcode) READ_UINT_1;
1951                         bp += set_charptr_emchar(bp, opcode);
1952
1953                         switch ((unsigned int)opcode) {
1954                         case Bvarref + 7:
1955                         case Bvarset + 7:
1956                         case Bvarbind + 7:
1957                         case Bcall + 7:
1958                         case Bunbind + 7:
1959                         case Bconstant2:
1960                                 bp += set_charptr_emchar(bp, READ_UINT_1);
1961                                 bp += set_charptr_emchar(bp, READ_UINT_1);
1962                                 break;
1963
1964                         case Bvarref + 6:
1965                         case Bvarset + 6:
1966                         case Bvarbind + 6:
1967                         case Bcall + 6:
1968                         case Bunbind + 6:
1969                         case BlistN:
1970                         case BconcatN:
1971                         case BinsertN:
1972                                 bp += set_charptr_emchar(bp, READ_UINT_1);
1973                                 break;
1974
1975                         case Bgoto:
1976                         case Bgotoifnil:
1977                         case Bgotoifnonnil:
1978                         case Bgotoifnilelsepop:
1979                         case Bgotoifnonnilelsepop:
1980                                 {
1981                                         int jump = READ_INT_2;
1982                                         Opbyte buf2[2];
1983                                         Opbyte *buf2p = buf2;
1984                                         /* Convert back to program-relative address */
1985                                         WRITE_INT16(jump +
1986                                                     (program_ptr - 2 - program),
1987                                                     buf2p);
1988                                         bp += set_charptr_emchar(bp, buf2[0]);
1989                                         bp += set_charptr_emchar(bp, buf2[1]);
1990                                         break;
1991                                 }
1992
1993                         case BRgoto:
1994                         case BRgotoifnil:
1995                         case BRgotoifnonnil:
1996                         case BRgotoifnilelsepop:
1997                         case BRgotoifnonnilelsepop:
1998                                 bp += set_charptr_emchar(bp, READ_INT_1 + 127);
1999                                 break;
2000
2001                         default:
2002                                 break;
2003                         }
2004                 }
2005                 return make_string(buffer, bp - buffer);
2006         }
2007 }
2008
2009 Lisp_Object compiled_function_constants(Lisp_Compiled_Function * f)
2010 {
2011         return f->constants;
2012 }
2013
2014 int compiled_function_stack_depth(Lisp_Compiled_Function * f)
2015 {
2016         return f->stack_depth;
2017 }
2018
2019 /* The compiled_function->doc_and_interactive slot uses the minimal
2020    number of conses, based on compiled_function->flags; it may take
2021    any of the following forms:
2022
2023         doc
2024         interactive
2025         domain
2026         (doc . interactive)
2027         (doc . domain)
2028         (interactive . domain)
2029         (doc . (interactive . domain))
2030  */
2031
2032 /* Caller must check flags.interactivep first */
2033 Lisp_Object compiled_function_interactive(Lisp_Compiled_Function * f)
2034 {
2035         assert(f->flags.interactivep);
2036         if (f->flags.documentationp && f->flags.domainp)
2037                 return XCAR(XCDR(f->doc_and_interactive));
2038         else if (f->flags.documentationp)
2039                 return XCDR(f->doc_and_interactive);
2040         else if (f->flags.domainp)
2041                 return XCAR(f->doc_and_interactive);
2042         else
2043                 return f->doc_and_interactive;
2044 }
2045
2046 /* Caller need not check flags.documentationp first */
2047 Lisp_Object compiled_function_documentation(Lisp_Compiled_Function * f)
2048 {
2049         if (!f->flags.documentationp)
2050                 return Qnil;
2051         else if (f->flags.interactivep && f->flags.domainp)
2052                 return XCAR(f->doc_and_interactive);
2053         else if (f->flags.interactivep)
2054                 return XCAR(f->doc_and_interactive);
2055         else if (f->flags.domainp)
2056                 return XCAR(f->doc_and_interactive);
2057         else
2058                 return f->doc_and_interactive;
2059 }
2060
2061 /* Caller need not check flags.domainp first */
2062 Lisp_Object compiled_function_domain(Lisp_Compiled_Function * f)
2063 {
2064         if (!f->flags.domainp)
2065                 return Qnil;
2066         else if (f->flags.documentationp && f->flags.interactivep)
2067                 return XCDR(XCDR(f->doc_and_interactive));
2068         else if (f->flags.documentationp)
2069                 return XCDR(f->doc_and_interactive);
2070         else if (f->flags.interactivep)
2071                 return XCDR(f->doc_and_interactive);
2072         else
2073                 return f->doc_and_interactive;
2074 }
2075
2076 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2077
2078 Lisp_Object compiled_function_annotation(Lisp_Compiled_Function * f)
2079 {
2080         return f->annotated;
2081 }
2082
2083 #endif
2084
2085 /* used only by Snarf-documentation; there must be doc already. */
2086 void
2087 set_compiled_function_documentation(Lisp_Compiled_Function * f,
2088                                     Lisp_Object new_doc)
2089 {
2090         assert(f->flags.documentationp);
2091         assert(INTP(new_doc) || STRINGP(new_doc));
2092
2093         if (f->flags.interactivep && f->flags.domainp)
2094                 XCAR(f->doc_and_interactive) = new_doc;
2095         else if (f->flags.interactivep)
2096                 XCAR(f->doc_and_interactive) = new_doc;
2097         else if (f->flags.domainp)
2098                 XCAR(f->doc_and_interactive) = new_doc;
2099         else
2100                 f->doc_and_interactive = new_doc;
2101 }
2102
2103 DEFUN("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2104 Return the argument list of the compiled-function object FUNCTION.
2105 */
2106       (function))
2107 {
2108         CHECK_COMPILED_FUNCTION(function);
2109         return compiled_function_arglist(XCOMPILED_FUNCTION(function));
2110 }
2111
2112 DEFUN("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0,       /*
2113 Return the byte-opcode string of the compiled-function object FUNCTION.
2114 */
2115       (function))
2116 {
2117         CHECK_COMPILED_FUNCTION(function);
2118         return compiled_function_instructions(XCOMPILED_FUNCTION(function));
2119 }
2120
2121 DEFUN("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0,     /*
2122 Return the constants vector of the compiled-function object FUNCTION.
2123 */
2124       (function))
2125 {
2126         CHECK_COMPILED_FUNCTION(function);
2127         return compiled_function_constants(XCOMPILED_FUNCTION(function));
2128 }
2129
2130 DEFUN("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2131 Return the maximum stack depth of the compiled-function object FUNCTION.
2132 */
2133       (function))
2134 {
2135         CHECK_COMPILED_FUNCTION(function);
2136         return
2137             make_int(compiled_function_stack_depth
2138                      (XCOMPILED_FUNCTION(function)));
2139 }
2140
2141 DEFUN("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0,   /*
2142 Return the doc string of the compiled-function object FUNCTION, if available.
2143 Functions that had their doc strings snarfed into the DOC file will have
2144 an integer returned instead of a string.
2145 */
2146       (function))
2147 {
2148         CHECK_COMPILED_FUNCTION(function);
2149         return compiled_function_documentation(XCOMPILED_FUNCTION(function));
2150 }
2151
2152 DEFUN("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2153 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2154 If non-nil, the return value will be a list whose first element is
2155 `interactive' and whose second element is the interactive spec.
2156 */
2157       (function))
2158 {
2159         CHECK_COMPILED_FUNCTION(function);
2160         return XCOMPILED_FUNCTION(function)->flags.interactivep
2161             ? list2(Qinteractive,
2162                     compiled_function_interactive(XCOMPILED_FUNCTION(function)))
2163             : Qnil;
2164 }
2165
2166 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2167
2168 /* Remove the `xx' if you wish to restore this feature */
2169 xxDEFUN("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2170 Return the annotation of the compiled-function object FUNCTION, or nil.
2171 The annotation is a piece of information indicating where this
2172 compiled-function object came from.  Generally this will be
2173 a symbol naming a function; or a string naming a file, if the
2174 compiled-function object was not defined in a function; or nil,
2175 if the compiled-function object was not created as a result of
2176 a `load'.
2177                                                                                  */
2178         (function)) {
2179         CHECK_COMPILED_FUNCTION(function);
2180         return compiled_function_annotation(XCOMPILED_FUNCTION(function));
2181 }
2182
2183 #endif                          /* COMPILED_FUNCTION_ANNOTATION_HACK */
2184
2185 DEFUN("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0,   /*
2186 Return the domain of the compiled-function object FUNCTION, or nil.
2187 This is only meaningful if I18N3 was enabled when emacs was compiled.
2188 */
2189       (function))
2190 {
2191         CHECK_COMPILED_FUNCTION(function);
2192         return XCOMPILED_FUNCTION(function)->flags.domainp
2193             ? compiled_function_domain(XCOMPILED_FUNCTION(function))
2194             : Qnil;
2195 }
2196 \f
2197 DEFUN("fetch-bytecode", Ffetch_bytecode, 1, 1, 0,       /*
2198 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2199 */
2200       (function))
2201 {
2202         Lisp_Compiled_Function *f;
2203         CHECK_COMPILED_FUNCTION(function);
2204         f = XCOMPILED_FUNCTION(function);
2205
2206         if (OPAQUEP(f->instructions) || STRINGP(f->instructions))
2207                 return function;
2208
2209         if (CONSP(f->instructions)) {
2210                 Lisp_Object tem = read_doc_string(f->instructions);
2211                 if (!CONSP(tem))
2212                         signal_simple_error("Invalid lazy-loaded byte code",
2213                                             tem);
2214                 /* v18 or v19 bytecode file.  Need to Ebolify. */
2215                 if (f->flags.ebolified && VECTORP(XCDR(tem)))
2216                         ebolify_bytecode_constants(XCDR(tem));
2217                 f->instructions = XCAR(tem);
2218                 f->constants = XCDR(tem);
2219                 return function;
2220         }
2221         abort();
2222         return Qnil;            /* not reached */
2223 }
2224
2225 DEFUN("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0,       /*
2226 Convert compiled function FUNCTION into an optimized internal form.
2227 */
2228       (function))
2229 {
2230         Lisp_Compiled_Function *f;
2231         CHECK_COMPILED_FUNCTION(function);
2232         f = XCOMPILED_FUNCTION(function);
2233
2234         if (OPAQUEP(f->instructions))   /* Already optimized? */
2235                 return Qnil;
2236
2237         optimize_compiled_function(function);
2238         return Qnil;
2239 }
2240
2241 DEFUN("byte-code", Fbyte_code, 3, 3, 0, /*
2242 Function used internally in byte-compiled code.
2243 First argument INSTRUCTIONS is a string of byte code.
2244 Second argument CONSTANTS is a vector of constants.
2245 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2246 If STACK-DEPTH is incorrect, Emacs may crash.
2247 */
2248       (instructions, constants, stack_depth))
2249 {
2250         /* This function can GC */
2251         int varbind_count;
2252         int program_length;
2253         Opbyte *program;
2254
2255         CHECK_STRING(instructions);
2256         CHECK_VECTOR(constants);
2257         CHECK_NATNUM(stack_depth);
2258
2259         /* Optimize the `instructions' string, just like when executing a
2260            regular compiled function, but don't save it for later since this is
2261            likely to only be executed once. */
2262         program = alloca_array(Opbyte, 1 + 2 * XSTRING_LENGTH(instructions));
2263         optimize_byte_code(instructions, constants, program,
2264                            &program_length, &varbind_count);
2265         SPECPDL_RESERVE(varbind_count);
2266         return execute_optimized_program(program,
2267                                          XINT(stack_depth),
2268                                          XVECTOR_DATA(constants));
2269 }
2270 \f
2271 void syms_of_bytecode(void)
2272 {
2273         INIT_LRECORD_IMPLEMENTATION(compiled_function);
2274
2275         DEFERROR_STANDARD(Qinvalid_byte_code, Qinvalid_state);
2276         defsymbol(&Qbyte_code, "byte-code");
2277         defsymbol(&Qcompiled_functionp, "compiled-function-p");
2278
2279         DEFSUBR(Fbyte_code);
2280         DEFSUBR(Ffetch_bytecode);
2281         DEFSUBR(Foptimize_compiled_function);
2282
2283         DEFSUBR(Fcompiled_function_p);
2284         DEFSUBR(Fcompiled_function_instructions);
2285         DEFSUBR(Fcompiled_function_constants);
2286         DEFSUBR(Fcompiled_function_stack_depth);
2287         DEFSUBR(Fcompiled_function_arglist);
2288         DEFSUBR(Fcompiled_function_interactive);
2289         DEFSUBR(Fcompiled_function_doc_string);
2290         DEFSUBR(Fcompiled_function_domain);
2291 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2292         DEFSUBR(Fcompiled_function_annotation);
2293 #endif
2294
2295 #ifdef BYTE_CODE_METER
2296         defsymbol(&Qbyte_code_meter, "byte-code-meter");
2297 #endif
2298 }
2299
2300 void vars_of_bytecode(void)
2301 {
2302 #ifdef BYTE_CODE_METER
2303
2304         DEFVAR_LISP("byte-code-meter", &Vbyte_code_meter        /*
2305 A vector of vectors which holds a histogram of byte code usage.
2306 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2307 opcode CODE has been executed.
2308 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2309 indicates how many times the byte opcodes CODE1 and CODE2 have been
2310 executed in succession.
2311                                                                  */ );
2312         DEFVAR_BOOL("byte-metering-on", &byte_metering_on       /*
2313 If non-nil, keep profiling information on byte code usage.
2314 The variable `byte-code-meter' indicates how often each byte opcode is used.
2315 If a symbol has a property named `byte-code-meter' whose value is an
2316 integer, it is incremented each time that symbol's function is called.
2317                                                                  */ );
2318
2319         byte_metering_on = 0;
2320         Vbyte_code_meter = make_vector(256, Qzero);
2321         {
2322                 int i = 256;
2323                 while (i--)
2324                         XVECTOR_DATA(Vbyte_code_meter)[i] =
2325                             make_vector(256, Qzero);
2326         }
2327 #endif                          /* BYTE_CODE_METER */
2328 }