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