Mercurial > emacs

comparison src/bytecode.c @ 435:43e88c4db330

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
*** empty log message ***
author Richard M. Stallman <rms@gnu.org>
date Tue, 26 Nov 1991 05:00:30 +0000
parents d0eb77a4d8f7
children db84d8d9a1d9
comparison
equal deleted inserted replaced
434:ab8836c672bd 435:43e88c4db330
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19 19
20 hacked on by jwz@lucid.com 17-jun-91 20 hacked on by jwz@lucid.com 17-jun-91
21 o added a compile-time switch to turn on simple sanity checking; 21 o added a compile-time switch to turn on simple sanity checking;
22 o put back the obsolete byte-codes for error-detection; 22 o put back the obsolete byte-codes for error-detection;
23 o put back fset, symbol-function, and read-char because I don't
24 see any reason for them to have been removed;
25 o added a new instruction, unbind_all, which I will use for 23 o added a new instruction, unbind_all, which I will use for
26 tail-recursion elimination; 24 tail-recursion elimination;
27 o made temp_output_buffer_show() be called with the right number 25 o made temp_output_buffer_show be called with the right number
28 of args; 26 of args;
29 o made the new bytecodes be called with args in the right order; 27 o made the new bytecodes be called with args in the right order;
30 o added metering support. 28 o added metering support.
31 29
32 by Hallvard: 30 by Hallvard:
33 o added relative jump instructions. 31 o added relative jump instructions;
34 o all conditionals now only do QUIT if they jump. 32 o all conditionals now only do QUIT if they jump.
35 */ 33 */
36
37 34
38 #include "config.h" 35 #include "config.h"
39 #include "lisp.h" 36 #include "lisp.h"
40 #include "buffer.h" 37 #include "buffer.h"
41 #include "syntax.h" 38 #include "syntax.h"
44 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for 41 * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
45 * debugging the byte compiler...) 42 * debugging the byte compiler...)
46 * 43 *
47 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. 44 * define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
48 */ 45 */
49 #define BYTE_CODE_SAFE 46 /* #define BYTE_CODE_SAFE */
50 #define BYTE_CODE_METER 47 /* #define BYTE_CODE_METER */
51 48
52 49
53 #ifdef BYTE_CODE_METER 50 #ifdef BYTE_CODE_METER
54 51
55 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; 52 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
56 int byte_metering_on; 53 int byte_metering_on;
57 54
58 # define METER_2(code1,code2) \ 55 #define METER_2(code1, code2) \
59 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \ 56 XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
60 ->contents[(code2)]) 57 ->contents[(code2)])
61 58
62 # define METER_1(code) METER_2 (0,(code)) 59 #define METER_1(code) METER_2 (0, (code))
63 60
64 # define METER_CODE(last_code, this_code) { \ 61 #define METER_CODE(last_code, this_code) \
65 if (byte_metering_on) { \ 62 { \
66 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \ 63 if (byte_metering_on) \
67 METER_1 (this_code) ++; \ 64 { \
68 if (last_code && \ 65 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
69 METER_2 (last_code,this_code) != ((1<<VALBITS)-1)) \ 66 METER_1 (this_code)++; \
70 METER_2 (last_code,this_code) ++; \ 67 if (last_code \
71 } \ 68 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
72 } 69 METER_2 (last_code, this_code)++; \
73 70 } \
74 #else /* ! BYTE_CODE_METER */ 71 }
75 72
76 # define meter_code(last_code, this_code) 73 #else /* no BYTE_CODE_METER */
77 74
78 #endif 75 #define METER_CODE(last_code, this_code)
76
77 #endif /* no BYTE_CODE_METER */
79 78
80 79
81 Lisp_Object Qbytecode; 80 Lisp_Object Qbytecode;
82 81
83 /* Byte codes: */ 82 /* Byte codes: */
105 #define Blist4 0106 104 #define Blist4 0106
106 #define Blength 0107 105 #define Blength 0107
107 #define Baref 0110 106 #define Baref 0110
108 #define Baset 0111 107 #define Baset 0111
109 #define Bsymbol_value 0112 108 #define Bsymbol_value 0112
110 #define Bsymbol_function 0113 109 #define Bsymbol_function 0113 /* no longer generated as of v19 */
111 #define Bset 0114 110 #define Bset 0114
112 #define Bfset 0115 111 #define Bfset 0115 /* no longer generated as of v19 */
113 #define Bget 0116 112 #define Bget 0116
114 #define Bsubstring 0117 113 #define Bsubstring 0117
115 #define Bconcat2 0120 114 #define Bconcat2 0120
116 #define Bconcat3 0121 115 #define Bconcat3 0121
117 #define Bconcat4 0122 116 #define Bconcat4 0122
215 #define BRgotoifnilelsepop 0255 214 #define BRgotoifnilelsepop 0255
216 #define BRgotoifnonnilelsepop 0256 215 #define BRgotoifnonnilelsepop 0256
217 216
218 #define BlistN 0257 217 #define BlistN 0257
219 #define BconcatN 0260 218 #define BconcatN 0260
219 #define BinsertN 0261
220 220
221 #define Bconstant 0300 221 #define Bconstant 0300
222 #define CONSTANTLIM 0100 222 #define CONSTANTLIM 0100
223 223
224 /* Fetch the next byte from the bytecode stream */ 224 /* Fetch the next byte from the bytecode stream */
299 299
300 while (1) 300 while (1)
301 { 301 {
302 #ifdef BYTE_CODE_SAFE 302 #ifdef BYTE_CODE_SAFE
303 if (stackp > stacke) 303 if (stackp > stacke)
304 error ( 304 error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
305 "Stack overflow in byte code (byte compiler bug), pc = %d, depth = %d",
306 pc - XSTRING (string_saved)->data, stacke - stackp); 305 pc - XSTRING (string_saved)->data, stacke - stackp);
307 if (stackp < stack) 306 if (stackp < stack)
308 error ("Stack underflow in byte code (byte compiler bug), pc = %d", 307 error ("Byte code stack underflow (byte compiler bug), pc %d",
309 pc - XSTRING (string_saved)->data); 308 pc - XSTRING (string_saved)->data);
310 #endif 309 #endif
311 310
312 if (string_saved != bytestr) 311 if (string_saved != bytestr)
313 { 312 {
404 403
405 case Bcall: case Bcall+1: case Bcall+2: case Bcall+3: 404 case Bcall: case Bcall+1: case Bcall+2: case Bcall+3:
406 case Bcall+4: case Bcall+5: 405 case Bcall+4: case Bcall+5:
407 op -= Bcall; 406 op -= Bcall;
408 docall: 407 docall:
409 DISCARD(op); 408 DISCARD (op);
410 #ifdef BYTE_CODE_METER 409 #ifdef BYTE_CODE_METER
411 if (byte_metering_on && XTYPE (TOP) == Lisp_Symbol) 410 if (byte_metering_on && XTYPE (TOP) == Lisp_Symbol)
412 { 411 {
413 v1 = TOP; 412 v1 = TOP;
414 v2 = Fget (v1, Qbyte_code_meter); 413 v2 = Fget (v1, Qbyte_code_meter);
417 XSETINT (v2, XINT (v2) + 1); 416 XSETINT (v2, XINT (v2) + 1);
418 Fput (v1, Qbyte_code_meter, v2); 417 Fput (v1, Qbyte_code_meter, v2);
419 } 418 }
420 } 419 }
421 #endif 420 #endif
421 /* The frobbing of gcpro3 was lost by jwz's changes in June 91
422 and then reinserted by jwz in Nov 91. */
423 /* Remove protection from the args we are giving to Ffuncall.
424 FFuncall will protect them, and double protection would
425 cause disasters. */
426 gcpro3.nvars = &TOP - stack - 1;
422 TOP = Ffuncall (op + 1, &TOP); 427 TOP = Ffuncall (op + 1, &TOP);
428 gcpro3.nvars = XFASTINT (maxdepth);
423 break; 429 break;
424 430
425 case Bunbind+6: 431 case Bunbind+6:
426 op = FETCH; 432 op = FETCH;
427 goto dounbind; 433 goto dounbind;
437 unbind_to (specpdl_ptr - specpdl - op, Qnil); 443 unbind_to (specpdl_ptr - specpdl - op, Qnil);
438 break; 444 break;
439 445
440 case Bunbind_all: 446 case Bunbind_all:
441 /* To unbind back to the beginning of this frame. Not used yet, 447 /* To unbind back to the beginning of this frame. Not used yet,
442 but wil be needed for tail-recursion elimination. 448 but will be needed for tail-recursion elimination. */
443 */
444 unbind_to (count, Qnil); 449 unbind_to (count, Qnil);
445 break; 450 break;
446 451
447 case Bgoto: 452 case Bgoto:
448 QUIT; 453 QUIT;
473 if (NULL (TOP)) 478 if (NULL (TOP))
474 { 479 {
475 QUIT; 480 QUIT;
476 pc = XSTRING (string_saved)->data + op; 481 pc = XSTRING (string_saved)->data + op;
477 } 482 }
478 else DISCARD(1); 483 else DISCARD (1);
479 break; 484 break;
480 485
481 case Bgotoifnonnilelsepop: 486 case Bgotoifnonnilelsepop:
482 op = FETCH2; 487 op = FETCH2;
483 if (!NULL (TOP)) 488 if (!NULL (TOP))
484 { 489 {
485 QUIT; 490 QUIT;
486 pc = XSTRING (string_saved)->data + op; 491 pc = XSTRING (string_saved)->data + op;
487 } 492 }
488 else DISCARD(1); 493 else DISCARD (1);
489 break; 494 break;
490 495
491 case BRgoto: 496 case BRgoto:
492 QUIT; 497 QUIT;
493 pc += *pc - 127; 498 pc += *pc - 127;
516 if (NULL (TOP)) 521 if (NULL (TOP))
517 { 522 {
518 QUIT; 523 QUIT;
519 pc += op - 128; 524 pc += op - 128;
520 } 525 }
521 else DISCARD(1); 526 else DISCARD (1);
522 break; 527 break;
523 528
524 case BRgotoifnonnilelsepop: 529 case BRgotoifnonnilelsepop:
525 op = *pc++; 530 op = *pc++;
526 if (!NULL (TOP)) 531 if (!NULL (TOP))
527 { 532 {
528 QUIT; 533 QUIT;
529 pc += op - 128; 534 pc += op - 128;
530 } 535 }
531 else DISCARD(1); 536 else DISCARD (1);
532 break; 537 break;
533 538
534 case Breturn: 539 case Breturn:
535 v1 = POP; 540 v1 = POP;
536 goto exit; 541 goto exit;
537 542
538 case Bdiscard: 543 case Bdiscard:
539 DISCARD(1); 544 DISCARD (1);
540 break; 545 break;
541 546
542 case Bdup: 547 case Bdup:
543 v1 = TOP; 548 v1 = TOP;
544 PUSH (v1); 549 PUSH (v1);
669 v1 = POP; 674 v1 = POP;
670 TOP = Fcons (TOP, Fcons (v1, Qnil)); 675 TOP = Fcons (TOP, Fcons (v1, Qnil));
671 break; 676 break;
672 677
673 case Blist3: 678 case Blist3:
674 DISCARD(2); 679 DISCARD (2);
675 TOP = Flist (3, &TOP); 680 TOP = Flist (3, &TOP);
676 break; 681 break;
677 682
678 case Blist4: 683 case Blist4:
679 DISCARD(3); 684 DISCARD (3);
680 TOP = Flist (4, &TOP); 685 TOP = Flist (4, &TOP);
681 break; 686 break;
682 687
683 case BlistN: 688 case BlistN:
684 op = FETCH; 689 op = FETCH;
727 v2 = POP; v1 = POP; 732 v2 = POP; v1 = POP;
728 TOP = Fsubstring (TOP, v1, v2); 733 TOP = Fsubstring (TOP, v1, v2);
729 break; 734 break;
730 735
731 case Bconcat2: 736 case Bconcat2:
732 DISCARD(1); 737 DISCARD (1);
733 TOP = Fconcat (2, &TOP); 738 TOP = Fconcat (2, &TOP);
734 break; 739 break;
735 740
736 case Bconcat3: 741 case Bconcat3:
737 DISCARD(2); 742 DISCARD (2);
738 TOP = Fconcat (3, &TOP); 743 TOP = Fconcat (3, &TOP);
739 break; 744 break;
740 745
741 case Bconcat4: 746 case Bconcat4:
742 DISCARD(3); 747 DISCARD (3);
743 TOP = Fconcat (4, &TOP); 748 TOP = Fconcat (4, &TOP);
744 break; 749 break;
745 750
746 case BconcatN: 751 case BconcatN:
747 op = FETCH; 752 op = FETCH;
797 v1 = POP; 802 v1 = POP;
798 TOP = Fgeq (TOP, v1); 803 TOP = Fgeq (TOP, v1);
799 break; 804 break;
800 805
801 case Bdiff: 806 case Bdiff:
802 DISCARD(1); 807 DISCARD (1);
803 TOP = Fminus (2, &TOP); 808 TOP = Fminus (2, &TOP);
804 break; 809 break;
805 810
806 case Bnegate: 811 case Bnegate:
807 v1 = TOP; 812 v1 = TOP;
813 else 818 else
814 TOP = Fminus (1, &TOP); 819 TOP = Fminus (1, &TOP);
815 break; 820 break;
816 821
817 case Bplus: 822 case Bplus:
818 DISCARD(1); 823 DISCARD (1);
819 TOP = Fplus (2, &TOP); 824 TOP = Fplus (2, &TOP);
820 break; 825 break;
821 826
822 case Bmax: 827 case Bmax:
823 DISCARD(1); 828 DISCARD (1);
824 TOP = Fmax (2, &TOP); 829 TOP = Fmax (2, &TOP);
825 break; 830 break;
826 831
827 case Bmin: 832 case Bmin:
828 DISCARD(1); 833 DISCARD (1);
829 TOP = Fmin (2, &TOP); 834 TOP = Fmin (2, &TOP);
830 break; 835 break;
831 836
832 case Bmult: 837 case Bmult:
833 DISCARD(1); 838 DISCARD (1);
834 TOP = Ftimes (2, &TOP); 839 TOP = Ftimes (2, &TOP);
835 break; 840 break;
836 841
837 case Bquo: 842 case Bquo:
838 DISCARD(1); 843 DISCARD (1);
839 TOP = Fquo (2, &TOP); 844 TOP = Fquo (2, &TOP);
840 break; 845 break;
841 846
842 case Brem: 847 case Brem:
843 v1 = POP; 848 v1 = POP;
853 TOP = Fgoto_char (TOP); 858 TOP = Fgoto_char (TOP);
854 break; 859 break;
855 860
856 case Binsert: 861 case Binsert:
857 TOP = Finsert (1, &TOP); 862 TOP = Finsert (1, &TOP);
863 break;
864
865 case BinsertN:
866 op = FETCH;
867 DISCARD (op - 1);
868 TOP = Finsert (op, &TOP);
858 break; 869 break;
859 870
860 case Bpoint_max: 871 case Bpoint_max:
861 XFASTINT (v1) = ZV; 872 XFASTINT (v1) = ZV;
862 PUSH (v1); 873 PUSH (v1);
1066 else 1077 else
1067 TOP = Qnil; 1078 TOP = Qnil;
1068 break; 1079 break;
1069 1080
1070 case Bnconc: 1081 case Bnconc:
1071 DISCARD(1); 1082 DISCARD (1);
1072 TOP = Fnconc (2, &TOP); 1083 TOP = Fnconc (2, &TOP);
1073 break; 1084 break;
1074 1085
1075 case Bnumberp: 1086 case Bnumberp:
1076 TOP = (XTYPE (TOP) == Lisp_Int || XTYPE (TOP) == Lisp_Float 1087 TOP = (XTYPE (TOP) == Lisp_Int || XTYPE (TOP) == Lisp_Float
1087 break; 1098 break;
1088 case Bscan_buffer: 1099 case Bscan_buffer:
1089 error ("scan-buffer is an obsolete bytecode"); 1100 error ("scan-buffer is an obsolete bytecode");
1090 break; 1101 break;
1091 case Bmark: 1102 case Bmark:
1092 error("mark is an obsolete bytecode"); 1103 error ("mark is an obsolete bytecode");
1093 break; 1104 break;
1094 #endif 1105 #endif
1095 1106
1096 default: 1107 default:
1097 #ifdef BYTE_CODE_SAFE 1108 #ifdef BYTE_CODE_SAFE
1126 defsubr (&Sbyte_code); 1137 defsubr (&Sbyte_code);
1127 1138
1128 #ifdef BYTE_CODE_METER 1139 #ifdef BYTE_CODE_METER
1129 1140
1130 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter, 1141 DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter,
1131 "a vector of vectors which holds a histogram of byte-code usage."); 1142 "A vector of vectors which holds a histogram of byte-code usage.");
1132 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on, ""); 1143 DEFVAR_BOOL ("byte-metering-on", &byte_metering_on, "");
1133 1144
1134 byte_metering_on = 0; 1145 byte_metering_on = 0;
1135 Vbyte_code_meter = Fmake_vector(make_number(256), make_number(0)); 1146 Vbyte_code_meter = Fmake_vector (make_number (256), make_number (0));
1147 Qbyte_code_meter = intern ("byte-code-meter");
1136 staticpro (&Qbyte_code_meter); 1148 staticpro (&Qbyte_code_meter);
1137 { 1149 {
1138 int i = 256; 1150 int i = 256;
1139 while (i--) 1151 while (i--)
1140 XVECTOR(Vbyte_code_meter)->contents[i] = 1152 XVECTOR (Vbyte_code_meter)->contents[i] =
1141 Fmake_vector(make_number(256), make_number(0)); 1153 Fmake_vector (make_number (256), make_number (0));
1142 } 1154 }
1143 #endif 1155 #endif
1144 } 1156 }