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 DEFUN ("byte-code", Fbyte_code
, Sbyte_code
, 3, 3, 0,
255 "Function used internally in byte-compiled code.\n\
256 The first argument, BYTESTR, is a string of byte code;\n\
257 the second, VECTOR, a vector of constants;\n\
258 the third, MAXDEPTH, the maximum stack depth used in this function.\n\
259 If the third argument is incorrect, Emacs may crash.")
260 (bytestr
, vector
, maxdepth
)
261 Lisp_Object bytestr
, vector
, maxdepth
;
263 struct gcpro gcpro1
, gcpro2
, gcpro3
;
264 int count
= specpdl_ptr
- specpdl
;
265 #ifdef BYTE_CODE_METER
272 register Lisp_Object
*stackp
;
274 register Lisp_Object v1
, v2
;
275 register Lisp_Object
*vectorp
= XVECTOR (vector
)->contents
;
276 #ifdef BYTE_CODE_SAFE
277 register int const_length
= XVECTOR (vector
)->size
;
279 /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated. */
280 Lisp_Object string_saved
;
281 /* Cached address of beginning of string,
282 valid if BYTESTR equals STRING_SAVED. */
283 register unsigned char *strbeg
;
285 CHECK_STRING (bytestr
, 0);
286 if (!VECTORP (vector
))
287 vector
= wrong_type_argument (Qvectorp
, vector
);
288 CHECK_NUMBER (maxdepth
, 2);
290 stackp
= (Lisp_Object
*) alloca (XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
291 bzero (stackp
, XFASTINT (maxdepth
) * sizeof (Lisp_Object
));
292 GCPRO3 (bytestr
, vector
, *stackp
);
293 gcpro3
.nvars
= XFASTINT (maxdepth
);
297 stacke
= stackp
+ XFASTINT (maxdepth
);
299 /* Initialize the saved pc-pointer for fetching from the string. */
300 string_saved
= bytestr
;
301 pc
= XSTRING (string_saved
)->data
;
305 #ifdef BYTE_CODE_SAFE
307 error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
308 pc
- XSTRING (string_saved
)->data
, stacke
- stackp
);
310 error ("Byte code stack underflow (byte compiler bug), pc %d",
311 pc
- XSTRING (string_saved
)->data
);
314 if (! EQ (string_saved
, bytestr
))
316 pc
= pc
- XSTRING (string_saved
)->data
+ XSTRING (bytestr
)->data
;
317 string_saved
= bytestr
;
320 #ifdef BYTE_CODE_METER
322 this_op
= op
= FETCH
;
323 METER_CODE (prev_op
, op
);
337 case Bvarref
: case Bvarref
+1: case Bvarref
+2: case Bvarref
+3:
338 case Bvarref
+4: case Bvarref
+5:
343 v2
= Fsymbol_value (v1
);
346 v2
= XSYMBOL (v1
)->value
;
347 if (MISCP (v2
) || EQ (v2
, Qunbound
))
348 v2
= Fsymbol_value (v1
);
361 case Bvarset
: case Bvarset
+1: case Bvarset
+2: case Bvarset
+3:
362 case Bvarset
+4: case Bvarset
+5:
365 Fset (vectorp
[op
], POP
);
376 case Bvarbind
: case Bvarbind
+1: case Bvarbind
+2: case Bvarbind
+3:
377 case Bvarbind
+4: case Bvarbind
+5:
380 specbind (vectorp
[op
], POP
);
391 case Bcall
: case Bcall
+1: case Bcall
+2: case Bcall
+3:
392 case Bcall
+4: case Bcall
+5:
396 #ifdef BYTE_CODE_METER
397 if (byte_metering_on
&& SYMBOLP (TOP
))
400 v2
= Fget (v1
, Qbyte_code_meter
);
402 && XINT (v2
) != ((1<<VALBITS
)-1))
404 XSETINT (v2
, XINT (v2
) + 1);
405 Fput (v1
, Qbyte_code_meter
, v2
);
409 TOP
= Ffuncall (op
+ 1, &TOP
);
420 case Bunbind
: case Bunbind
+1: case Bunbind
+2: case Bunbind
+3:
421 case Bunbind
+4: case Bunbind
+5:
424 unbind_to (specpdl_ptr
- specpdl
- op
, Qnil
);
428 /* To unbind back to the beginning of this frame. Not used yet,
429 but will be needed for tail-recursion elimination. */
430 unbind_to (count
, Qnil
);
435 op
= FETCH2
; /* pc = FETCH2 loses since FETCH2 contains pc++ */
436 pc
= XSTRING (string_saved
)->data
+ op
;
444 pc
= XSTRING (string_saved
)->data
+ op
;
453 pc
= XSTRING (string_saved
)->data
+ op
;
457 case Bgotoifnilelsepop
:
462 pc
= XSTRING (string_saved
)->data
+ op
;
467 case Bgotoifnonnilelsepop
:
472 pc
= XSTRING (string_saved
)->data
+ op
;
479 pc
+= (int) *pc
- 127;
486 pc
+= (int) *pc
- 128;
495 pc
+= (int) *pc
- 128;
500 case BRgotoifnilelsepop
:
510 case BRgotoifnonnilelsepop
:
534 PUSH (vectorp
[FETCH2
]);
537 case Bsave_excursion
:
538 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
541 case Bsave_current_buffer
:
542 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
545 case Bsave_window_excursion
:
546 TOP
= Fsave_window_excursion (TOP
);
549 case Bsave_restriction
:
550 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
555 TOP
= internal_catch (TOP
, Feval
, v1
);
558 case Bunwind_protect
:
559 record_unwind_protect (0, POP
);
560 (specpdl_ptr
- 1)->symbol
= Qnil
;
563 case Bcondition_case
:
565 v1
= Fcons (POP
, v1
);
566 TOP
= Fcondition_case (Fcons (TOP
, v1
));
569 case Btemp_output_buffer_setup
:
570 temp_output_buffer_setup (XSTRING (TOP
)->data
);
571 TOP
= Vstandard_output
;
574 case Btemp_output_buffer_show
:
576 temp_output_buffer_show (TOP
);
578 /* pop binding of standard-output */
579 unbind_to (specpdl_ptr
- specpdl
- 1, Qnil
);
586 CHECK_NUMBER (v2
, 0);
592 v1
= XCONS (v1
)->cdr
;
596 v1
= wrong_type_argument (Qlistp
, v1
);
605 TOP
= SYMBOLP (TOP
) ? Qt
: Qnil
;
609 TOP
= CONSP (TOP
) ? Qt
: Qnil
;
613 TOP
= STRINGP (TOP
) ? Qt
: Qnil
;
617 TOP
= CONSP (TOP
) || NILP (TOP
) ? Qt
: Qnil
;
622 TOP
= EQ (v1
, TOP
) ? Qt
: Qnil
;
627 TOP
= Fmemq (TOP
, v1
);
631 TOP
= NILP (TOP
) ? Qt
: Qnil
;
637 if (CONSP (v1
)) TOP
= XCONS (v1
)->car
;
638 else if (NILP (v1
)) TOP
= Qnil
;
639 else Fcar (wrong_type_argument (Qlistp
, v1
));
644 if (CONSP (v1
)) TOP
= XCONS (v1
)->cdr
;
645 else if (NILP (v1
)) TOP
= Qnil
;
646 else Fcdr (wrong_type_argument (Qlistp
, v1
));
651 TOP
= Fcons (TOP
, v1
);
655 TOP
= Fcons (TOP
, Qnil
);
660 TOP
= Fcons (TOP
, Fcons (v1
, Qnil
));
665 TOP
= Flist (3, &TOP
);
670 TOP
= Flist (4, &TOP
);
676 TOP
= Flist (op
, &TOP
);
685 TOP
= Faref (TOP
, v1
);
690 TOP
= Faset (TOP
, v1
, v2
);
694 TOP
= Fsymbol_value (TOP
);
697 case Bsymbol_function
:
698 TOP
= Fsymbol_function (TOP
);
703 TOP
= Fset (TOP
, v1
);
708 TOP
= Ffset (TOP
, v1
);
713 TOP
= Fget (TOP
, v1
);
718 TOP
= Fsubstring (TOP
, v1
, v2
);
723 TOP
= Fconcat (2, &TOP
);
728 TOP
= Fconcat (3, &TOP
);
733 TOP
= Fconcat (4, &TOP
);
739 TOP
= Fconcat (op
, &TOP
);
746 XSETINT (v1
, XINT (v1
) - 1);
757 XSETINT (v1
, XINT (v1
) + 1);
766 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1
, 0);
767 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2
, 0);
768 #ifdef LISP_FLOAT_TYPE
769 if (FLOATP (v1
) || FLOATP (v2
))
773 f1
= (FLOATP (v1
) ? XFLOAT (v1
)->data
: XINT (v1
));
774 f2
= (FLOATP (v2
) ? XFLOAT (v2
)->data
: XINT (v2
));
775 TOP
= (f1
== f2
? Qt
: Qnil
);
779 TOP
= (XINT (v1
) == XINT (v2
) ? Qt
: Qnil
);
784 TOP
= Fgtr (TOP
, v1
);
789 TOP
= Flss (TOP
, v1
);
794 TOP
= Fleq (TOP
, v1
);
799 TOP
= Fgeq (TOP
, v1
);
804 TOP
= Fminus (2, &TOP
);
811 XSETINT (v1
, - XINT (v1
));
815 TOP
= Fminus (1, &TOP
);
820 TOP
= Fplus (2, &TOP
);
825 TOP
= Fmax (2, &TOP
);
830 TOP
= Fmin (2, &TOP
);
835 TOP
= Ftimes (2, &TOP
);
840 TOP
= Fquo (2, &TOP
);
845 TOP
= Frem (TOP
, v1
);
849 XSETFASTINT (v1
, PT
);
854 TOP
= Fgoto_char (TOP
);
858 TOP
= Finsert (1, &TOP
);
864 TOP
= Finsert (op
, &TOP
);
868 XSETFASTINT (v1
, ZV
);
873 XSETFASTINT (v1
, BEGV
);
878 TOP
= Fchar_after (TOP
);
881 case Bfollowing_char
:
882 v1
= Ffollowing_char ();
886 case Bpreceding_char
:
887 v1
= Fprevious_char ();
891 case Bcurrent_column
:
892 XSETFASTINT (v1
, current_column ());
897 TOP
= Findent_to (TOP
, Qnil
);
916 case Bcurrent_buffer
:
917 PUSH (Fcurrent_buffer ());
921 TOP
= Fset_buffer (TOP
);
925 PUSH (Fread_char ());
930 PUSH (Finteractive_p ());
934 TOP
= Fforward_char (TOP
);
938 TOP
= Fforward_word (TOP
);
941 case Bskip_chars_forward
:
943 TOP
= Fskip_chars_forward (TOP
, v1
);
946 case Bskip_chars_backward
:
948 TOP
= Fskip_chars_backward (TOP
, v1
);
952 TOP
= Fforward_line (TOP
);
956 CHECK_NUMBER (TOP
, 0);
958 syntax_code_spec
[(int) SYNTAX (XINT (TOP
))]);
961 case Bbuffer_substring
:
963 TOP
= Fbuffer_substring (TOP
, v1
);
968 TOP
= Fdelete_region (TOP
, v1
);
971 case Bnarrow_to_region
:
973 TOP
= Fnarrow_to_region (TOP
, v1
);
981 TOP
= Fend_of_line (TOP
);
987 TOP
= Fset_marker (TOP
, v2
, v1
);
990 case Bmatch_beginning
:
991 TOP
= Fmatch_beginning (TOP
);
995 TOP
= Fmatch_end (TOP
);
1003 TOP
= Fdowncase (TOP
);
1006 case Bstringeqlsign
:
1008 TOP
= Fstring_equal (TOP
, v1
);
1013 TOP
= Fstring_lessp (TOP
, v1
);
1018 TOP
= Fequal (TOP
, v1
);
1023 TOP
= Fnthcdr (TOP
, v1
);
1029 /* Exchange args and then do nth. */
1035 TOP
= Felt (TOP
, v1
);
1040 TOP
= Fmember (TOP
, v1
);
1045 TOP
= Fassq (TOP
, v1
);
1049 TOP
= Fnreverse (TOP
);
1054 TOP
= Fsetcar (TOP
, v1
);
1059 TOP
= Fsetcdr (TOP
, v1
);
1065 TOP
= XCONS (v1
)->car
;
1073 TOP
= XCONS (v1
)->cdr
;
1080 TOP
= Fnconc (2, &TOP
);
1084 TOP
= (NUMBERP (TOP
) ? Qt
: Qnil
);
1088 TOP
= INTEGERP (TOP
) ? Qt
: Qnil
;
1091 #ifdef BYTE_CODE_SAFE
1093 error ("set-mark is an obsolete bytecode");
1096 error ("scan-buffer is an obsolete bytecode");
1099 error ("mark is an obsolete bytecode");
1104 #ifdef BYTE_CODE_SAFE
1106 error ("unknown bytecode %d (byte compiler bug)", op
);
1107 if ((op
-= Bconstant
) >= const_length
)
1108 error ("no constant number %d (byte compiler bug)", op
);
1111 PUSH (vectorp
[op
- Bconstant
]);
1118 /* Binds and unbinds are supposed to be compiled balanced. */
1119 if (specpdl_ptr
- specpdl
!= count
)
1120 #ifdef BYTE_CODE_SAFE
1121 error ("binding stack not balanced (serious byte compiler bug)");
1130 Qbytecode
= intern ("byte-code");
1131 staticpro (&Qbytecode
);
1133 defsubr (&Sbyte_code
);
1135 #ifdef BYTE_CODE_METER
1137 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter
,
1138 "A vector of vectors which holds a histogram of byte-code usage.\n\
1139 (aref (aref byte-code-meter 0) CODE) indicates how many times the byte\n\
1140 opcode CODE has been executed.\n\
1141 (aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0,\n\
1142 indicates how many times the byte opcodes CODE1 and CODE2 have been\n\
1143 executed in succession.");
1144 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on
,
1145 "If non-nil, keep profiling information on byte code usage.\n\
1146 The variable byte-code-meter indicates how often each byte opcode is used.\n\
1147 If a symbol has a property named `byte-code-meter' whose value is an\n\
1148 integer, it is incremented each time that symbol's function is called.");
1150 byte_metering_on
= 0;
1151 Vbyte_code_meter
= Fmake_vector (make_number (256), make_number (0));
1152 Qbyte_code_meter
= intern ("byte-code-meter");
1153 staticpro (&Qbyte_code_meter
);
1157 XVECTOR (Vbyte_code_meter
)->contents
[i
] =
1158 Fmake_vector (make_number (256), make_number (0));