Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 424:11054d720c21 r21-2-20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-20
author cvs
date Mon, 13 Aug 2007 11:26:11 +0200
parents 41dbb7a9d5f2
children
comparison
equal deleted inserted replaced
423:28d9c139be4c 424:11054d720c21
233 #ifdef BYTE_CODE_METER 233 #ifdef BYTE_CODE_METER
234 234
235 Lisp_Object Vbyte_code_meter, Qbyte_code_meter; 235 Lisp_Object Vbyte_code_meter, Qbyte_code_meter;
236 int byte_metering_on; 236 int byte_metering_on;
237 237
238 #define METER_2(code1, code2) \ 238 static void
239 XINT (XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[(code1)])[(code2)]) 239 meter_code (Opcode prev_opcode, Opcode this_opcode)
240 240 {
241 #define METER_1(code) METER_2 (0, (code)) 241 if (byte_metering_on)
242 242 {
243 #define METER_CODE(last_code, this_code) do { \ 243 Lisp_Object *p = XVECTOR_DATA (XVECTOR_DATA (Vbyte_code_meter)[this_opcode]);
244 if (byte_metering_on) \ 244 p[0] = INT_PLUS1 (p[0]);
245 { \ 245 if (prev_opcode)
246 if (METER_1 (this_code) != ((1<<VALBITS)-1)) \ 246 p[prev_opcode] = INT_PLUS1 (p[prev_opcode]);
247 METER_1 (this_code)++; \ 247 }
248 if (last_code \ 248 }
249 && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
250 METER_2 (last_code, this_code)++; \
251 } \
252 } while (0)
253 249
254 #endif /* BYTE_CODE_METER */ 250 #endif /* BYTE_CODE_METER */
255 251
256 252
257 static Lisp_Object 253 static Lisp_Object
258 bytecode_negate (Lisp_Object obj) 254 bytecode_negate (Lisp_Object obj)
259 { 255 {
260 retry: 256 retry:
261 257
258 if (INTP (obj)) return make_int (- XINT (obj));
262 #ifdef LISP_FLOAT_TYPE 259 #ifdef LISP_FLOAT_TYPE
263 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); 260 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
264 #endif 261 #endif
265 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj))); 262 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
266 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj))); 263 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
267 if (INTP (obj)) return make_int (- XINT (obj));
268 264
269 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); 265 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
270 goto retry; 266 goto retry;
271 } 267 }
272 268
296 { 292 {
297 retry: 293 retry:
298 294
299 #ifdef LISP_FLOAT_TYPE 295 #ifdef LISP_FLOAT_TYPE
300 { 296 {
301 int ival1, ival2; 297 EMACS_INT ival1, ival2;
302 298
303 if (INTP (obj1)) ival1 = XINT (obj1); 299 if (INTP (obj1)) ival1 = XINT (obj1);
304 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 300 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
305 else if (MARKERP (obj1)) ival1 = marker_position (obj1); 301 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
306 else goto arithcompare_float; 302 else goto arithcompare_float;
340 336
341 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; 337 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
342 } 338 }
343 #else /* !LISP_FLOAT_TYPE */ 339 #else /* !LISP_FLOAT_TYPE */
344 { 340 {
345 int ival1, ival2; 341 EMACS_INT ival1, ival2;
346 342
347 if (INTP (obj1)) ival1 = XINT (obj1); 343 if (INTP (obj1)) ival1 = XINT (obj1);
348 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 344 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
349 else if (MARKERP (obj1)) ival1 = marker_position (obj1); 345 else if (MARKERP (obj1)) ival1 = marker_position (obj1);
350 else 346 else
369 365
370 static Lisp_Object 366 static Lisp_Object
371 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) 367 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
372 { 368 {
373 #ifdef LISP_FLOAT_TYPE 369 #ifdef LISP_FLOAT_TYPE
374 int ival1, ival2; 370 EMACS_INT ival1, ival2;
375 int float_p; 371 int float_p;
376 372
377 retry: 373 retry:
378 374
379 float_p = 0; 375 float_p = 0;
431 case Bmin: if (dval1 > dval2) dval1 = dval2; break; 427 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
432 } 428 }
433 return make_float (dval1); 429 return make_float (dval1);
434 } 430 }
435 #else /* !LISP_FLOAT_TYPE */ 431 #else /* !LISP_FLOAT_TYPE */
436 int ival1, ival2; 432 EMACS_INT ival1, ival2;
437 433
438 retry: 434 retry:
439 435
440 if (INTP (obj1)) ival1 = XINT (obj1); 436 if (INTP (obj1)) ival1 = XINT (obj1);
441 else if (CHARP (obj1)) ival1 = XCHAR (obj1); 437 else if (CHARP (obj1)) ival1 = XCHAR (obj1);
641 #endif 637 #endif
642 638
643 #ifdef BYTE_CODE_METER 639 #ifdef BYTE_CODE_METER
644 prev_opcode = this_opcode; 640 prev_opcode = this_opcode;
645 this_opcode = opcode; 641 this_opcode = opcode;
646 METER_CODE (prev_opcode, this_opcode); 642 meter_code (prev_opcode, this_opcode);
647 #endif 643 #endif
648 644
649 switch (opcode) 645 switch (opcode)
650 { 646 {
651 REGISTER int n; 647 REGISTER int n;
758 UNBIND_TO (specpdl_depth() - 754 UNBIND_TO (specpdl_depth() -
759 (opcode < Bunbind+6 ? opcode-Bunbind : 755 (opcode < Bunbind+6 ? opcode-Bunbind :
760 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2)); 756 opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
761 break; 757 break;
762 758
759
763 case Bgoto: 760 case Bgoto:
764 JUMP; 761 JUMP;
765 break; 762 break;
766 763
767 case Bgotoifnil: 764 case Bgotoifnil:
995 TOP = Fget (TOP, arg, Qnil); 992 TOP = Fget (TOP, arg, Qnil);
996 break; 993 break;
997 } 994 }
998 995
999 case Bsub1: 996 case Bsub1:
1000 TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP); 997 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1001 break; 998 break;
1002 999
1003 case Badd1: 1000 case Badd1:
1004 TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP); 1001 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1005 break; 1002 break;
1006 1003
1007 1004
1008 case Beqlsign: 1005 case Beqlsign:
1009 { 1006 {
1053 case Bplus: 1050 case Bplus:
1054 { 1051 {
1055 Lisp_Object arg2 = POP; 1052 Lisp_Object arg2 = POP;
1056 Lisp_Object arg1 = TOP; 1053 Lisp_Object arg1 = TOP;
1057 TOP = INTP (arg1) && INTP (arg2) ? 1054 TOP = INTP (arg1) && INTP (arg2) ?
1058 make_int (XINT (arg1) + XINT (arg2)) : 1055 INT_PLUS (arg1, arg2) :
1059 bytecode_arithop (arg1, arg2, opcode); 1056 bytecode_arithop (arg1, arg2, opcode);
1060 break; 1057 break;
1061 } 1058 }
1062 1059
1063 case Bdiff: 1060 case Bdiff:
1064 { 1061 {
1065 Lisp_Object arg2 = POP; 1062 Lisp_Object arg2 = POP;
1066 Lisp_Object arg1 = TOP; 1063 Lisp_Object arg1 = TOP;
1067 TOP = INTP (arg1) && INTP (arg2) ? 1064 TOP = INTP (arg1) && INTP (arg2) ?
1068 make_int (XINT (arg1) - XINT (arg2)) : 1065 INT_MINUS (arg1, arg2) :
1069 bytecode_arithop (arg1, arg2, opcode); 1066 bytecode_arithop (arg1, arg2, opcode);
1070 break; 1067 break;
1071 } 1068 }
1072 1069
1073 case Bmult: 1070 case Bmult:
1105 { 1102 {
1106 Lisp_Object arg = POP; 1103 Lisp_Object arg = POP;
1107 TOP = Fmemq (TOP, arg); 1104 TOP = Fmemq (TOP, arg);
1108 break; 1105 break;
1109 } 1106 }
1110
1111 1107
1112 case Bset: 1108 case Bset:
1113 { 1109 {
1114 Lisp_Object arg = POP; 1110 Lisp_Object arg = POP;
1115 TOP = Fset (TOP, arg); 1111 TOP = Fset (TOP, arg);
1892 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); 1888 program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions));
1893 optimize_byte_code (f->instructions, f->constants, 1889 optimize_byte_code (f->instructions, f->constants,
1894 program, &program_length, &varbind_count); 1890 program, &program_length, &varbind_count);
1895 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count; 1891 f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count;
1896 f->instructions = 1892 f->instructions =
1897 Fpurecopy (make_opaque (program_length * sizeof (Opbyte), 1893 make_opaque (program_length * sizeof (Opbyte),
1898 (CONST void *) program)); 1894 (CONST void *) program);
1899 } 1895 }
1900 1896
1901 assert (OPAQUEP (f->instructions)); 1897 assert (OPAQUEP (f->instructions));
1902 } 1898 }
1903 1899
1979 write_c_string (print_readably ? "]" : ">", printcharfun); 1975 write_c_string (print_readably ? "]" : ">", printcharfun);
1980 } 1976 }
1981 1977
1982 1978
1983 static Lisp_Object 1979 static Lisp_Object
1984 mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) 1980 mark_compiled_function (Lisp_Object obj)
1985 { 1981 {
1986 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); 1982 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj);
1987 1983
1988 markobj (f->instructions); 1984 mark_object (f->instructions);
1989 markobj (f->arglist); 1985 mark_object (f->arglist);
1990 markobj (f->doc_and_interactive); 1986 mark_object (f->doc_and_interactive);
1991 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK 1987 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
1992 markobj (f->annotated); 1988 mark_object (f->annotated);
1993 #endif 1989 #endif
1994 /* tail-recurse on constants */ 1990 /* tail-recurse on constants */
1995 return f->constants; 1991 return f->constants;
1996 } 1992 }
1997 1993
2348 if (!CONSP (tem)) 2344 if (!CONSP (tem))
2349 signal_simple_error ("Invalid lazy-loaded byte code", tem); 2345 signal_simple_error ("Invalid lazy-loaded byte code", tem);
2350 /* v18 or v19 bytecode file. Need to Ebolify. */ 2346 /* v18 or v19 bytecode file. Need to Ebolify. */
2351 if (f->flags.ebolified && VECTORP (XCDR (tem))) 2347 if (f->flags.ebolified && VECTORP (XCDR (tem)))
2352 ebolify_bytecode_constants (XCDR (tem)); 2348 ebolify_bytecode_constants (XCDR (tem));
2353 /* VERY IMPORTANT to purecopy here!!!!! 2349 f->instructions = XCAR (tem);
2354 See load_force_doc_string_unwind. */ 2350 f->constants = XCDR (tem);
2355 f->instructions = Fpurecopy (XCAR (tem));
2356 f->constants = Fpurecopy (XCDR (tem));
2357 return function; 2351 return function;
2358 } 2352 }
2359 abort (); 2353 abort ();
2360 return Qnil; /* not reached */ 2354 return Qnil; /* not reached */
2361 } 2355 }