Mercurial > emacs

comparison src/bytecode.c @ 26363:efb608f1cb10

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(struct byte_stack): New. (byte_stack_list, mark_byte_stack, relocate_byte_pcs): New (BEFORE_POTENTIAL_GC, AFTER_POTENTIAL_GC): New. (FETCH, PUSH, POP, DISCARD, TOP, MAYBE_GC): Rewritten. (HANDLE_RELOCATION): Removed. (Fbyte_code): Use byte_stack structures.
author Gerd Moellmann <gerd@gnu.org>
date Fri, 05 Nov 1999 21:26:15 +0000
parents a14111a2a100
children b3378aff433e
comparison
equal deleted inserted replaced
26362:dc0efddbdd77 26363:efb608f1cb10
222 #define BconcatN 0260 222 #define BconcatN 0260
223 #define BinsertN 0261 223 #define BinsertN 0261
224 224
225 #define Bconstant 0300 225 #define Bconstant 0300
226 #define CONSTANTLIM 0100 226 #define CONSTANTLIM 0100
227
228 /* Structure describing a value stack used during byte-code execution
229 in Fbyte_code. */
230
231 struct byte_stack
232 {
233 /* Program counter. This points into the byte_string below
234 and is relocated when that string is relocated. */
235 unsigned char *pc;
236
237 /* Top and bottom of stack. The bottom points to an area of memory
238 allocated with alloca in Fbyte_code. */
239 Lisp_Object *top, *bottom;
240
241 /* The string containing the byte-code, and its current address.
242 Storing this here protects it from GC because mark_byte_stack
243 marks it. */
244 Lisp_Object byte_string;
245 unsigned char *byte_string_start;
246
247 /* The vector of constants used during byte-code execution. Storing
248 this here protects it from GC because mark_byte_stack marks it. */
249 Lisp_Object constants;
250
251 /* Next entry in byte_stack_list. */
252 struct byte_stack *next;
253 };
254
255 /* A list of currently active byte-code execution value stacks.
256 Fbyte_code adds an entry to the head of this list before it starts
257 processing byte-code, and it removed the entry again when it is
258 done. Signalling an error truncates the list analoguous to
259 gcprolist. */
260
261 struct byte_stack *byte_stack_list;
262
263 /* Mark objects on byte_stack_list. Called during GC. */
264
265 void
266 mark_byte_stack ()
267 {
268 struct byte_stack *stack;
269 Lisp_Object *obj;
270
271 for (stack = byte_stack_list; stack; stack = stack->next)
272 {
273 if (!stack->top)
274 abort ();
275
276 for (obj = stack->bottom; obj <= stack->top; ++obj)
277 mark_object (obj);
278
279 mark_object (&stack->byte_string);
280 mark_object (&stack->constants);
281 }
282 }
283
284
285 /* Relocate program counters in the stacks on byte_stack_list. Called
286 when GC has completed. */
287
288 void
289 relocate_byte_pcs ()
290 {
291 struct byte_stack *stack;
292
293 for (stack = byte_stack_list; stack; stack = stack->next)
294 if (stack->byte_string_start != XSTRING (stack->byte_string)->data)
295 {
296 int offset = stack->pc - stack->byte_string_start;
297 stack->byte_string_start = XSTRING (stack->byte_string)->data;
298 stack->pc = stack->byte_string_start + offset;
299 }
300 }
301
302
227 303
228 /* Fetch the next byte from the bytecode stream */ 304 /* Fetch the next byte from the bytecode stream */
229 305
230 #define FETCH *pc++ 306 #define FETCH *stack.pc++
231 307
232 /* Fetch two bytes from the bytecode stream 308 /* Fetch two bytes from the bytecode stream
233 and make a 16-bit number out of them */ 309 and make a 16-bit number out of them */
234 310
235 #define FETCH2 (op = FETCH, op + (FETCH << 8)) 311 #define FETCH2 (op = FETCH, op + (FETCH << 8))
236 312
237 /* Push x onto the execution stack. */ 313 /* Push x onto the execution stack. */
238 314
239 /* This used to be #define PUSH(x) (*++stackp = (x)) 315 /* This used to be #define PUSH(x) (*++stackp = (x)) This oddity is
240 This oddity is necessary because Alliant can't be bothered to 316 necessary because Alliant can't be bothered to compile the
241 compile the preincrement operator properly, as of 4/91. -JimB */ 317 preincrement operator properly, as of 4/91. -JimB */
242 #define PUSH(x) (stackp++, *stackp = (x)) 318
319 #define PUSH(x) (top++, *top = (x))
243 320
244 /* Pop a value off the execution stack. */ 321 /* Pop a value off the execution stack. */
245 322
246 #define POP (*stackp--) 323 #define POP (*top--)
247 324
248 /* Discard n values from the execution stack. */ 325 /* Discard n values from the execution stack. */
249 326
250 #define DISCARD(n) (stackp -= (n)) 327 #define DISCARD(n) (top -= (n))
251 328
252 /* Get the value which is at the top of the execution stack, but don't pop it. */ 329 /* Get the value which is at the top of the execution stack, but don't
253 330 pop it. */
254 #define TOP (*stackp) 331
332 #define TOP (*top)
333
334 /* Actions that must performed before and after calling a function
335 that might GC. */
336
337 #define BEFORE_POTENTIAL_GC() stack.top = top
338 #define AFTER_POTENTIAL_GC() stack.top = NULL
255 339
256 /* Garbage collect if we have consed enough since the last time. 340 /* Garbage collect if we have consed enough since the last time.
257 We do this at every branch, to avoid loops that never GC. */ 341 We do this at every branch, to avoid loops that never GC. */
258 342
259 #define MAYBE_GC() \ 343 #define MAYBE_GC() \
260 if (consing_since_gc > gc_cons_threshold) \ 344 if (consing_since_gc > gc_cons_threshold) \
261 { \ 345 { \
346 BEFORE_POTENTIAL_GC (); \
262 Fgarbage_collect (); \ 347 Fgarbage_collect (); \
263 HANDLE_RELOCATION (); \ 348 AFTER_POTENTIAL_GC (); \
264 } \ 349 } \
265 else 350 else
266 351
267 /* Relocate BYTESTR if there has been a GC recently. */
268 #define HANDLE_RELOCATION() \
269 if (! EQ (string_saved, bytestr)) \
270 { \
271 pc = pc - XSTRING (string_saved)->data + XSTRING (bytestr)->data; \
272 string_saved = bytestr; \
273 } \
274 else
275
276 /* Check for jumping out of range. */ 352 /* Check for jumping out of range. */
353
354 #ifdef BYTE_CODE_SAFE
355
277 #define CHECK_RANGE(ARG) \ 356 #define CHECK_RANGE(ARG) \
278 if (ARG >= bytestr_length) abort () 357 if (ARG >= bytestr_length) abort ()
358
359 #else
360
361 #define CHECK_RANGE(ARG)
362
363 #endif
364
279 365
280 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0, 366 DEFUN ("byte-code", Fbyte_code, Sbyte_code, 3, 3, 0,
281 "Function used internally in byte-compiled code.\n\ 367 "Function used internally in byte-compiled code.\n\
282 The first argument, BYTESTR, is a string of byte code;\n\ 368 The first argument, BYTESTR, is a string of byte code;\n\
283 the second, VECTOR, a vector of constants;\n\ 369 the second, VECTOR, a vector of constants;\n\
284 the third, MAXDEPTH, the maximum stack depth used in this function.\n\ 370 the third, MAXDEPTH, the maximum stack depth used in this function.\n\
285 If the third argument is incorrect, Emacs may crash.") 371 If the third argument is incorrect, Emacs may crash.")
286 (bytestr, vector, maxdepth) 372 (bytestr, vector, maxdepth)
287 Lisp_Object bytestr, vector, maxdepth; 373 Lisp_Object bytestr, vector, maxdepth;
288 { 374 {
289 struct gcpro gcpro1, gcpro2, gcpro3;
290 int count = specpdl_ptr - specpdl; 375 int count = specpdl_ptr - specpdl;
291 #ifdef BYTE_CODE_METER 376 #ifdef BYTE_CODE_METER
292 int this_op = 0; 377 int this_op = 0;
293 int prev_op; 378 int prev_op;
294 #endif 379 #endif
295 register int op; 380 int op;
296 unsigned char *pc; 381 Lisp_Object v1, v2;
297 Lisp_Object *stack; 382 Lisp_Object *stackp;
298 register Lisp_Object *stackp; 383 Lisp_Object *vectorp = XVECTOR (vector)->contents;
384 #ifdef BYTE_CODE_SAFE
385 int const_length = XVECTOR (vector)->size;
299 Lisp_Object *stacke; 386 Lisp_Object *stacke;
300 register Lisp_Object v1, v2;
301 register Lisp_Object *vectorp = XVECTOR (vector)->contents;
302 #ifdef BYTE_CODE_SAFE
303 register int const_length = XVECTOR (vector)->size;
304 #endif 387 #endif
305 /* Copy of BYTESTR, saved so we can tell if BYTESTR was relocated. */
306 Lisp_Object string_saved;
307 /* Cached address of beginning of string,
308 valid if BYTESTR equals STRING_SAVED. */
309 register unsigned char *strbeg;
310 int bytestr_length = STRING_BYTES (XSTRING (bytestr)); 388 int bytestr_length = STRING_BYTES (XSTRING (bytestr));
389 struct byte_stack stack;
390 Lisp_Object *top;
311 391
312 CHECK_STRING (bytestr, 0); 392 CHECK_STRING (bytestr, 0);
313 if (!VECTORP (vector)) 393 if (!VECTORP (vector))
314 vector = wrong_type_argument (Qvectorp, vector); 394 vector = wrong_type_argument (Qvectorp, vector);
315 CHECK_NUMBER (maxdepth, 2); 395 CHECK_NUMBER (maxdepth, 2);
316 396
317 stackp = (Lisp_Object *) alloca (XFASTINT (maxdepth) * sizeof (Lisp_Object)); 397 stack.byte_string = bytestr;
318 bzero (stackp, XFASTINT (maxdepth) * sizeof (Lisp_Object)); 398 stack.pc = stack.byte_string_start = XSTRING (bytestr)->data;
319 GCPRO3 (bytestr, vector, *stackp); 399 stack.constants = vector;
320 gcpro3.nvars = XFASTINT (maxdepth); 400 stack.bottom = (Lisp_Object *) alloca (XFASTINT (maxdepth)
321 401 * sizeof (Lisp_Object));
322 --stackp; 402 top = stack.bottom - 1;
323 stack = stackp; 403 stack.top = NULL;
324 stacke = stackp + XFASTINT (maxdepth); 404 stack.next = byte_stack_list;
325 405 byte_stack_list = &stack;
326 /* Initialize the saved pc-pointer for fetching from the string. */ 406
327 string_saved = bytestr; 407 #ifdef BYTE_CODE_SAFE
328 pc = XSTRING (string_saved)->data; 408 stacke = stack.bottom - 1 + XFASTINT (maxdepth);
329 409 #endif
410
330 while (1) 411 while (1)
331 { 412 {
332 #ifdef BYTE_CODE_SAFE 413 #ifdef BYTE_CODE_SAFE
333 if (stackp > stacke) 414 if (top > stacks)
334 error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d", 415 error ("Byte code stack overflow (byte compiler bug), pc %d, depth %d",
335 pc - XSTRING (string_saved)->data, stacke - stackp); 416 stack.pc - stack.byte_string_start, stacke - top);
336 if (stackp < stack) 417 else if (top < stack.bottom - 1)
337 error ("Byte code stack underflow (byte compiler bug), pc %d", 418 error ("Byte code stack underflow (byte compiler bug), pc %d",
338 pc - XSTRING (string_saved)->data); 419 stack.pc - stack.byte_string_start);
339 #endif 420 #endif
340
341 /* Update BYTESTR if we had a garbage collection. */
342 HANDLE_RELOCATION ();
343 421
344 #ifdef BYTE_CODE_METER 422 #ifdef BYTE_CODE_METER
345 prev_op = this_op; 423 prev_op = this_op;
346 this_op = op = FETCH; 424 this_op = op = FETCH;
347 METER_CODE (prev_op, op); 425 METER_CODE (prev_op, op);
428 XSETINT (v2, XINT (v2) + 1); 506 XSETINT (v2, XINT (v2) + 1);
429 Fput (v1, Qbyte_code_meter, v2); 507 Fput (v1, Qbyte_code_meter, v2);
430 } 508 }
431 } 509 }
432 #endif 510 #endif
511 BEFORE_POTENTIAL_GC ();
433 TOP = Ffuncall (op + 1, &TOP); 512 TOP = Ffuncall (op + 1, &TOP);
513 AFTER_POTENTIAL_GC ();
434 break; 514 break;
435 515
436 case Bunbind+6: 516 case Bunbind+6:
437 op = FETCH; 517 op = FETCH;
438 goto dounbind; 518 goto dounbind;
443 523
444 case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3: 524 case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3:
445 case Bunbind+4: case Bunbind+5: 525 case Bunbind+4: case Bunbind+5:
446 op -= Bunbind; 526 op -= Bunbind;
447 dounbind: 527 dounbind:
528 BEFORE_POTENTIAL_GC ();
448 unbind_to (specpdl_ptr - specpdl - op, Qnil); 529 unbind_to (specpdl_ptr - specpdl - op, Qnil);
530 AFTER_POTENTIAL_GC ();
449 break; 531 break;
450 532
451 case Bunbind_all: 533 case Bunbind_all:
452 /* To unbind back to the beginning of this frame. Not used yet, 534 /* To unbind back to the beginning of this frame. Not used yet,
453 but will be needed for tail-recursion elimination. */ 535 but will be needed for tail-recursion elimination. */
536 BEFORE_POTENTIAL_GC ();
454 unbind_to (count, Qnil); 537 unbind_to (count, Qnil);
538 AFTER_POTENTIAL_GC ();
455 break; 539 break;
456 540
457 case Bgoto: 541 case Bgoto:
458 MAYBE_GC (); 542 MAYBE_GC ();
459 QUIT; 543 QUIT;
460 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */ 544 op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
461 CHECK_RANGE (op); 545 CHECK_RANGE (op);
462 pc = XSTRING (string_saved)->data + op; 546 stack.pc = stack.byte_string_start + op;
463 break; 547 break;
464 548
465 case Bgotoifnil: 549 case Bgotoifnil:
466 MAYBE_GC (); 550 MAYBE_GC ();
467 op = FETCH2; 551 op = FETCH2;
468 if (NILP (POP)) 552 if (NILP (POP))
469 { 553 {
470 QUIT; 554 QUIT;
471 CHECK_RANGE (op); 555 CHECK_RANGE (op);
472 pc = XSTRING (string_saved)->data + op; 556 stack.pc = stack.byte_string_start + op;
473 } 557 }
474 break; 558 break;
475 559
476 case Bgotoifnonnil: 560 case Bgotoifnonnil:
477 MAYBE_GC (); 561 MAYBE_GC ();
478 op = FETCH2; 562 op = FETCH2;
479 if (!NILP (POP)) 563 if (!NILP (POP))
480 { 564 {
481 QUIT; 565 QUIT;
482 CHECK_RANGE (op); 566 CHECK_RANGE (op);
483 pc = XSTRING (string_saved)->data + op; 567 stack.pc = stack.byte_string_start + op;
484 } 568 }
485 break; 569 break;
486 570
487 case Bgotoifnilelsepop: 571 case Bgotoifnilelsepop:
488 MAYBE_GC (); 572 MAYBE_GC ();
489 op = FETCH2; 573 op = FETCH2;
490 if (NILP (TOP)) 574 if (NILP (TOP))
491 { 575 {
492 QUIT; 576 QUIT;
493 CHECK_RANGE (op); 577 CHECK_RANGE (op);
494 pc = XSTRING (string_saved)->data + op; 578 stack.pc = stack.byte_string_start + op;
495 } 579 }
496 else DISCARD (1); 580 else DISCARD (1);
497 break; 581 break;
498 582
499 case Bgotoifnonnilelsepop: 583 case Bgotoifnonnilelsepop:
501 op = FETCH2; 585 op = FETCH2;
502 if (!NILP (TOP)) 586 if (!NILP (TOP))
503 { 587 {
504 QUIT; 588 QUIT;
505 CHECK_RANGE (op); 589 CHECK_RANGE (op);
506 pc = XSTRING (string_saved)->data + op; 590 stack.pc = stack.byte_string_start + op;
507 } 591 }
508 else DISCARD (1); 592 else DISCARD (1);
509 break; 593 break;
510 594
511 case BRgoto: 595 case BRgoto:
512 MAYBE_GC (); 596 MAYBE_GC ();
513 QUIT; 597 QUIT;
514 pc += (int) *pc - 127; 598 stack.pc += (int) *stack.pc - 127;
515 break; 599 break;
516 600
517 case BRgotoifnil: 601 case BRgotoifnil:
518 MAYBE_GC (); 602 MAYBE_GC ();
519 if (NILP (POP)) 603 if (NILP (POP))
520 { 604 {
521 QUIT; 605 QUIT;
522 pc += (int) *pc - 128; 606 stack.pc += (int) *stack.pc - 128;
523 } 607 }
524 pc++; 608 stack.pc++;
525 break; 609 break;
526 610
527 case BRgotoifnonnil: 611 case BRgotoifnonnil:
528 MAYBE_GC (); 612 MAYBE_GC ();
529 if (!NILP (POP)) 613 if (!NILP (POP))
530 { 614 {
531 QUIT; 615 QUIT;
532 pc += (int) *pc - 128; 616 stack.pc += (int) *stack.pc - 128;
533 } 617 }
534 pc++; 618 stack.pc++;
535 break; 619 break;
536 620
537 case BRgotoifnilelsepop: 621 case BRgotoifnilelsepop:
538 MAYBE_GC (); 622 MAYBE_GC ();
539 op = *pc++; 623 op = *stack.pc++;
540 if (NILP (TOP)) 624 if (NILP (TOP))
541 { 625 {
542 QUIT; 626 QUIT;
543 pc += op - 128; 627 stack.pc += op - 128;
544 } 628 }
545 else DISCARD (1); 629 else DISCARD (1);
546 break; 630 break;
547 631
548 case BRgotoifnonnilelsepop: 632 case BRgotoifnonnilelsepop:
549 MAYBE_GC (); 633 MAYBE_GC ();
550 op = *pc++; 634 op = *stack.pc++;
551 if (!NILP (TOP)) 635 if (!NILP (TOP))
552 { 636 {
553 QUIT; 637 QUIT;
554 pc += op - 128; 638 stack.pc += op - 128;
555 } 639 }
556 else DISCARD (1); 640 else DISCARD (1);
557 break; 641 break;
558 642
559 case Breturn: 643 case Breturn:
601 break; 685 break;
602 686
603 case Bcondition_case: 687 case Bcondition_case:
604 v1 = POP; 688 v1 = POP;
605 v1 = Fcons (POP, v1); 689 v1 = Fcons (POP, v1);
690 BEFORE_POTENTIAL_GC ();
606 TOP = Fcondition_case (Fcons (TOP, v1)); 691 TOP = Fcondition_case (Fcons (TOP, v1));
692 AFTER_POTENTIAL_GC ();
607 break; 693 break;
608 694
609 case Btemp_output_buffer_setup: 695 case Btemp_output_buffer_setup:
610 temp_output_buffer_setup (XSTRING (TOP)->data); 696 temp_output_buffer_setup (XSTRING (TOP)->data);
611 TOP = Vstandard_output; 697 TOP = Vstandard_output;
614 case Btemp_output_buffer_show: 700 case Btemp_output_buffer_show:
615 v1 = POP; 701 v1 = POP;
616 temp_output_buffer_show (TOP); 702 temp_output_buffer_show (TOP);
617 TOP = v1; 703 TOP = v1;
618 /* pop binding of standard-output */ 704 /* pop binding of standard-output */
705 BEFORE_POTENTIAL_GC ();
619 unbind_to (specpdl_ptr - specpdl - 1, Qnil); 706 unbind_to (specpdl_ptr - specpdl - 1, Qnil);
707 AFTER_POTENTIAL_GC ();
620 break; 708 break;
621 709
622 case Bnth: 710 case Bnth:
623 v1 = POP; 711 v1 = POP;
624 v2 = TOP; 712 v2 = TOP;
1144 #endif 1232 #endif
1145 } 1233 }
1146 } 1234 }
1147 1235
1148 exit: 1236 exit:
1149 UNGCPRO; 1237
1238 byte_stack_list = byte_stack_list->next;
1239
1150 /* Binds and unbinds are supposed to be compiled balanced. */ 1240 /* Binds and unbinds are supposed to be compiled balanced. */
1151 if (specpdl_ptr - specpdl != count) 1241 if (specpdl_ptr - specpdl != count)
1152 #ifdef BYTE_CODE_SAFE 1242 #ifdef BYTE_CODE_SAFE
1153 error ("binding stack not balanced (serious byte compiler bug)"); 1243 error ("binding stack not balanced (serious byte compiler bug)");
1154 #else 1244 #else
1155 abort (); 1245 abort ();
1156 #endif 1246 #endif
1247
1157 return v1; 1248 return v1;
1158 } 1249 }
1159 1250
1160 void 1251 void
1161 syms_of_bytecode () 1252 syms_of_bytecode ()