Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 380:8626e4521993 r21-2-5

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