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