1 /* Execution of byte code produced by bytecomp.el.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA.
21 hacked on by jwz@lucid.com 17-jun-91
22 o added a compile-time switch to turn on simple sanity checking;
23 o put back the obsolete byte-codes for error-detection;
24 o added a new instruction, unbind_all, which I will use for
25 tail-recursion elimination;
26 o made temp_output_buffer_show be called with the right number
28 o made the new bytecodes be called with args in the right order;
29 o added metering support.
32 o added relative jump instructions;
33 o all conditionals now only do QUIT if they jump.
42 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
43 * debugging the byte compiler...)
45 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
47 /* #define BYTE_CODE_SAFE */
48 /* #define BYTE_CODE_METER */
51 #ifdef BYTE_CODE_METER
53 Lisp_Object Vbyte_code_meter
, Qbyte_code_meter
;
56 #define METER_2(code1, code2) \
57 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
60 #define METER_1(code) METER_2 (0, (code))
62 #define METER_CODE(last_code, this_code) \
64 if (byte_metering_on) \
66 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
67 METER_1 (this_code)++; \
69 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1))\
70 METER_2 (last_code, this_code)++; \
74 #else /* no BYTE_CODE_METER */
76 #define METER_CODE(last_code, this_code)
78 #endif /* no BYTE_CODE_METER */
81 Lisp_Object Qbytecode
;
109 #define Bsymbol_value 0112
110 #define Bsymbol_function 0113
114 #define Bsubstring 0117
115 #define Bconcat2 0120
116 #define Bconcat3 0121
117 #define Bconcat4 0122
120 #define Beqlsign 0125
133 /* Was Bmark in v17. */
134 #define Bsave_current_buffer 0141
135 #define Bgoto_char 0142
137 #define Bpoint_max 0144
138 #define Bpoint_min 0145
139 #define Bchar_after 0146
140 #define Bfollowing_char 0147
141 #define Bpreceding_char 0150
142 #define Bcurrent_column 0151
143 #define Bindent_to 0152
144 #define Bscan_buffer 0153 /* No longer generated as of v18 */
149 #define Bcurrent_buffer 0160
150 #define Bset_buffer 0161
151 #define Bread_char 0162 /* No longer generated as of v19 */
152 #define Bset_mark 0163 /* this loser is no longer generated as of v18 */
153 #define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
155 #define Bforward_char 0165
156 #define Bforward_word 0166
157 #define Bskip_chars_forward 0167
158 #define Bskip_chars_backward 0170
159 #define Bforward_line 0171
160 #define Bchar_syntax 0172
161 #define Bbuffer_substring 0173
162 #define Bdelete_region 0174
163 #define Bnarrow_to_region 0175
165 #define Bend_of_line 0177
167 #define Bconstant2 0201
169 #define Bgotoifnil 0203
170 #define Bgotoifnonnil 0204
171 #define Bgotoifnilelsepop 0205
172 #define Bgotoifnonnilelsepop 0206
174 #define Bdiscard 0210
177 #define Bsave_excursion 0212
178 #define Bsave_window_excursion 0213
179 #define Bsave_restriction 0214
182 #define Bunwind_protect 0216
183 #define Bcondition_case 0217
184 #define Btemp_output_buffer_setup 0220
185 #define Btemp_output_buffer_show 0221
187 #define Bunbind_all 0222
189 #define Bset_marker 0223
190 #define Bmatch_beginning 0224
191 #define Bmatch_end 0225
193 #define Bdowncase 0227
195 #define Bstringeqlsign 0230
196 #define Bstringlss 0231
202 #define Bnreverse 0237
205 #define Bcar_safe 0242
206 #define Bcdr_safe 0243
210 #define Bnumberp 0247
211 #define Bintegerp 0250
214 #define BRgotoifnil 0253
215 #define BRgotoifnonnil 0254
216 #define BRgotoifnilelsepop 0255
217 #define BRgotoifnonnilelsepop 0256
220 #define BconcatN 0260
221 #define BinsertN 0261
223 #define Bconstant 0300
224 #define CONSTANTLIM 0100
226 /* Fetch the next byte from the bytecode stream */
230 /* Fetch two bytes from the bytecode stream
231 and make a 16-bit number out of them */
233 #define FETCH2 (op = FETCH, op + (FETCH << 8))
235 /* Push x onto the execution stack. */
237 /* This used to be #define PUSH(x) (*++stackp = (x))
238 This oddity is necessary because Alliant can't be bothered to
239 compile the preincrement operator properly, as of 4/91. -JimB */
240 #define PUSH(x) (stackp++, *stackp = (x))
242 /* Pop a value off the execution stack. */
244 #define POP (*stackp--)
246 /* Discard n values from the execution stack. */
248 #define DISCARD(n) (stackp -= (n))
250 /* Get the value which is at the top of the execution stack, but don't pop it. */
252 #define TOP (*stackp)
254 /* Garbage collect if we have consed enough since the last time.
255 We do this at every branch, to avoid loops that never GC. */
258 if (consing_since_gc > gc_cons_threshold) \
261 DEFUN ("byte-code", Fbyte_code
, Sbyte_code
, 3, 3, 0,
262 "Function used internally in byte-compiled code.\n\
263 The first argument, BYTESTR, is a string of byte code;\n\
264 the second, VECTOR, a vector of constants;\n\
265 the third, MAXDEPTH, the maximum stack depth used in this function.\n\
266 If the third argument is incorrect, Emacs may crash.")
267 (bytestr
, vector
, maxdepth
)
268 Lisp_Object bytestr
, vector
, maxdepth
;
270 struct gcpro gcpro1
, gcpro2
, gcpro3
;
271 int count
= specpdl_ptr
- specpdl
;
272 #ifdef BYTE_CODE_METER
279 register Lisp_Object
*stackp
;
281 register Lisp_Object v1
, v2
;
282 register Lisp_Object
*vectorp
= XVECTOR (vector
)->contents
;
283 #ifdef BYTE_CODE_SAFE
284 register int const_length
= XVECTOR (vector
)->size
;
286 /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated. */
287 Lisp_Object string_saved
;
288 /* Cached address of beginning of string,
289 valid if BYTESTR equals STRING_SAVED. */
290 register unsigned char *strbeg
;
292 CHECK_STRING (bytestr
, 0);
293 if (!VECTORP (vector
))
294 vector
= wrong_type_argument (Qvectorp
, vector
);
295 CHECK_NUMBER (maxdepth
, 2);
297 stackp
= (Lisp_Object
*) alloca (XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
298 bzero (stackp
, XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
299 GCPRO3 (bytestr
, vector
, *stackp
);
300 gcpro3
.nvars
= XFASTINT (maxdepth
);
304 stacke
= stackp
+ XFASTINT (maxdepth
);
306 /* Initialize the saved pc-pointer for fetching from the string. */
307 string_saved
= bytestr
;
308 pc
= XSTRING (string_saved
)->data
;
312 #ifdef BYTE_CODE_SAFE
314 error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
315 pc
- XSTRING (string_saved
)->data
, stacke
- stackp
);
317 error ("Byte code stack underflow (byte compiler bug), pc %d",
318 pc
- XSTRING (string_saved
)->data
);
321 if (! EQ (string_saved
, bytestr
))
323 pc
= pc
- XSTRING (string_saved
)->data
+ XSTRING (bytestr
)->data
;
324 string_saved
= bytestr
;
327 #ifdef BYTE_CODE_METER
329 this_op
= op
= FETCH
;
330 METER_CODE (prev_op
, op
);
344 case Bvarref
: case Bvarref
+1: case Bvarref
+2: case Bvarref
+3:
345 case Bvarref
+4: case Bvarref
+5:
350 v2
= Fsymbol_value (v1
);
353 v2
= XSYMBOL (v1
)->value
;
354 if (MISCP (v2
) || EQ (v2
, Qunbound
))
355 v2
= Fsymbol_value (v1
);
368 case Bvarset
: case Bvarset
+1: case Bvarset
+2: case Bvarset
+3:
369 case Bvarset
+4: case Bvarset
+5:
372 Fset (vectorp
[op
], POP
);
383 case Bvarbind
: case Bvarbind
+1: case Bvarbind
+2: case Bvarbind
+3:
384 case Bvarbind
+4: case Bvarbind
+5:
387 specbind (vectorp
[op
], POP
);
398 case Bcall
: case Bcall
+1: case Bcall
+2: case Bcall
+3:
399 case Bcall
+4: case Bcall
+5:
403 #ifdef BYTE_CODE_METER
404 if (byte_metering_on
&& SYMBOLP (TOP
))
407 v2
= Fget (v1
, Qbyte_code_meter
);
409 && XINT (v2
) != ((1<<VALBITS
)-1))
411 XSETINT (v2
, XINT (v2
) + 1);
412 Fput (v1
, Qbyte_code_meter
, v2
);
416 TOP
= Ffuncall (op
+ 1, &TOP
);
427 case Bunbind
: case Bunbind
+1: case Bunbind
+2: case Bunbind
+3:
428 case Bunbind
+4: case Bunbind
+5:
431 unbind_to (specpdl_ptr
- specpdl
- op
, Qnil
);
435 /* To unbind back to the beginning of this frame. Not used yet,
436 but will be needed for tail-recursion elimination. */
437 unbind_to (count
, Qnil
);
443 op
= FETCH2
; /* pc = FETCH2 loses since FETCH2 contains pc++ */
444 pc
= XSTRING (string_saved
)->data
+ op
;
453 pc
= XSTRING (string_saved
)->data
+ op
;
463 pc
= XSTRING (string_saved
)->data
+ op
;
467 case Bgotoifnilelsepop
:
473 pc
= XSTRING (string_saved
)->data
+ op
;
478 case Bgotoifnonnilelsepop
:
484 pc
= XSTRING (string_saved
)->data
+ op
;
492 pc
+= (int) *pc
- 127;
500 pc
+= (int) *pc
- 128;
510 pc
+= (int) *pc
- 128;
515 case BRgotoifnilelsepop
:
526 case BRgotoifnonnilelsepop
:
551 PUSH (vectorp
[FETCH2
]);
554 case Bsave_excursion
:
555 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
558 case Bsave_current_buffer
:
559 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
562 case Bsave_window_excursion
:
563 TOP
= Fsave_window_excursion (TOP
);
566 case Bsave_restriction
:
567 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
572 TOP
= internal_catch (TOP
, Feval
, v1
);
575 case Bunwind_protect
:
576 record_unwind_protect (0, POP
);
577 (specpdl_ptr
- 1)->symbol
= Qnil
;
580 case Bcondition_case
:
582 v1
= Fcons (POP
, v1
);
583 TOP
= Fcondition_case (Fcons (TOP
, v1
));
586 case Btemp_output_buffer_setup
:
587 temp_output_buffer_setup (XSTRING (TOP
)->data
);
588 TOP
= Vstandard_output
;
591 case Btemp_output_buffer_show
:
593 temp_output_buffer_show (TOP
);
595 /* pop binding of standard-output */
596 unbind_to (specpdl_ptr
- specpdl
- 1, Qnil
);
603 CHECK_NUMBER (v2
, 0);
609 v1
= XCONS (v1
)->cdr
;
613 v1
= wrong_type_argument (Qlistp
, v1
);
622 TOP
= SYMBOLP (TOP
) ? Qt
: Qnil
;
626 TOP
= CONSP (TOP
) ? Qt
: Qnil
;
630 TOP
= STRINGP (TOP
) ? Qt
: Qnil
;
634 TOP
= CONSP (TOP
) || NILP (TOP
) ? Qt
: Qnil
;
639 TOP
= EQ (v1
, TOP
) ? Qt
: Qnil
;
644 TOP
= Fmemq (TOP
, v1
);
648 TOP
= NILP (TOP
) ? Qt
: Qnil
;
654 if (CONSP (v1
)) TOP
= XCONS (v1
)->car
;
655 else if (NILP (v1
)) TOP
= Qnil
;
656 else Fcar (wrong_type_argument (Qlistp
, v1
));
661 if (CONSP (v1
)) TOP
= XCONS (v1
)->cdr
;
662 else if (NILP (v1
)) TOP
= Qnil
;
663 else Fcdr (wrong_type_argument (Qlistp
, v1
));
668 TOP
= Fcons (TOP
, v1
);
672 TOP
= Fcons (TOP
, Qnil
);
677 TOP
= Fcons (TOP
, Fcons (v1
, Qnil
));
682 TOP
= Flist (3, &TOP
);
687 TOP
= Flist (4, &TOP
);
693 TOP
= Flist (op
, &TOP
);
702 TOP
= Faref (TOP
, v1
);
707 TOP
= Faset (TOP
, v1
, v2
);
711 TOP
= Fsymbol_value (TOP
);
714 case Bsymbol_function
:
715 TOP
= Fsymbol_function (TOP
);
720 TOP
= Fset (TOP
, v1
);
725 TOP
= Ffset (TOP
, v1
);
730 TOP
= Fget (TOP
, v1
);
735 TOP
= Fsubstring (TOP
, v1
, v2
);
740 TOP
= Fconcat (2, &TOP
);
745 TOP
= Fconcat (3, &TOP
);
750 TOP
= Fconcat (4, &TOP
);
756 TOP
= Fconcat (op
, &TOP
);
763 XSETINT (v1
, XINT (v1
) - 1);
774 XSETINT (v1
, XINT (v1
) + 1);
783 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1
, 0);
784 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2
, 0);
785 #ifdef LISP_FLOAT_TYPE
786 if (FLOATP (v1
) || FLOATP (v2
))
790 f1
= (FLOATP (v1
) ? XFLOAT (v1
)->data
: XINT (v1
));
791 f2
= (FLOATP (v2
) ? XFLOAT (v2
)->data
: XINT (v2
));
792 TOP
= (f1
== f2
? Qt
: Qnil
);
796 TOP
= (XINT (v1
) == XINT (v2
) ? Qt
: Qnil
);
801 TOP
= Fgtr (TOP
, v1
);
806 TOP
= Flss (TOP
, v1
);
811 TOP
= Fleq (TOP
, v1
);
816 TOP
= Fgeq (TOP
, v1
);
821 TOP
= Fminus (2, &TOP
);
828 XSETINT (v1
, - XINT (v1
));
832 TOP
= Fminus (1, &TOP
);
837 TOP
= Fplus (2, &TOP
);
842 TOP
= Fmax (2, &TOP
);
847 TOP
= Fmin (2, &TOP
);
852 TOP
= Ftimes (2, &TOP
);
857 TOP
= Fquo (2, &TOP
);
862 TOP
= Frem (TOP
, v1
);
866 XSETFASTINT (v1
, PT
);
871 TOP
= Fgoto_char (TOP
);
875 TOP
= Finsert (1, &TOP
);
881 TOP
= Finsert (op
, &TOP
);
885 XSETFASTINT (v1
, ZV
);
890 XSETFASTINT (v1
, BEGV
);
895 TOP
= Fchar_after (TOP
);
898 case Bfollowing_char
:
899 v1
= Ffollowing_char ();
903 case Bpreceding_char
:
904 v1
= Fprevious_char ();
908 case Bcurrent_column
:
909 XSETFASTINT (v1
, current_column ());
914 TOP
= Findent_to (TOP
, Qnil
);
933 case Bcurrent_buffer
:
934 PUSH (Fcurrent_buffer ());
938 TOP
= Fset_buffer (TOP
);
942 PUSH (Fread_char ());
947 PUSH (Finteractive_p ());
951 TOP
= Fforward_char (TOP
);
955 TOP
= Fforward_word (TOP
);
958 case Bskip_chars_forward
:
960 TOP
= Fskip_chars_forward (TOP
, v1
);
963 case Bskip_chars_backward
:
965 TOP
= Fskip_chars_backward (TOP
, v1
);
969 TOP
= Fforward_line (TOP
);
973 CHECK_NUMBER (TOP
, 0);
975 syntax_code_spec
[(int) SYNTAX (XINT (TOP
))]);
978 case Bbuffer_substring
:
980 TOP
= Fbuffer_substring (TOP
, v1
);
985 TOP
= Fdelete_region (TOP
, v1
);
988 case Bnarrow_to_region
:
990 TOP
= Fnarrow_to_region (TOP
, v1
);
998 TOP
= Fend_of_line (TOP
);
1004 TOP
= Fset_marker (TOP
, v2
, v1
);
1007 case Bmatch_beginning
:
1008 TOP
= Fmatch_beginning (TOP
);
1012 TOP
= Fmatch_end (TOP
);
1016 TOP
= Fupcase (TOP
);
1020 TOP
= Fdowncase (TOP
);
1023 case Bstringeqlsign
:
1025 TOP
= Fstring_equal (TOP
, v1
);
1030 TOP
= Fstring_lessp (TOP
, v1
);
1035 TOP
= Fequal (TOP
, v1
);
1040 TOP
= Fnthcdr (TOP
, v1
);
1046 /* Exchange args and then do nth. */
1052 TOP
= Felt (TOP
, v1
);
1057 TOP
= Fmember (TOP
, v1
);
1062 TOP
= Fassq (TOP
, v1
);
1066 TOP
= Fnreverse (TOP
);
1071 TOP
= Fsetcar (TOP
, v1
);
1076 TOP
= Fsetcdr (TOP
, v1
);
1082 TOP
= XCONS (v1
)->car
;
1090 TOP
= XCONS (v1
)->cdr
;
1097 TOP
= Fnconc (2, &TOP
);
1101 TOP
= (NUMBERP (TOP
) ? Qt
: Qnil
);
1105 TOP
= INTEGERP (TOP
) ? Qt
: Qnil
;
1108 #ifdef BYTE_CODE_SAFE
1110 error ("set-mark is an obsolete bytecode");
1113 error ("scan-buffer is an obsolete bytecode");
1116 error ("mark is an obsolete bytecode");
1121 #ifdef BYTE_CODE_SAFE
1123 error ("unknown bytecode %d (byte compiler bug)", op
);
1124 if ((op
-= Bconstant
) >= const_length
)
1125 error ("no constant number %d (byte compiler bug)", op
);
1128 PUSH (vectorp
[op
- Bconstant
]);
1135 /* Binds and unbinds are supposed to be compiled balanced. */
1136 if (specpdl_ptr
- specpdl
!= count
)
1137 #ifdef BYTE_CODE_SAFE
1138 error ("binding stack not balanced (serious byte compiler bug)");
1147 Qbytecode
= intern ("byte-code");
1148 staticpro (&Qbytecode
);
1150 defsubr (&Sbyte_code
);
1152 #ifdef BYTE_CODE_METER
1154 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter
,
1155 "A vector of vectors which holds a histogram of byte-code usage.\n\
1156 (aref (aref byte-code-meter 0) CODE) indicates how many times the byte\n\
1157 opcode CODE has been executed.\n\
1158 (aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,\n\
1159 indicates how many times the byte opcodes CODE1 and CODE2 have been\n\
1160 executed in succession.");
1161 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on
,
1162 "If non-nil, keep profiling information on byte code usage.\n\
1163 The variable byte-code-meter indicates how often each byte opcode is used.\n\
1164 If a symbol has a property named `byte-code-meter' whose value is an\n\
1165 integer, it is incremented each time that symbol's function is called.");
1167 byte_metering_on
= 0;
1168 Vbyte_code_meter
= Fmake_vector (make_number (256), make_number (0));
1169 Qbyte_code_meter
= intern ("byte-code-meter");
1170 staticpro (&Qbyte_code_meter
);
1174 XVECTOR (Vbyte_code_meter
)->contents
[i
] =
1175 Fmake_vector (make_number (256), make_number (0));