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

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