1: /* Execution of byte code produced by bytecomp.el.
    2:    Copyright (C) 1985, 1986, 1987, 1988, 1993, 2000, 2001, 2002, 2003, 2004,
    3:                  2005, 2006, 2007 Free Software Foundation, Inc.
    4: 
    5: This file is part of GNU Emacs.
    6: 
    7: GNU Emacs 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 2, or (at your option)
   10: any later version.
   11: 
   12: GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to
   19: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   20: Boston, MA 02110-1301, USA.
   21: 
   22: hacked on by jwz@lucid.com 17-jun-91
   23:   o  added a compile-time switch to turn on simple sanity checking;
   24:   o  put back the obsolete byte-codes for error-detection;
   25:   o  added a new instruction, unbind_all, which I will use for
   26:      tail-recursion elimination;
   27:   o  made temp_output_buffer_show be called with the right number
   28:      of args;
   29:   o  made the new bytecodes be called with args in the right order;
   30:   o  added metering support.
   31: 
   32: by Hallvard:
   33:   o  added relative jump instructions;
   34:   o  all conditionals now only do QUIT if they jump.
   35:  */
   36: 
   37: #include <config.h>
   38: #include "lisp.h"
   39: #include "buffer.h"
   40: #include "charset.h"
   41: #include "syntax.h"
   42: #include "window.h"
   43: 
   44: #ifdef CHECK_FRAME_FONT
   45: #include "frame.h"
   46: #include "xterm.h"
   47: #endif
   48: 
   49: /*
   50:  * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
   51:  * debugging the byte compiler...)
   52:  *
   53:  * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
   54:  */
   55: /* #define BYTE_CODE_SAFE */
   56: /* #define BYTE_CODE_METER */
   57: 
   58: ^L
   59: #ifdef BYTE_CODE_METER
   60: 
   61: Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
   62: int byte_metering_on;
   63: 
   64: #define METER_2(code1, code2) \
   65:   XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
   66:             ->contents[(code2)])
   67: 
   68: #define METER_1(code) METER_2 (0, (code))
   69: 
   70: #define METER_CODE(last_code, this_code)                                \
   71: {                                                                       \
   72:   if (byte_metering_on)                                                 \
   73:     {                                                                   \
   74:       if (METER_1 (this_code) < MOST_POSITIVE_FIXNUM)                   \
   75:         METER_1 (this_code)++;                                          \
   76:       if (last_code                                                     \
   77:           && METER_2 (last_code, this_code) < MOST_POSITIVE_FIXNUM)    \
   78:         METER_2 (last_code, this_code)++;                               \
   79:     }                                                                   \
   80: }
   81: 
   82: #else /* no BYTE_CODE_METER */
   83: 
   84: #define METER_CODE(last_code, this_code)
   85: 
   86: #endif /* no BYTE_CODE_METER */
   87: ^L
   88: 
   89: Lisp_Object Qbytecode;
   90: 
   91: /*  Byte codes: */
   92: 
   93: #define Bvarref 010
   94: #define Bvarset 020
   95: #define Bvarbind 030
   96: #define Bcall 040
   97: #define Bunbind 050
   98: 
   99: #define Bnth 070
  100: #define Bsymbolp 071
  101: #define Bconsp 072
  102: #define Bstringp 073
  103: #define Blistp 074
  104: #define Beq 075
  105: #define Bmemq 076
  106: #define Bnot 077
  107: #define Bcar 0100
  108: #define Bcdr 0101
  109: #define Bcons 0102
  110: #define Blist1 0103
  111: #define Blist2 0104
  112: #define Blist3 0105
  113: #define Blist4 0106
  114: #define Blength 0107
  115: #define Baref 0110
  116: #define Baset 0111
  117: #define Bsymbol_value 0112
  118: #define Bsymbol_function 0113
  119: #define Bset 0114
  120: #define Bfset 0115
  121: #define Bget 0116
  122: #define Bsubstring 0117
  123: #define Bconcat2 0120
  124: #define Bconcat3 0121
  125: #define Bconcat4 0122
  126: #define Bsub1 0123
  127: #define Badd1 0124
  128: #define Beqlsign 0125
  129: #define Bgtr 0126
  130: #define Blss 0127
  131: #define Bleq 0130
  132: #define Bgeq 0131
  133: #define Bdiff 0132
  134: #define Bnegate 0133
  135: #define Bplus 0134
  136: #define Bmax 0135
  137: #define Bmin 0136
  138: #define Bmult 0137
  139: 
  140: #define Bpoint 0140
  141: /* Was Bmark in v17.  */
  142: #define Bsave_current_buffer 0141
  143: #define Bgoto_char 0142
  144: #define Binsert 0143
  145: #define Bpoint_max 0144
  146: #define Bpoint_min 0145
  147: #define Bchar_after 0146
  148: #define Bfollowing_char 0147
  149: #define Bpreceding_char 0150
  150: #define Bcurrent_column 0151
  151: #define Bindent_to 0152
  152: #define Bscan_buffer 0153 /* No longer generated as of v18 */
  153: #define Beolp 0154
  154: #define Beobp 0155
  155: #define Bbolp 0156
  156: #define Bbobp 0157
  157: #define Bcurrent_buffer 0160
  158: #define Bset_buffer 0161
  159: #define Bsave_current_buffer_1 0162 /* Replacing Bsave_current_buffer.  */
  160: #define Bread_char 0162 /* No longer generated as of v19 */
  161: #define Bset_mark 0163 /* this loser is no longer generated as of v18 */
  162: #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
  163: 
  164: #define Bforward_char 0165
  165: #define Bforward_word 0166
  166: #define Bskip_chars_forward 0167
  167: #define Bskip_chars_backward 0170
  168: #define Bforward_line 0171
  169: #define Bchar_syntax 0172
  170: #define Bbuffer_substring 0173
  171: #define Bdelete_region 0174
  172: #define Bnarrow_to_region 0175
  173: #define Bwiden 0176
  174: #define Bend_of_line 0177
  175: 
  176: #define Bconstant2 0201
  177: #define Bgoto 0202
  178: #define Bgotoifnil 0203
  179: #define Bgotoifnonnil 0204
  180: #define Bgotoifnilelsepop 0205
  181: #define Bgotoifnonnilelsepop 0206
  182: #define Breturn 0207
  183: #define Bdiscard 0210
  184: #define Bdup 0211
  185: 
  186: #define Bsave_excursion 0212
  187: #define Bsave_window_excursion 0213
  188: #define Bsave_restriction 0214
  189: #define Bcatch 0215
  190: 
  191: #define Bunwind_protect 0216
  192: #define Bcondition_case 0217
  193: #define Btemp_output_buffer_setup 0220
  194: #define Btemp_output_buffer_show 0221
  195: 
  196: #define Bunbind_all 0222
  197: 
  198: #define Bset_marker 0223
  199: #define Bmatch_beginning 0224
  200: #define Bmatch_end 0225
  201: #define Bupcase 0226
  202: #define Bdowncase 0227
  203: 
  204: #define Bstringeqlsign 0230
  205: #define Bstringlss 0231
  206: #define Bequal 0232
  207: #define Bnthcdr 0233
  208: #define Belt 0234
  209: #define Bmember 0235
  210: #define Bassq 0236
  211: #define Bnreverse 0237
  212: #define Bsetcar 0240
  213: #define Bsetcdr 0241
  214: #define Bcar_safe 0242
  215: #define Bcdr_safe 0243
  216: #define Bnconc 0244
  217: #define Bquo 0245
  218: #define Brem 0246
  219: #define Bnumberp 0247
  220: #define Bintegerp 0250
  221: 
  222: #define BRgoto 0252
  223: #define BRgotoifnil 0253
  224: #define BRgotoifnonnil 0254
  225: #define BRgotoifnilelsepop 0255
  226: #define BRgotoifnonnilelsepop 0256
  227: 
  228: #define BlistN 0257
  229: #define BconcatN 0260
  230: #define BinsertN 0261
  231: 
  232: #define Bconstant 0300
  233: #define CONSTANTLIM 0100
  234: 
  235: ^L
  236: /* Structure describing a value stack used during byte-code execution
  237:    in Fbyte_code.  */
  238: 
  239: struct byte_stack
  240: {
  241:   /* Program counter.  This points into the byte_string below
  242:      and is relocated when that string is relocated.  */
  243:   const unsigned char *pc;
  244: 
  245:   /* Top and bottom of stack.  The bottom points to an area of memory
  246:      allocated with alloca in Fbyte_code.  */
  247:   Lisp_Object *top, *bottom;
  248: 
  249:   /* The string containing the byte-code, and its current address.
  250:      Storing this here protects it from GC because mark_byte_stack
  251:      marks it.  */
  252:   Lisp_Object byte_string;
  253:   const unsigned char *byte_string_start;
  254: 
  255:   /* The vector of constants used during byte-code execution.  Storing
  256:      this here protects it from GC because mark_byte_stack marks it.  */
  257:   Lisp_Object constants;
  258: 
  259:   /* Next entry in byte_stack_list.  */
  260:   struct byte_stack *next;
  261: };
  262: 
  263: /* A list of currently active byte-code execution value stacks.
  264:    Fbyte_code adds an entry to the head of this list before it starts
  265:    processing byte-code, and it removed the entry again when it is
  266:    done.  Signalling an error truncates the list analoguous to
  267:    gcprolist.  */
  268: 
  269: struct byte_stack *byte_stack_list;
  270: 
  271: ^L
  272: /* Mark objects on byte_stack_list.  Called during GC.  */
  273: 
  274: void
  275: mark_byte_stack ()
  276: {
  277:   struct byte_stack *stack;
  278:   Lisp_Object *obj;
  279: 
  280:   for (stack = byte_stack_list; stack; stack = stack->next)
  281:     {
  282:       /* If STACK->top is null here, this means there's an opcode in
  283:          Fbyte_code that wasn't expected to GC, but did.  To find out
  284:          which opcode this is, record the value of `stack', and walk
  285:          up the stack in a debugger, stopping in frames of Fbyte_code.
  286:          The culprit is found in the frame of Fbyte_code where the
  287:          address of its local variable `stack' is equal to the
  288:          recorded value of `stack' here.  */
  289:       eassert (stack->top);
  290: 
  291:       for (obj = stack->bottom; obj <= stack->top; ++obj)
  292:         mark_object (*obj);
  293: 
  294:       mark_object (stack->byte_string);
  295:       mark_object (stack->constants);
  296:     }
  297: }
  298: 
  299: 
  300: /* Unmark objects in the stacks on byte_stack_list.  Relocate program
  301:    counters.  Called when GC has completed.  */
  302: 
  303: void
  304: unmark_byte_stack ()
  305: {
  306:   struct byte_stack *stack;
  307: 
  308:   for (stack = byte_stack_list; stack; stack = stack->next)
  309:     {
  310:       if (stack->byte_string_start != SDATA (stack->byte_string))
  311:         {
  312:           int offset = stack->pc - stack->byte_string_start;
  313:           stack->byte_string_start = SDATA (stack->byte_string);
  314:           stack->pc = stack->byte_string_start + offset;
  315:         }
  316:     }
  317: }
  318: 
  319: ^L
  320: /* Fetch the next byte from the bytecode stream */
  321: 
  322: #define FETCH *stack.pc++
  323: 
  324: /* Fetch two bytes from the bytecode stream and make a 16-bit number
  325:    out of them */
  326: 
  327: #define FETCH2 (op = FETCH, op + (FETCH << 8))
  328: 
  329: /* Push x onto the execution stack.  This used to be #define PUSH(x)
  330:    (*++stackp = (x)) This oddity is necessary because Alliant can't be
  331:    bothered to compile the preincrement operator properly, as of 4/91.
  332:    -JimB */
  333: 
  334: #define PUSH(x) (top++, *top = (x))
  335: 
  336: /* Pop a value off the execution stack.  */
  337: 
  338: #define POP (*top--)
  339: 
  340: /* Discard n values from the execution stack.  */
  341: 
  342: #define DISCARD(n) (top -= (n))
  343: 
  344: /* Get the value which is at the top of the execution stack, but don't
  345:    pop it. */
  346: 
  347: #define TOP (*top)
  348: 
  349: /* Actions that must be performed before and after calling a function
  350:    that might GC.  */
  351: 
  352: #define BEFORE_POTENTIAL_GC()   stack.top = top
  353: #define AFTER_POTENTIAL_GC()    stack.top = NULL
  354: 
  355: /* Garbage collect if we have consed enough since the last time.
  356:    We do this at every branch, to avoid loops that never GC.  */
  357: 
  358: #define MAYBE_GC()                                      \
  359:   if (consing_since_gc > gc_cons_threshold              \
  360:       && consing_since_gc > gc_relative_threshold)      \
  361:     {                                                   \
  362:       BEFORE_POTENTIAL_GC ();                           \
  363:       Fgarbage_collect ();                              \
  364:       AFTER_POTENTIAL_GC ();                            \
  365:     }                                                   \
  366:   else
  367: 
  368: /* Check for jumping out of range.  */
  369: 
  370: #ifdef BYTE_CODE_SAFE
  371: 
  372: #define CHECK_RANGE(ARG) \
  373:   if (ARG >= bytestr_length) abort ()
  374: 
  375: #else /* not BYTE_CODE_SAFE */
  376: 
  377: #define CHECK_RANGE(ARG)
  378: 
  379: #endif /* not BYTE_CODE_SAFE */
  380: 
  381: /* A version of the QUIT macro which makes sure that the stack top is
  382:    set before signaling `quit'.  */
  383: 
  384: #define BYTE_CODE_QUIT                                  \
  385:   do {                                                  \
  386:     if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))     \
  387:       {                                                 \
  388:         Lisp_Object flag = Vquit_flag;                  \
  389:         Vquit_flag = Qnil;                             \
  390:         BEFORE_POTENTIAL_GC ();                         \
  391:         if (EQ (Vthrow_on_input, flag))                        \
  392:           Fthrow (Vthrow_on_input, Qt);                        \
  393:         Fsignal (Qquit, Qnil);                         \
  394:         AFTER_POTENTIAL_GC ();                         \
  395:       }                                                 \
  396:   } while (0)
  397: 
  398: 
  399: DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
  400:        doc: /* Function used internally in byte-compiled code.
  401: The first argument, BYTESTR, is a string of byte code;
  402: the second, VECTOR, a vector of constants;
  403: the third, MAXDEPTH, the maximum stack depth used in this function.
  404: If the third argument is incorrect, Emacs may crash.  */)
  405:      (bytestr, vector, maxdepth)
  406:      Lisp_Object bytestr, vector, maxdepth;
  407: {
  408:   int count = SPECPDL_INDEX ();
  409: #ifdef BYTE_CODE_METER
  410:   int this_op = 0;
  411:   int prev_op;
  412: #endif
  413:   int op;
  414:   /* Lisp_Object v1, v2; */
  415:   Lisp_Object *vectorp;
  416: #ifdef BYTE_CODE_SAFE
  417:   int const_length = XVECTOR (vector)->size;
  418:   Lisp_Object *stacke;
  419: #endif
  420:   int bytestr_length;
  421:   struct byte_stack stack;
  422:   Lisp_Object *top;
  423:   Lisp_Object result;
  424: 
  425: #ifdef CHECK_FRAME_FONT
  426:  {
  427:    struct frame *f = SELECTED_FRAME ();
  428:    if (FRAME_X_P (f)
  429:        && FRAME_FONT (f)->direction != 0
  430:        && FRAME_FONT (f)->direction != 1)
  431:      abort ();
  432:  }
  433: #endif
  434: 
  435:   CHECK_STRING (bytestr);
  436:   CHECK_VECTOR (vector);
  437:   CHECK_NUMBER (maxdepth);
  438: 
  439:   if (STRING_MULTIBYTE (bytestr))
  440:     /* BYTESTR must have been produced by Emacs 20.2 or the earlier
  441:        because they produced a raw 8-bit string for byte-code and now
  442:        such a byte-code string is loaded as multibyte while raw 8-bit
  443:        characters converted to multibyte form.  Thus, now we must
  444:        convert them back to the originally intended unibyte form.  */
  445:     bytestr = Fstring_as_unibyte (bytestr);
  446: 
  447:   bytestr_length = SBYTES (bytestr);
  448:   vectorp = XVECTOR (vector)->contents;
  449: 
  450:   stack.byte_string = bytestr;
  451:   stack.pc = stack.byte_string_start = SDATA (bytestr);
  452:   stack.constants = vector;
  453:   stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
  454:                                          * sizeof (Lisp_Object));
  455:   top = stack.bottom - 1;
  456:   stack.top = NULL;
  457:   stack.next = byte_stack_list;
  458:   byte_stack_list = &stack;
  459: 
  460: #ifdef BYTE_CODE_SAFE
  461:   stacke = stack.bottom - 1 + XFASTINT (maxdepth);
  462: #endif
  463: 
  464:   while (1)
  465:     {
  466: #ifdef BYTE_CODE_SAFE
  467:       if (top > stacke)
  468:         abort ();
  469:       else if (top < stack.bottom - 1)
  470:         abort ();
  471: #endif
  472: 
  473: #ifdef BYTE_CODE_METER
  474:       prev_op = this_op;
  475:       this_op = op = FETCH;
  476:       METER_CODE (prev_op, op);
  477: #else
  478:       op = FETCH;
  479: #endif
  480: 
  481:       switch (op)
  482:         {
  483:         case Bvarref + 7:
  484:           op = FETCH2;
  485:           goto varref;
  486: 
  487:         case Bvarref:
  488:         case Bvarref + 1:
  489:         case Bvarref + 2:
  490:         case Bvarref + 3:
  491:         case Bvarref + 4:
  492:         case Bvarref + 5:
  493:           op = op - Bvarref;
  494:           goto varref;
  495: 
  496:         /* This seems to be the most frequently executed byte-code
  497:            among the Bvarref's, so avoid a goto here.  */
  498:         case Bvarref+6:
  499:           op = FETCH;
  500:         varref:
  501:           {
  502:             Lisp_Object v1, v2;
  503: 
  504:             v1 = vectorp[op];
  505:             if (SYMBOLP (v1))
  506:               {
  507:                 v2 = SYMBOL_VALUE (v1);
  508:                 if (MISCP (v2) || EQ (v2, Qunbound))
  509:                   {
  510:                     BEFORE_POTENTIAL_GC ();
  511:                     v2 = Fsymbol_value (v1);
  512:                     AFTER_POTENTIAL_GC ();
  513:                   }
  514:               }
  515:             else
  516:               {
  517:                 BEFORE_POTENTIAL_GC ();
  518:                 v2 = Fsymbol_value (v1);
  519:                 AFTER_POTENTIAL_GC ();
  520:               }
  521:             PUSH (v2);
  522:             break;
  523:           }
  524: 
  525:         case Bgotoifnil:
  526:           {
  527:             Lisp_Object v1;
  528:             MAYBE_GC ();
  529:             op = FETCH2;
  530:             v1 = POP;
  531:             if (NILP (v1))
  532:               {
  533:                 BYTE_CODE_QUIT;
  534:                 CHECK_RANGE (op);
  535:                 stack.pc = stack.byte_string_start + op;
  536:               }
  537:             break;
  538:           }
  539: 
  540:         case Bcar:
  541:           {
  542:             Lisp_Object v1;
  543:             v1 = TOP;
  544:             TOP = CAR (v1);
  545:             break;
  546:           }
  547: 
  548:         case Beq:
  549:           {
  550:             Lisp_Object v1;
  551:             v1 = POP;
  552:             TOP = EQ (v1, TOP) ? Qt : Qnil;
  553:             break;
  554:           }
  555: 
  556:         case Bmemq:
  557:           {
  558:             Lisp_Object v1;
  559:             BEFORE_POTENTIAL_GC ();
  560:             v1 = POP;
  561:             TOP = Fmemq (TOP, v1);
  562:             AFTER_POTENTIAL_GC ();
  563: