Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 428:3ecd8885ac67 r21-2-22

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