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         int maxsz = strlen(error_message) + 128;
1332         char *buf = alloca_array(char, maxsz);
1333
1334         int sz=snprintf(buf, maxsz, "%s", error_message);
1335         assert(sz>=0 && sz<maxsz);
1336         va_start(args, error_message);
1337         obj = emacs_doprnt_string_va((const Bufbyte *)GETTEXT(buf), Qnil, -1,
1338                                      args);
1339         va_end(args);
1340
1341         signal_error(Qinvalid_byte_code, list1(obj));
1342 }
1343
1344 /* Check for valid opcodes.  Change this when adding new opcodes.  */
1345 static void check_opcode(Opcode opcode)
1346 {
1347         if ((opcode < Bvarref) ||
1348             (opcode == 0251) ||
1349             (opcode > BLAST_BEFORE_THREE_O_O && opcode < Bconstant))
1350                 invalid_byte_code_error
1351                     ("invalid opcode %d in instruction stream", opcode);
1352 }
1353
1354 /* Check that IDX is a valid offset into the `constants' vector */
1355 static void check_constants_index(int idx, Lisp_Object constants)
1356 {
1357         if (idx < 0 || idx >= XVECTOR_LENGTH(constants))
1358                 invalid_byte_code_error
1359                     ("reference %d to constants array out of range 0, %d",
1360                      idx, XVECTOR_LENGTH(constants) - 1);
1361 }
1362
1363 /* Get next character from Lisp instructions string. */
1364 #define READ_INSTRUCTION_CHAR(lvalue) do {              \
1365   (lvalue) = charptr_emchar (ptr);                      \
1366   INC_CHARPTR (ptr);                                    \
1367   *icounts_ptr++ = program_ptr - program;               \
1368   if (lvalue > UCHAR_MAX)                               \
1369     invalid_byte_code_error                             \
1370       ("Invalid character %c in byte code string");     \
1371 } while (0)
1372
1373 /* Get opcode from Lisp instructions string. */
1374 #define READ_OPCODE do {                \
1375   unsigned int c;                       \
1376   READ_INSTRUCTION_CHAR (c);            \
1377   opcode = (Opcode) c;                  \
1378 } while (0)
1379
1380 /* Get next operand, a uint8, from Lisp instructions string. */
1381 #define READ_OPERAND_1 do {             \
1382   READ_INSTRUCTION_CHAR (arg);          \
1383   argsize = 1;                          \
1384 } while (0)
1385
1386 /* Get next operand, a uint16, from Lisp instructions string. */
1387 #define READ_OPERAND_2 do {             \
1388   unsigned int arg1, arg2;              \
1389   READ_INSTRUCTION_CHAR (arg1);         \
1390   READ_INSTRUCTION_CHAR (arg2);         \
1391   arg = arg1 + (arg2 << 8);             \
1392   argsize = 2;                          \
1393 } while (0)
1394
1395 /* Write 1 byte to PTR, incrementing PTR */
1396 #define WRITE_INT8(value, ptr) do {     \
1397   *((ptr)++) = (value);                 \
1398 } while (0)
1399
1400 /* Write 2 bytes to PTR, incrementing PTR */
1401 #define WRITE_INT16(value, ptr) do {                    \
1402   WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr));    \
1403   WRITE_INT8 (((unsigned) (value)) >> 8    , (ptr));    \
1404 } while (0)
1405
1406 /* We've changed our minds about the opcode we've already written. */
1407 #define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode))
1408
1409 /* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */
1410 #define WRITE_NARGS(base_opcode) do {           \
1411   if (arg <= 5)                                 \
1412     {                                           \
1413       REWRITE_OPCODE (base_opcode + arg);       \
1414     }                                           \
1415   else if (arg <= UCHAR_MAX)                    \
1416     {                                           \
1417       REWRITE_OPCODE (base_opcode + 6);         \
1418       WRITE_INT8 (arg, program_ptr);            \
1419     }                                           \
1420   else                                          \
1421     {                                           \
1422       REWRITE_OPCODE (base_opcode + 7);         \
1423       WRITE_INT16 (arg, program_ptr);           \
1424     }                                           \
1425 } while (0)
1426
1427 /* Encode a constants reference within the opcode, or as a 2-byte operand. */
1428 #define WRITE_CONSTANT do {                     \
1429   check_constants_index(arg, constants);        \
1430   if (arg <= UCHAR_MAX - Bconstant)             \
1431     {                                           \
1432       REWRITE_OPCODE (Bconstant + arg);         \
1433     }                                           \
1434   else                                          \
1435     {                                           \
1436       REWRITE_OPCODE (Bconstant2);              \
1437       WRITE_INT16 (arg, program_ptr);           \
1438     }                                           \
1439 } while (0)
1440
1441 #define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr)
1442
1443 /* Compile byte code instructions into free space provided by caller, with
1444    size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte).
1445    Returns length of compiled code. */
1446 static void optimize_byte_code(
1447         /* in */
1448         Lisp_Object instructions,
1449         Lisp_Object constants,
1450         /* out */
1451         Opbyte * const program,
1452         int *const program_length,
1453         int *const varbind_count)
1454 {
1455         size_t instructions_length = XSTRING_LENGTH(instructions);
1456         size_t comfy_size = 2 * instructions_length;
1457
1458         int *const icounts = alloca_array(int, comfy_size);
1459         int *icounts_ptr = icounts;
1460
1461         /* We maintain a table of jumps in the source code. */
1462         struct jump {
1463                 int from;
1464                 int to;
1465         };
1466         struct jump *const jumps = alloca_array(struct jump, comfy_size);
1467         struct jump *jumps_ptr = jumps;
1468
1469         Opbyte *program_ptr = program;
1470
1471         /* const means constant! */
1472         Bufbyte *ptr = XSTRING_DATA(instructions);
1473         const Bufbyte *const end = ptr + instructions_length;
1474
1475         *varbind_count = 0;
1476
1477         while (ptr < end) {
1478                 Opcode opcode;
1479                 int arg;
1480                 int argsize = 0;
1481                 READ_OPCODE;
1482                 WRITE_OPCODE;
1483
1484                 switch ((unsigned int)opcode) {
1485                         Lisp_Object val;
1486
1487                 case Bvarref + 7:
1488                         READ_OPERAND_2;
1489                         goto do_varref;
1490                 case Bvarref + 6:
1491                         READ_OPERAND_1;
1492                         goto do_varref;
1493                 case Bvarref:
1494                 case Bvarref + 1:
1495                 case Bvarref + 2:
1496                 case Bvarref + 3:
1497                 case Bvarref + 4:
1498                 case Bvarref + 5:
1499                         arg = opcode - Bvarref;
1500                       do_varref:
1501                         check_constants_index(arg, constants);
1502                         val = XVECTOR_DATA(constants)[arg];
1503                         if (!SYMBOLP(val))
1504                                 invalid_byte_code_error
1505                                     ("variable reference to non-symbol %S",
1506                                      val);
1507                         if (EQ(val, Qnil) || EQ(val, Qt)
1508                             || (SYMBOL_IS_KEYWORD(val)))
1509                                 invalid_byte_code_error
1510                                     ("variable reference to constant symbol %s",
1511                                      string_data(XSYMBOL(val)->name));
1512                         WRITE_NARGS(Bvarref);
1513                         break;
1514
1515                 case Bvarset + 7:
1516                         READ_OPERAND_2;
1517                         goto do_varset;
1518                 case Bvarset + 6:
1519                         READ_OPERAND_1;
1520                         goto do_varset;
1521                 case Bvarset:
1522                 case Bvarset + 1:
1523                 case Bvarset + 2:
1524                 case Bvarset + 3:
1525                 case Bvarset + 4:
1526                 case Bvarset + 5:
1527                         arg = opcode - Bvarset;
1528                       do_varset:
1529                         check_constants_index(arg, constants);
1530                         val = XVECTOR_DATA(constants)[arg];
1531                         if (!SYMBOLP(val))
1532                                 invalid_byte_code_error
1533                                     ("attempt to set non-symbol %S", val);
1534                         if (EQ(val, Qnil) || EQ(val, Qt))
1535                                 invalid_byte_code_error
1536                                     ("attempt to set constant symbol %s",
1537                                      string_data(XSYMBOL(val)->name));
1538                         /* Ignore assignments to keywords by converting to Bdiscard.
1539                            For backward compatibility only - we'd like to make this an error.  */
1540                         if (SYMBOL_IS_KEYWORD(val))
1541                                 REWRITE_OPCODE(Bdiscard);
1542                         else
1543                                 WRITE_NARGS(Bvarset);
1544                         break;
1545
1546                 case Bvarbind + 7:
1547                         READ_OPERAND_2;
1548                         goto do_varbind;
1549                 case Bvarbind + 6:
1550                         READ_OPERAND_1;
1551                         goto do_varbind;
1552                 case Bvarbind:
1553                 case Bvarbind + 1:
1554                 case Bvarbind + 2:
1555                 case Bvarbind + 3:
1556                 case Bvarbind + 4:
1557                 case Bvarbind + 5:
1558                         arg = opcode - Bvarbind;
1559                       do_varbind:
1560                         (*varbind_count)++;
1561                         check_constants_index(arg, constants);
1562                         val = XVECTOR_DATA(constants)[arg];
1563                         if (!SYMBOLP(val))
1564                                 invalid_byte_code_error
1565                                     ("attempt to let-bind non-symbol %S", val);
1566                         if (EQ(val, Qnil) || EQ(val, Qt)
1567                             || (SYMBOL_IS_KEYWORD(val)))
1568                                 invalid_byte_code_error
1569                                     ("attempt to let-bind constant symbol %s",
1570                                      string_data(XSYMBOL(val)->name));
1571                         WRITE_NARGS(Bvarbind);
1572                         break;
1573
1574                 case Bcall + 7:
1575                         READ_OPERAND_2;
1576                         goto do_call;
1577                 case Bcall + 6:
1578                         READ_OPERAND_1;
1579                         goto do_call;
1580                 case Bcall:
1581                 case Bcall + 1:
1582                 case Bcall + 2:
1583                 case Bcall + 3:
1584                 case Bcall + 4:
1585                 case Bcall + 5:
1586                         arg = opcode - Bcall;
1587                       do_call:
1588                         WRITE_NARGS(Bcall);
1589                         break;
1590
1591                 case Bunbind + 7:
1592                         READ_OPERAND_2;
1593                         goto do_unbind;
1594                 case Bunbind + 6:
1595                         READ_OPERAND_1;
1596                         goto do_unbind;
1597                 case Bunbind:
1598                 case Bunbind + 1:
1599                 case Bunbind + 2:
1600                 case Bunbind + 3:
1601                 case Bunbind + 4:
1602                 case Bunbind + 5:
1603                         arg = opcode - Bunbind;
1604                       do_unbind:
1605                         WRITE_NARGS(Bunbind);
1606                         break;
1607
1608                 case Bgoto:
1609                 case Bgotoifnil:
1610                 case Bgotoifnonnil:
1611                 case Bgotoifnilelsepop:
1612                 case Bgotoifnonnilelsepop:
1613                         READ_OPERAND_2;
1614                         /* Make program_ptr-relative */
1615                         arg += icounts - (icounts_ptr - argsize);
1616                         goto do_jump;
1617
1618                 case BRgoto:
1619                 case BRgotoifnil:
1620                 case BRgotoifnonnil:
1621                 case BRgotoifnilelsepop:
1622                 case BRgotoifnonnilelsepop:
1623                         READ_OPERAND_1;
1624                         /* Make program_ptr-relative */
1625                         arg -= 127;
1626                       do_jump:
1627                         /* Record program-relative goto addresses in `jumps' table */
1628                         jumps_ptr->from = icounts_ptr - icounts - argsize;
1629                         jumps_ptr->to = jumps_ptr->from + arg;
1630                         jumps_ptr++;
1631                         if (arg >= -1 && arg <= argsize)
1632                                 invalid_byte_code_error
1633                                     ("goto instruction is its own target");
1634                         if (arg <= SCHAR_MIN || arg > SCHAR_MAX) {
1635                                 if (argsize == 1)
1636                                         REWRITE_OPCODE(opcode + Bgoto - BRgoto);
1637                                 WRITE_INT16(arg, program_ptr);
1638                         } else {
1639                                 if (argsize == 2)
1640                                         REWRITE_OPCODE(opcode + BRgoto - Bgoto);
1641                                 WRITE_INT8(arg, program_ptr);
1642                         }
1643                         break;
1644
1645                 case Bconstant2:
1646                         READ_OPERAND_2;
1647                         WRITE_CONSTANT;
1648                         break;
1649
1650                 case BlistN:
1651                 case BconcatN:
1652                 case BinsertN:
1653                         READ_OPERAND_1;
1654                         WRITE_INT8(arg, program_ptr);
1655                         break;
1656
1657                 default:
1658                         if (opcode < Bconstant)
1659                                 check_opcode(opcode);
1660                         else {
1661                                 arg = opcode - Bconstant;
1662                                 WRITE_CONSTANT;
1663                         }
1664                         break;
1665                 }
1666         }
1667
1668         /* Fix up jumps table to refer to NEW offsets. */
1669         for (struct jump *j = jumps; j < jumps_ptr; j++) {
1670 #ifdef ERROR_CHECK_BYTE_CODE
1671                 assert(j->from < icounts_ptr - icounts);
1672                 assert(j->to < icounts_ptr - icounts);
1673 #endif
1674                 j->from = icounts[j->from];
1675                 j->to = icounts[j->to];
1676 #ifdef ERROR_CHECK_BYTE_CODE
1677                 assert(j->from < program_ptr - program);
1678                 assert(j->to < program_ptr - program);
1679                 check_opcode((Opcode) (program[j->from - 1]));
1680 #endif
1681                 check_opcode((Opcode) (program[j->to]));
1682         }
1683
1684         /* Fixup jumps in byte-code until no more fixups needed */
1685         for (bool more_fixups_needed = true; more_fixups_needed; ) {
1686                 struct jump *j;
1687
1688                 /* assume we don't need more hiccups */
1689                 more_fixups_needed = false;
1690                 for (j = jumps; j < jumps_ptr; j++) {
1691                         int from = j->from;
1692                         int to = j->to;
1693                         int jump = to - from;
1694                         Opbyte *p = program + from;
1695                         Opcode opcode = (Opcode)p[-1];
1696
1697                         if (!more_fixups_needed) {
1698                                 check_opcode((Opcode) p[jump]);
1699                         }
1700                         assert(to >= 0 && program + to < program_ptr);
1701
1702                         switch ((unsigned int)opcode) {
1703                         case Bgoto:
1704                         case Bgotoifnil:
1705                         case Bgotoifnonnil:
1706                         case Bgotoifnilelsepop:
1707                         case Bgotoifnonnilelsepop:
1708                                 WRITE_INT16(jump, p);
1709                                 break;
1710
1711                         case BRgoto:
1712                         case BRgotoifnil:
1713                         case BRgotoifnonnil:
1714                         case BRgotoifnilelsepop:
1715                         case BRgotoifnonnilelsepop:
1716                                 if (jump > SCHAR_MIN && jump <= SCHAR_MAX) {
1717                                         WRITE_INT8(jump, p);
1718                                 } else {
1719                                         /* barf */
1720                                         struct jump *jj;
1721
1722                                         for (jj = jumps; jj < jumps_ptr; jj++) {
1723                                                 assert(jj->from <
1724                                                        program_ptr - program);
1725                                                 assert(jj->to <
1726                                                        program_ptr - program);
1727                                                 if (jj->from > from) {
1728                                                         jj->from++;
1729                                                 }
1730                                                 if (jj->to > from) {
1731                                                         jj->to++;
1732                                                 }
1733                                         }
1734                                         p[-1] += Bgoto - BRgoto;
1735                                         more_fixups_needed = true;
1736                                         memmove(p + 1, p, program_ptr++ - p);
1737                                         WRITE_INT16(jump, p);
1738                                 }
1739                                 break;
1740
1741                         default:
1742                                 abort();
1743                                 break;
1744                         }
1745                 }
1746         }
1747
1748         /* *program_ptr++ = 0; */
1749         *program_length = program_ptr - program;
1750 }
1751
1752 /* Optimize the byte code and store the optimized program, only
1753    understood by bytecode.c, in an opaque object in the
1754    instructions slot of the Compiled_Function object. */
1755 void optimize_compiled_function(Lisp_Object compiled_function)
1756 {
1757         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(compiled_function);
1758         int program_length;
1759         int varbind_count;
1760         Opbyte *program;
1761
1762         /* If we have not actually read the bytecode string
1763            and constants vector yet, fetch them from the file.  */
1764         if (CONSP(f->instructions))
1765                 Ffetch_bytecode(compiled_function);
1766
1767         if (STRINGP(f->instructions)) {
1768                 /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(),
1769                    which would be slightly more `proper' */
1770                 program =
1771                     alloca_array(Opbyte,
1772                                  1 + 2 * XSTRING_LENGTH(f->instructions));
1773                 optimize_byte_code(f->instructions, f->constants, program,
1774                                    &program_length, &varbind_count);
1775                 f->specpdl_depth = XINT(Flength(f->arglist)) + varbind_count;
1776                 f->instructions =
1777                     make_opaque(program, program_length * sizeof(Opbyte));
1778         }
1779
1780         assert(OPAQUEP(f->instructions));
1781 }
1782 \f
1783 /************************************************************************/
1784 /*              The compiled-function object type                       */
1785 /************************************************************************/
1786 static void
1787 print_compiled_function(Lisp_Object obj, Lisp_Object printcharfun,
1788                         int escapeflag)
1789 {
1790         /* This function can GC */
1791         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);    /* GC doesn't relocate */
1792         int docp = f->flags.documentationp;
1793         int intp = f->flags.interactivep;
1794         struct gcpro gcpro1, gcpro2;
1795         GCPRO2(obj, printcharfun);
1796
1797         write_c_string(print_readably ? "#[" : "#<compiled-function ",
1798                        printcharfun);
1799 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1800         if (!print_readably) {
1801                 Lisp_Object ann = compiled_function_annotation(f);
1802                 if (!NILP(ann)) {
1803                         write_c_string("(from ", printcharfun);
1804                         print_internal(ann, printcharfun, 1);
1805                         write_c_string(") ", printcharfun);
1806                 }
1807         }
1808 #endif                          /* COMPILED_FUNCTION_ANNOTATION_HACK */
1809         /* COMPILED_ARGLIST = 0 */
1810         print_internal(compiled_function_arglist(f), printcharfun, escapeflag);
1811
1812         /* COMPILED_INSTRUCTIONS = 1 */
1813         write_c_string(" ", printcharfun);
1814         {
1815                 struct gcpro ngcpro1;
1816                 Lisp_Object instructions = compiled_function_instructions(f);
1817                 NGCPRO1(instructions);
1818                 if (STRINGP(instructions) && !print_readably) {
1819                         /* We don't usually want to see that junk in the bytecode. */
1820                         write_fmt_str(printcharfun, "\"...(%ld)\"",
1821                                       (long)XSTRING_CHAR_LENGTH(instructions));
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         write_fmt_str(printcharfun, " %d", compiled_function_stack_depth(f));
1834
1835         /* COMPILED_DOC_STRING = 4 */
1836         if (docp || intp) {
1837                 write_c_string(" ", printcharfun);
1838                 print_internal(compiled_function_documentation(f), printcharfun,
1839                                escapeflag);
1840         }
1841
1842         /* COMPILED_INTERACTIVE = 5 */
1843         if (intp) {
1844                 write_c_string(" ", printcharfun);
1845                 print_internal(compiled_function_interactive(f), printcharfun,
1846                                escapeflag);
1847         }
1848
1849         UNGCPRO;
1850         write_c_string(print_readably ? "]" : ">", printcharfun);
1851 }
1852
1853 static Lisp_Object mark_compiled_function(Lisp_Object obj)
1854 {
1855         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1856
1857         mark_object(f->instructions);
1858         mark_object(f->arglist);
1859         mark_object(f->doc_and_interactive);
1860 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1861         mark_object(f->annotated);
1862 #endif
1863         /* tail-recurse on constants */
1864         return f->constants;
1865 }
1866
1867 static int
1868 compiled_function_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
1869 {
1870         Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION(obj1);
1871         Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION(obj2);
1872         return (f1->flags.documentationp == f2->flags.documentationp && f1->flags.interactivep == f2->flags.interactivep && f1->flags.domainp == f2->flags.domainp &&   /* I18N3 */
1873                 internal_equal(compiled_function_instructions(f1),
1874                                compiled_function_instructions(f2), depth + 1) &&
1875                 internal_equal(f1->constants, f2->constants, depth + 1) &&
1876                 internal_equal(f1->arglist, f2->arglist, depth + 1) &&
1877                 internal_equal(f1->doc_and_interactive,
1878                                f2->doc_and_interactive, depth + 1));
1879 }
1880
1881 static unsigned long compiled_function_hash(Lisp_Object obj, int depth)
1882 {
1883         Lisp_Compiled_Function *f = XCOMPILED_FUNCTION(obj);
1884         return HASH3((f->flags.documentationp << 2) +
1885                      (f->flags.interactivep << 1) +
1886                      f->flags.domainp,
1887                      internal_hash(f->instructions, depth + 1),
1888                      internal_hash(f->constants, depth + 1));
1889 }
1890
1891 static const struct lrecord_description compiled_function_description[] = {
1892         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, instructions)},
1893         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, constants)},
1894         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, arglist)},
1895         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, doc_and_interactive)},
1896 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1897         {XD_LISP_OBJECT, offsetof(Lisp_Compiled_Function, annotated)},
1898 #endif
1899         {XD_END}
1900 };
1901
1902 DEFINE_BASIC_LRECORD_IMPLEMENTATION("compiled-function", compiled_function,
1903                                     mark_compiled_function,
1904                                     print_compiled_function, 0,
1905                                     compiled_function_equal,
1906                                     compiled_function_hash,
1907                                     compiled_function_description,
1908                                     Lisp_Compiled_Function);
1909 \f
1910 DEFUN("compiled-function-p", Fcompiled_function_p, 1, 1, 0,     /*
1911 Return t if OBJECT is a byte-compiled function object.
1912 */
1913       (object))
1914 {
1915         return COMPILED_FUNCTIONP(object) ? Qt : Qnil;
1916 }
1917
1918 /************************************************************************/
1919 /*              compiled-function object accessor functions             */
1920 /************************************************************************/
1921
1922 Lisp_Object compiled_function_arglist(Lisp_Compiled_Function * f)
1923 {
1924         return f->arglist;
1925 }
1926
1927 Lisp_Object compiled_function_instructions(Lisp_Compiled_Function * f)
1928 {
1929         if (!OPAQUEP(f->instructions))
1930                 return f->instructions;
1931
1932         {
1933                 /* Invert action performed by optimize_byte_code() */
1934                 Lisp_Opaque *opaque = XOPAQUE(f->instructions);
1935
1936                 Bufbyte *const buffer =
1937                     alloca_array(Bufbyte, OPAQUE_SIZE(opaque) * MAX_EMCHAR_LEN);
1938                 Bufbyte *bp = buffer;
1939
1940                 const Opbyte *const program =
1941                     (const Opbyte *)OPAQUE_DATA(opaque);
1942                 const Opbyte *program_ptr = program;
1943                 const Opbyte *const program_end =
1944                     program_ptr + OPAQUE_SIZE(opaque);
1945
1946                 while (program_ptr < program_end) {
1947                         Opcode opcode = (Opcode) READ_UINT_1;
1948                         bp += set_charptr_emchar(bp, opcode);
1949
1950                         switch ((unsigned int)opcode) {
1951                         case Bvarref + 7:
1952                         case Bvarset + 7:
1953                         case Bvarbind + 7:
1954                         case Bcall + 7:
1955                         case Bunbind + 7:
1956                         case Bconstant2:
1957                                 bp += set_charptr_emchar(bp, READ_UINT_1);
1958                                 bp += set_charptr_emchar(bp, READ_UINT_1);
1959                                 break;
1960
1961                         case Bvarref + 6:
1962                         case Bvarset + 6:
1963                         case Bvarbind + 6:
1964                         case Bcall + 6:
1965                         case Bunbind + 6:
1966                         case BlistN:
1967                         case BconcatN:
1968                         case BinsertN:
1969                                 bp += set_charptr_emchar(bp, READ_UINT_1);
1970                                 break;
1971
1972                         case Bgoto:
1973                         case Bgotoifnil:
1974                         case Bgotoifnonnil:
1975                         case Bgotoifnilelsepop:
1976                         case Bgotoifnonnilelsepop:
1977                                 {
1978                                         int jump = READ_INT_2;
1979                                         Opbyte buf2[2];
1980                                         Opbyte *buf2p = buf2;
1981                                         /* Convert back to program-relative address */
1982                                         WRITE_INT16(jump +
1983                                                     (program_ptr - 2 - program),
1984                                                     buf2p);
1985                                         bp += set_charptr_emchar(bp, buf2[0]);
1986                                         bp += set_charptr_emchar(bp, buf2[1]);
1987                                         break;
1988                                 }
1989
1990                         case BRgoto:
1991                         case BRgotoifnil:
1992                         case BRgotoifnonnil:
1993                         case BRgotoifnilelsepop:
1994                         case BRgotoifnonnilelsepop:
1995                                 bp += set_charptr_emchar(bp, READ_INT_1 + 127);
1996                                 break;
1997
1998                         default:
1999                                 break;
2000                         }
2001                 }
2002                 return make_string(buffer, bp - buffer);
2003         }
2004 }
2005
2006 Lisp_Object compiled_function_constants(Lisp_Compiled_Function * f)
2007 {
2008         return f->constants;
2009 }
2010
2011 int compiled_function_stack_depth(Lisp_Compiled_Function * f)
2012 {
2013         return f->stack_depth;
2014 }
2015
2016 /* The compiled_function->doc_and_interactive slot uses the minimal
2017    number of conses, based on compiled_function->flags; it may take
2018    any of the following forms:
2019
2020         doc
2021         interactive
2022         domain
2023         (doc . interactive)
2024         (doc . domain)
2025         (interactive . domain)
2026         (doc . (interactive . domain))
2027  */
2028
2029 /* Caller must check flags.interactivep first */
2030 Lisp_Object compiled_function_interactive(Lisp_Compiled_Function * f)
2031 {
2032         assert(f->flags.interactivep);
2033         if (f->flags.documentationp && f->flags.domainp)
2034                 return XCAR(XCDR(f->doc_and_interactive));
2035         else if (f->flags.documentationp)
2036                 return XCDR(f->doc_and_interactive);
2037         else if (f->flags.domainp)
2038                 return XCAR(f->doc_and_interactive);
2039         else
2040                 return f->doc_and_interactive;
2041 }
2042
2043 /* Caller need not check flags.documentationp first */
2044 Lisp_Object compiled_function_documentation(Lisp_Compiled_Function * f)
2045 {
2046         if (!f->flags.documentationp)
2047                 return Qnil;
2048         else if (f->flags.interactivep && f->flags.domainp)
2049                 return XCAR(f->doc_and_interactive);
2050         else if (f->flags.interactivep)
2051                 return XCAR(f->doc_and_interactive);
2052         else if (f->flags.domainp)
2053                 return XCAR(f->doc_and_interactive);
2054         else
2055                 return f->doc_and_interactive;
2056 }
2057
2058 /* Caller need not check flags.domainp first */
2059 Lisp_Object compiled_function_domain(Lisp_Compiled_Function * f)
2060 {
2061         if (!f->flags.domainp)
2062                 return Qnil;
2063         else if (f->flags.documentationp && f->flags.interactivep)
2064                 return XCDR(XCDR(f->doc_and_interactive));
2065         else if (f->flags.documentationp)
2066                 return XCDR(f->doc_and_interactive);
2067         else if (f->flags.interactivep)
2068                 return XCDR(f->doc_and_interactive);
2069         else
2070                 return f->doc_and_interactive;
2071 }
2072
2073 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2074
2075 Lisp_Object compiled_function_annotation(Lisp_Compiled_Function * f)
2076 {
2077         return f->annotated;
2078 }
2079
2080 #endif
2081
2082 /* used only by Snarf-documentation; there must be doc already. */
2083 void
2084 set_compiled_function_documentation(Lisp_Compiled_Function * f,
2085                                     Lisp_Object new_doc)
2086 {
2087         assert(f->flags.documentationp);
2088         assert(INTP(new_doc) || STRINGP(new_doc));
2089
2090         if (f->flags.interactivep && f->flags.domainp)
2091                 XCAR(f->doc_and_interactive) = new_doc;
2092         else if (f->flags.interactivep)
2093                 XCAR(f->doc_and_interactive) = new_doc;
2094         else if (f->flags.domainp)
2095                 XCAR(f->doc_and_interactive) = new_doc;
2096         else
2097                 f->doc_and_interactive = new_doc;
2098 }
2099
2100 DEFUN("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
2101 Return the argument list of the compiled-function object FUNCTION.
2102 */
2103       (function))
2104 {
2105         CHECK_COMPILED_FUNCTION(function);
2106         return compiled_function_arglist(XCOMPILED_FUNCTION(function));
2107 }
2108
2109 DEFUN("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0,       /*
2110 Return the byte-opcode string of the compiled-function object FUNCTION.
2111 */
2112       (function))
2113 {
2114         CHECK_COMPILED_FUNCTION(function);
2115         return compiled_function_instructions(XCOMPILED_FUNCTION(function));
2116 }
2117
2118 DEFUN("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0,     /*
2119 Return the constants vector of the compiled-function object FUNCTION.
2120 */
2121       (function))
2122 {
2123         CHECK_COMPILED_FUNCTION(function);
2124         return compiled_function_constants(XCOMPILED_FUNCTION(function));
2125 }
2126
2127 DEFUN("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
2128 Return the maximum stack depth of the compiled-function object FUNCTION.
2129 */
2130       (function))
2131 {
2132         CHECK_COMPILED_FUNCTION(function);
2133         return
2134             make_int(compiled_function_stack_depth
2135                      (XCOMPILED_FUNCTION(function)));
2136 }
2137
2138 DEFUN("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0,   /*
2139 Return the doc string of the compiled-function object FUNCTION, if available.
2140 Functions that had their doc strings snarfed into the DOC file will have
2141 an integer returned instead of a string.
2142 */
2143       (function))
2144 {
2145         CHECK_COMPILED_FUNCTION(function);
2146         return compiled_function_documentation(XCOMPILED_FUNCTION(function));
2147 }
2148
2149 DEFUN("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
2150 Return the interactive spec of the compiled-function object FUNCTION, or nil.
2151 If non-nil, the return value will be a list whose first element is
2152 `interactive' and whose second element is the interactive spec.
2153 */
2154       (function))
2155 {
2156         CHECK_COMPILED_FUNCTION(function);
2157         return XCOMPILED_FUNCTION(function)->flags.interactivep
2158             ? list2(Qinteractive,
2159                     compiled_function_interactive(XCOMPILED_FUNCTION(function)))
2160             : Qnil;
2161 }
2162
2163 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2164
2165 /* Remove the `xx' if you wish to restore this feature */
2166 xxDEFUN("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
2167 Return the annotation of the compiled-function object FUNCTION, or nil.
2168 The annotation is a piece of information indicating where this
2169 compiled-function object came from.  Generally this will be
2170 a symbol naming a function; or a string naming a file, if the
2171 compiled-function object was not defined in a function; or nil,
2172 if the compiled-function object was not created as a result of
2173 a `load'.
2174                                                                                  */
2175         (function)) {
2176         CHECK_COMPILED_FUNCTION(function);
2177         return compiled_function_annotation(XCOMPILED_FUNCTION(function));
2178 }
2179
2180 #endif                          /* COMPILED_FUNCTION_ANNOTATION_HACK */
2181
2182 DEFUN("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0,   /*
2183 Return the domain of the compiled-function object FUNCTION, or nil.
2184 This is only meaningful if I18N3 was enabled when emacs was compiled.
2185 */
2186       (function))
2187 {
2188         CHECK_COMPILED_FUNCTION(function);
2189         return XCOMPILED_FUNCTION(function)->flags.domainp
2190             ? compiled_function_domain(XCOMPILED_FUNCTION(function))
2191             : Qnil;
2192 }
2193 \f
2194 DEFUN("fetch-bytecode", Ffetch_bytecode, 1, 1, 0,       /*
2195 If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now.
2196 */
2197       (function))
2198 {
2199         Lisp_Compiled_Function *f;
2200         CHECK_COMPILED_FUNCTION(function);
2201         f = XCOMPILED_FUNCTION(function);
2202
2203         if (OPAQUEP(f->instructions) || STRINGP(f->instructions))
2204                 return function;
2205
2206         if (CONSP(f->instructions)) {
2207                 Lisp_Object tem = read_doc_string(f->instructions);
2208                 if (!CONSP(tem))
2209                         signal_simple_error("Invalid lazy-loaded byte code",
2210                                             tem);
2211                 /* v18 or v19 bytecode file.  Need to Ebolify. */
2212                 if (f->flags.ebolified && VECTORP(XCDR(tem)))
2213                         ebolify_bytecode_constants(XCDR(tem));
2214                 f->instructions = XCAR(tem);
2215                 f->constants = XCDR(tem);
2216                 return function;
2217         }
2218         abort();
2219         return Qnil;            /* not reached */
2220 }
2221
2222 DEFUN("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0,       /*
2223 Convert compiled function FUNCTION into an optimized internal form.
2224 */
2225       (function))
2226 {
2227         Lisp_Compiled_Function *f;
2228         CHECK_COMPILED_FUNCTION(function);
2229         f = XCOMPILED_FUNCTION(function);
2230
2231         if (OPAQUEP(f->instructions))   /* Already optimized? */
2232                 return Qnil;
2233
2234         optimize_compiled_function(function);
2235         return Qnil;
2236 }
2237
2238 DEFUN("byte-code", Fbyte_code, 3, 3, 0, /*
2239 Function used internally in byte-compiled code.
2240 First argument INSTRUCTIONS is a string of byte code.
2241 Second argument CONSTANTS is a vector of constants.
2242 Third argument STACK-DEPTH is the maximum stack depth used in this function.
2243 If STACK-DEPTH is incorrect, Emacs may crash.
2244 */
2245       (instructions, constants, stack_depth))
2246 {
2247         /* This function can GC */
2248         int varbind_count;
2249         int program_length;
2250         Opbyte *program;
2251
2252         CHECK_STRING(instructions);
2253         CHECK_VECTOR(constants);
2254         CHECK_NATNUM(stack_depth);
2255
2256         /* Optimize the `instructions' string, just like when executing a
2257            regular compiled function, but don't save it for later since this is
2258            likely to only be executed once. */
2259         program = alloca_array(Opbyte, 1 + 2 * XSTRING_LENGTH(instructions));
2260         optimize_byte_code(instructions, constants, program,
2261                            &program_length, &varbind_count);
2262         SPECPDL_RESERVE(varbind_count);
2263         return execute_optimized_program(program,
2264                                          XINT(stack_depth),
2265                                          XVECTOR_DATA(constants));
2266 }
2267 \f
2268 void syms_of_bytecode(void)
2269 {
2270         INIT_LRECORD_IMPLEMENTATION(compiled_function);
2271
2272         DEFERROR_STANDARD(Qinvalid_byte_code, Qinvalid_state);
2273         defsymbol(&Qbyte_code, "byte-code");
2274         defsymbol(&Qcompiled_functionp, "compiled-function-p");
2275
2276         DEFSUBR(Fbyte_code);
2277         DEFSUBR(Ffetch_bytecode);
2278         DEFSUBR(Foptimize_compiled_function);
2279
2280         DEFSUBR(Fcompiled_function_p);
2281         DEFSUBR(Fcompiled_function_instructions);
2282         DEFSUBR(Fcompiled_function_constants);
2283         DEFSUBR(Fcompiled_function_stack_depth);
2284         DEFSUBR(Fcompiled_function_arglist);
2285         DEFSUBR(Fcompiled_function_interactive);
2286         DEFSUBR(Fcompiled_function_doc_string);
2287         DEFSUBR(Fcompiled_function_domain);
2288 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2289         DEFSUBR(Fcompiled_function_annotation);
2290 #endif
2291
2292 #ifdef BYTE_CODE_METER
2293         defsymbol(&Qbyte_code_meter, "byte-code-meter");
2294 #endif
2295 }
2296
2297 void vars_of_bytecode(void)
2298 {
2299 #ifdef BYTE_CODE_METER
2300
2301         DEFVAR_LISP("byte-code-meter", &Vbyte_code_meter        /*
2302 A vector of vectors which holds a histogram of byte code usage.
2303 \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte
2304 opcode CODE has been executed.
2305 \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,
2306 indicates how many times the byte opcodes CODE1 and CODE2 have been
2307 executed in succession.
2308                                                                  */ );
2309         DEFVAR_BOOL("byte-metering-on", &byte_metering_on       /*
2310 If non-nil, keep profiling information on byte code usage.
2311 The variable `byte-code-meter' indicates how often each byte opcode is used.
2312 If a symbol has a property named `byte-code-meter' whose value is an
2313 integer, it is incremented each time that symbol's function is called.
2314                                                                  */ );
2315
2316         byte_metering_on = 0;
2317         Vbyte_code_meter = make_vector(256, Qzero);
2318         {
2319                 int i = 256;
2320                 while (i--)
2321                         XVECTOR_DATA(Vbyte_code_meter)[i] =
2322                             make_vector(256, Qzero);
2323         }
2324 #endif                          /* BYTE_CODE_METER */
2325 }