libguile/vm-i-system.c

   1 /* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 /* This file is included in vm_engine.c */
  21
  22 \f
  23 /*
  24  * Basic operations
  25  */
  26
  27 VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
  28 {
  29   NEXT;
  30 }
  31
  32 VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
  33 {
  34   vp->time += scm_c_get_internal_run_time () - start_time;
  35   HALT_HOOK ();
  36   nvalues = SCM_I_INUM (*sp--);
  37   NULLSTACK (1);
  38   if (nvalues == 1)
  39     POP (finish_args);
  40   else
  41     {
  42       POP_LIST (nvalues);
  43       POP (finish_args);
  44       SYNC_REGISTER ();
  45       finish_args = scm_values (finish_args);
  46     }
  47
  48   {
  49     ASSERT (sp == stack_base);
  50     ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
  51
  52     /* Restore registers */
  53     sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
  54     ip = NULL;
  55     fp = SCM_FRAME_DYNAMIC_LINK (fp);
  56     NULLSTACK (stack_base - sp);
  57   }
  58
  59   goto vm_done;
  60 }
  61
  62 VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0)
  63 {
  64   BREAK_HOOK ();
  65   NEXT;
  66 }
  67
  68 VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
  69 {
  70   DROP ();
  71   NEXT;
  72 }
  73
  74 VM_DEFINE_INSTRUCTION (4, mark, "mark", 0, 0, 1)
  75 {
  76   PUSH (SCM_UNDEFINED);
  77   NEXT;
  78 }
  79
  80 VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
  81 {
  82   SCM x = *sp;
  83   PUSH (x);
  84   NEXT;
  85 }
  86
  87 \f
  88 /*
  89  * Object creation
  90  */
  91
  92 VM_DEFINE_INSTRUCTION (6, void, "void", 0, 0, 1)
  93 {
  94   PUSH (SCM_UNSPECIFIED);
  95   NEXT;
  96 }
  97
  98 VM_DEFINE_INSTRUCTION (7, make_true, "make-true", 0, 0, 1)
  99 {
 100   PUSH (SCM_BOOL_T);
 101   NEXT;
 102 }
 103
 104 VM_DEFINE_INSTRUCTION (8, make_false, "make-false", 0, 0, 1)
 105 {
 106   PUSH (SCM_BOOL_F);
 107   NEXT;
 108 }
 109
 110 VM_DEFINE_INSTRUCTION (9, make_eol, "make-eol", 0, 0, 1)
 111 {
 112   PUSH (SCM_EOL);
 113   NEXT;
 114 }
 115
 116 VM_DEFINE_INSTRUCTION (10, make_int8, "make-int8", 1, 0, 1)
 117 {
 118   PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
 119   NEXT;
 120 }
 121
 122 VM_DEFINE_INSTRUCTION (11, make_int8_0, "make-int8:0", 0, 0, 1)
 123 {
 124   PUSH (SCM_INUM0);
 125   NEXT;
 126 }
 127
 128 VM_DEFINE_INSTRUCTION (12, make_int8_1, "make-int8:1", 0, 0, 1)
 129 {
 130   PUSH (SCM_I_MAKINUM (1));
 131   NEXT;
 132 }
 133
 134 VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
 135 {
 136   int h = FETCH ();
 137   int l = FETCH ();
 138   PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
 139   NEXT;
 140 }
 141
 142 VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
 143 {
 144   scm_t_uint64 v = 0;
 145   v += FETCH ();
 146   v <<= 8; v += FETCH ();
 147   v <<= 8; v += FETCH ();
 148   v <<= 8; v += FETCH ();
 149   v <<= 8; v += FETCH ();
 150   v <<= 8; v += FETCH ();
 151   v <<= 8; v += FETCH ();
 152   v <<= 8; v += FETCH ();
 153   PUSH (scm_from_int64 ((scm_t_int64) v));
 154   NEXT;
 155 }
 156
 157 VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
 158 {
 159   scm_t_uint64 v = 0;
 160   v += FETCH ();
 161   v <<= 8; v += FETCH ();
 162   v <<= 8; v += FETCH ();
 163   v <<= 8; v += FETCH ();
 164   v <<= 8; v += FETCH ();
 165   v <<= 8; v += FETCH ();
 166   v <<= 8; v += FETCH ();
 167   v <<= 8; v += FETCH ();
 168   PUSH (scm_from_uint64 (v));
 169   NEXT;
 170 }
 171
 172 VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
 173 {
 174   PUSH (SCM_MAKE_CHAR (FETCH ()));
 175   NEXT;
 176 }
 177
 178 VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
 179 {
 180   unsigned h = FETCH ();
 181   unsigned l = FETCH ();
 182   unsigned len = ((h << 8) + l);
 183   POP_LIST (len);
 184   NEXT;
 185 }
 186
 187 VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
 188 {
 189   unsigned h = FETCH ();
 190   unsigned l = FETCH ();
 191   unsigned len = ((h << 8) + l);
 192   SCM vect;
 193
 194   SYNC_REGISTER ();
 195   sp++; sp -= len;
 196   CHECK_UNDERFLOW ();
 197   vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
 198   memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
 199   NULLSTACK (len);
 200   *sp = vect;
 201
 202   NEXT;
 203 }
 204
 205 VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
 206 {
 207   POP_LIST_MARK ();
 208   NEXT;
 209 }
 210
 211 VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
 212 {
 213   POP_CONS_MARK ();
 214   NEXT;
 215 }
 216
 217 VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
 218 {
 219   POP_LIST_MARK ();
 220   SYNC_REGISTER ();
 221   *sp = scm_vector (*sp);
 222   NEXT;
 223 }
 224
 225 VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
 226 {
 227   SCM l;
 228   POP (l);
 229   PUSH_LIST (l, SCM_NULLP);
 230   NEXT;
 231 }
 232
 233 \f
 234 /*
 235  * Variable access
 236  */
 237
 238 #define OBJECT_REF(i)           objects[i]
 239 #define OBJECT_SET(i,o)         objects[i] = o
 240
 241 #define LOCAL_REF(i)            SCM_FRAME_VARIABLE (fp, i)
 242 #define LOCAL_SET(i,o)          SCM_FRAME_VARIABLE (fp, i) = o
 243
 244 /* For the variable operations, we _must_ obviously avoid function calls to
 245    `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
 246    nothing more than the corresponding macros.  */
 247 #define VARIABLE_REF(v)         SCM_VARIABLE_REF (v)
 248 #define VARIABLE_SET(v,o)       SCM_VARIABLE_SET (v, o)
 249 #define VARIABLE_BOUNDP(v)      (VARIABLE_REF (v) != SCM_UNDEFINED)
 250
 251 #define FREE_VARIABLE_REF(i)    free_vars[i]
 252
 253 /* ref */
 254
 255 VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
 256 {
 257   register unsigned objnum = FETCH ();
 258   CHECK_OBJECT (objnum);
 259   PUSH (OBJECT_REF (objnum));
 260   NEXT;
 261 }
 262
 263 /* FIXME: necessary? elt 255 of the vector could be a vector... */
 264 VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
 265 {
 266   unsigned int objnum = FETCH ();
 267   objnum <<= 8;
 268   objnum += FETCH ();
 269   CHECK_OBJECT (objnum);
 270   PUSH (OBJECT_REF (objnum));
 271   NEXT;
 272 }
 273
 274 VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
 275 {
 276   PUSH (LOCAL_REF (FETCH ()));
 277   ASSERT_BOUND (*sp);
 278   NEXT;
 279 }
 280
 281 VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
 282 {
 283   unsigned int i = FETCH ();
 284   i <<= 8;
 285   i += FETCH ();
 286   PUSH (LOCAL_REF (i));
 287   ASSERT_BOUND (*sp);
 288   NEXT;
 289 }
 290
 291 VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
 292 {
 293   SCM x = *sp;
 294
 295   if (!VARIABLE_BOUNDP (x))
 296     {
 297       finish_args = scm_list_1 (x);
 298       /* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */
 299       goto vm_error_unbound;
 300     }
 301   else
 302     {
 303       SCM o = VARIABLE_REF (x);
 304       *sp = o;
 305     }
 306
 307   NEXT;
 308 }
 309
 310 VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
 311 {
 312   unsigned objnum = FETCH ();
 313   SCM what;
 314   CHECK_OBJECT (objnum);
 315   what = OBJECT_REF (objnum);
 316
 317   if (!SCM_VARIABLEP (what))
 318     {
 319       SYNC_REGISTER ();
 320       what = resolve_variable (what, scm_program_module (program));
 321       if (!VARIABLE_BOUNDP (what))
 322         {
 323           finish_args = scm_list_1 (what);
 324           goto vm_error_unbound;
 325         }
 326       OBJECT_SET (objnum, what);
 327     }
 328
 329   PUSH (VARIABLE_REF (what));
 330   NEXT;
 331 }
 332
 333 VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
 334 {
 335   SCM what;
 336   unsigned int objnum = FETCH ();
 337   objnum <<= 8;
 338   objnum += FETCH ();
 339   CHECK_OBJECT (objnum);
 340   what = OBJECT_REF (objnum);
 341
 342   if (!SCM_VARIABLEP (what))
 343     {
 344       SYNC_REGISTER ();
 345       what = resolve_variable (what, scm_program_module (program));
 346       if (!VARIABLE_BOUNDP (what))
 347         {
 348           finish_args = scm_list_1 (what);
 349           goto vm_error_unbound;
 350         }
 351       OBJECT_SET (objnum, what);
 352     }
 353
 354   PUSH (VARIABLE_REF (what));
 355   NEXT;
 356 }
 357
 358 /* set */
 359
 360 VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
 361 {
 362   LOCAL_SET (FETCH (), *sp);
 363   DROP ();
 364   NEXT;
 365 }
 366
 367 VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
 368 {
 369   unsigned int i = FETCH ();
 370   i <<= 8;
 371   i += FETCH ();
 372   LOCAL_SET (i, *sp);
 373   DROP ();
 374   NEXT;
 375 }
 376
 377 VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
 378 {
 379   VARIABLE_SET (sp[0], sp[-1]);
 380   DROPN (2);
 381   NEXT;
 382 }
 383
 384 VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
 385 {
 386   unsigned objnum = FETCH ();
 387   SCM what;
 388   CHECK_OBJECT (objnum);
 389   what = OBJECT_REF (objnum);
 390
 391   if (!SCM_VARIABLEP (what))
 392     {
 393       SYNC_BEFORE_GC ();
 394       what = resolve_variable (what, scm_program_module (program));
 395       OBJECT_SET (objnum, what);
 396     }
 397
 398   VARIABLE_SET (what, *sp);
 399   DROP ();
 400   NEXT;
 401 }
 402
 403 VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
 404 {
 405   SCM what;
 406   unsigned int objnum = FETCH ();
 407   objnum <<= 8;
 408   objnum += FETCH ();
 409   CHECK_OBJECT (objnum);
 410   what = OBJECT_REF (objnum);
 411
 412   if (!SCM_VARIABLEP (what))
 413     {
 414       SYNC_BEFORE_GC ();
 415       what = resolve_variable (what, scm_program_module (program));
 416       OBJECT_SET (objnum, what);
 417     }
 418
 419   VARIABLE_SET (what, *sp);
 420   DROP ();
 421   NEXT;
 422 }
 423
 424 \f
 425 /*
 426  * branch and jump
 427  */
 428
 429 /* offset must be a signed short!!! */
 430 #define FETCH_OFFSET(offset)                    \
 431 {                                               \
 432   int h = FETCH ();                             \
 433   int l = FETCH ();                             \
 434   offset = (h << 8) + l;                        \
 435 }
 436
 437 #define BR(p)                                   \
 438 {                                               \
 439   signed short offset;                          \
 440   FETCH_OFFSET (offset);                        \
 441   if (p)                                        \
 442     ip += offset;                               \
 443   NULLSTACK (1);                                \
 444   DROP ();                                      \
 445   NEXT;                                         \
 446 }
 447
 448 VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
 449 {
 450   int h = FETCH ();
 451   int l = FETCH ();
 452   ip += (signed short) (h << 8) + l;
 453   NEXT;
 454 }
 455
 456 VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
 457 {
 458   BR (!SCM_FALSEP (*sp));
 459 }
 460
 461 VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
 462 {
 463   BR (SCM_FALSEP (*sp));
 464 }
 465
 466 VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
 467 {
 468   sp--; /* underflow? */
 469   BR (SCM_EQ_P (sp[0], sp[1]));
 470 }
 471
 472 VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
 473 {
 474   sp--; /* underflow? */
 475   BR (!SCM_EQ_P (sp[0], sp[1]));
 476 }
 477
 478 VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
 479 {
 480   BR (SCM_NULLP (*sp));
 481 }
 482
 483 VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
 484 {
 485   BR (!SCM_NULLP (*sp));
 486 }
 487
 488 \f
 489 /*
 490  * Subprogram call
 491  */
 492
 493 VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
 494 {
 495   SCM x;
 496   nargs = FETCH ();
 497
 498  vm_call:
 499   x = sp[-nargs];
 500
 501   SYNC_REGISTER ();
 502   SCM_TICK;     /* allow interrupt here */
 503
 504   /*
 505    * Subprogram call
 506    */
 507   if (SCM_PROGRAM_P (x))
 508     {
 509       program = x;
 510       CACHE_PROGRAM ();
 511       INIT_ARGS ();
 512       NEW_FRAME ();
 513       ENTER_HOOK ();
 514       APPLY_HOOK ();
 515       NEXT;
 516     }
 517 #ifdef ENABLE_TRAMPOLINE
 518   /* Seems to slow down the fibo test, dunno why */
 519   /*
 520    * Subr call
 521    */
 522   switch (nargs)
 523     {
 524     case 0:
 525       {
 526         scm_t_trampoline_0 call = scm_trampoline_0 (x);
 527         if (call)
 528           {
 529             SYNC_ALL ();
 530             *sp = call (x);
 531             NEXT;
 532           }
 533         break;
 534       }
 535     case 1:
 536       {
 537         scm_t_trampoline_1 call = scm_trampoline_1 (x);
 538         if (call)
 539           {
 540             SCM arg1;
 541             POP (arg1);
 542             SYNC_ALL ();
 543             *sp = call (x, arg1);
 544             NEXT;
 545           }
 546         break;
 547       }
 548     case 2:
 549       {
 550         scm_t_trampoline_2 call = scm_trampoline_2 (x);
 551         if (call)
 552           {
 553             SCM arg1, arg2;
 554             POP (arg2);
 555             POP (arg1);
 556             SYNC_ALL ();
 557             *sp = call (x, arg1, arg2);
 558             NEXT;
 559           }
 560         break;
 561       }
 562     }
 563 #endif
 564   /*
 565    * Other interpreted or compiled call
 566    */
 567   if (!SCM_FALSEP (scm_procedure_p (x)))
 568     {
 569       /* At this point, the stack contains the procedure and each one of its
 570          arguments.  */
 571       POP_LIST (nargs);
 572       SYNC_REGISTER ();
 573       /* keep args on stack so they are marked */
 574       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 575       NULLSTACK_FOR_NONLOCAL_EXIT ();
 576       DROP ();
 577       if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
 578         {
 579           /* truncate values */
 580           SCM values;
 581           POP (values);
 582           values = scm_struct_ref (values, SCM_INUM0);
 583           if (scm_is_null (values))
 584             goto vm_error_not_enough_values;
 585           PUSH (SCM_CAR (values));
 586         }
 587       NEXT;
 588     }
 589   /*
 590    * Continuation call
 591    */
 592   if (SCM_VM_CONT_P (x))
 593     {
 594       program = x;
 595     vm_call_continuation:
 596       /* Check the number of arguments */
 597       /* FIXME multiple args */
 598       if (nargs != 1)
 599         scm_wrong_num_args (program);
 600
 601       /* Reinstate the continuation */
 602       EXIT_HOOK ();
 603       reinstate_vm_cont (vp, program);
 604       CACHE_REGISTER ();
 605       program = SCM_FRAME_PROGRAM (fp);
 606       CACHE_PROGRAM ();
 607       NEXT;
 608     }
 609
 610   program = x;
 611   goto vm_error_wrong_type_apply;
 612 }
 613
 614 VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
 615 {
 616   register SCM x;
 617   nargs = FETCH ();
 618  vm_goto_args:
 619   x = sp[-nargs];
 620
 621   SYNC_REGISTER ();
 622   SCM_TICK;     /* allow interrupt here */
 623
 624   /*
 625    * Tail recursive call
 626    */
 627   if (SCM_EQ_P (x, program))
 628     {
 629       int i;
 630
 631       /* Move arguments */
 632       INIT_ARGS ();
 633       sp -= bp->nargs - 1;
 634       for (i = 0; i < bp->nargs; i++)
 635         LOCAL_SET (i, sp[i]);
 636
 637       /* Drop the first argument and the program itself.  */
 638       sp -= 2;
 639       NULLSTACK (bp->nargs + 1);
 640
 641       /* Init locals to valid SCM values */
 642       for (i = 0; i < bp->nlocs; i++)
 643         LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
 644
 645       /* Call itself */
 646       ip = bp->base;
 647       APPLY_HOOK ();
 648       NEXT;
 649     }
 650
 651   /*
 652    * Tail call, but not to self -- reuse the frame, keeping the ra and dl
 653    */
 654   if (SCM_PROGRAM_P (x))
 655     {
 656       SCM *data, *tail_args, *dl;
 657       int i;
 658       scm_byte_t *ra, *mvra;
 659 #ifdef VM_ENABLE_STACK_NULLING
 660       SCM *old_sp;
 661 #endif
 662
 663       EXIT_HOOK ();
 664
 665       /* save registers */
 666       tail_args = stack_base + 2;
 667       ra = SCM_FRAME_RETURN_ADDRESS (fp);
 668       mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp);
 669       dl = SCM_FRAME_DYNAMIC_LINK (fp);
 670
 671       /* switch programs */
 672       program = x;
 673       CACHE_PROGRAM ();
 674       INIT_ARGS ();
 675       /* delay updating the frame so that if INIT_ARGS has to cons up a rest
 676          arg, going into GC, the stack still makes sense */
 677       fp[-1] = program;
 678       nargs = bp->nargs;
 679
 680 #ifdef VM_ENABLE_STACK_NULLING
 681       old_sp = sp;
 682       CHECK_STACK_LEAK ();
 683 #endif
 684
 685       /* new registers -- logically this would be better later, but let's make
 686          sure we have space for the locals now */
 687       data = SCM_FRAME_DATA_ADDRESS (fp);
 688       ip = bp->base;
 689       stack_base = data + 2;
 690       sp = stack_base;
 691       CHECK_OVERFLOW ();
 692
 693       /* copy args, bottom-up */
 694       for (i = 0; i < nargs; i++)
 695         fp[i] = tail_args[i];
 696
 697       NULLSTACK (old_sp - sp);
 698
 699       /* init locals */
 700       for (i = bp->nlocs; i; i--)
 701         data[-i] = SCM_UNDEFINED;
 702
 703       /* Set frame data */
 704       data[2] = (SCM)ra;
 705       data[1] = (SCM)mvra;
 706       data[0] = (SCM)dl;
 707
 708       ENTER_HOOK ();
 709       APPLY_HOOK ();
 710       NEXT;
 711     }
 712 #ifdef ENABLE_TRAMPOLINE
 713   /* This seems to actually slow down the fibo test -- dunno why */
 714   /*
 715    * Subr call
 716    */
 717   switch (nargs)
 718     {
 719     case 0:
 720       {
 721         scm_t_trampoline_0 call = scm_trampoline_0 (x);
 722         if (call)
 723           {
 724             SYNC_ALL ();
 725             *sp = call (x);
 726             goto vm_return;
 727           }
 728         break;
 729       }
 730     case 1:
 731       {
 732         scm_t_trampoline_1 call = scm_trampoline_1 (x);
 733         if (call)
 734           {
 735             SCM arg1;
 736             POP (arg1);
 737             SYNC_ALL ();
 738             *sp = call (x, arg1);
 739             goto vm_return;
 740           }
 741         break;
 742       }
 743     case 2:
 744       {
 745         scm_t_trampoline_2 call = scm_trampoline_2 (x);
 746         if (call)
 747           {
 748             SCM arg1, arg2;
 749             POP (arg2);
 750             POP (arg1);
 751             SYNC_ALL ();
 752             *sp = call (x, arg1, arg2);
 753             goto vm_return;
 754           }
 755         break;
 756       }
 757     }
 758 #endif
 759
 760   /*
 761    * Other interpreted or compiled call
 762    */
 763   if (!SCM_FALSEP (scm_procedure_p (x)))
 764     {
 765       POP_LIST (nargs);
 766       SYNC_REGISTER ();
 767       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 768       NULLSTACK_FOR_NONLOCAL_EXIT ();
 769       DROP ();
 770       if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
 771         {
 772           /* multiple values returned to continuation */
 773           SCM values;
 774           POP (values);
 775           values = scm_struct_ref (values, SCM_INUM0);
 776           nvalues = scm_ilength (values);
 777           PUSH_LIST (values, SCM_NULLP);
 778           goto vm_return_values;
 779         }
 780       goto vm_return;
 781     }
 782
 783   program = x;
 784
 785   /*
 786    * Continuation call
 787    */
 788   if (SCM_VM_CONT_P (program))
 789     goto vm_call_continuation;
 790
 791   goto vm_error_wrong_type_apply;
 792 }
 793
 794 VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
 795 {
 796   SCM x;
 797   POP (x);
 798   nargs = scm_to_int (x);
 799   /* FIXME: should truncate values? */
 800   goto vm_goto_args;
 801 }
 802
 803 VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
 804 {
 805   SCM x;
 806   POP (x);
 807   nargs = scm_to_int (x);
 808   /* FIXME: should truncate values? */
 809   goto vm_call;
 810 }
 811
 812 VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
 813 {
 814   SCM x;
 815   signed short offset;
 816
 817   nargs = FETCH ();
 818   FETCH_OFFSET (offset);
 819
 820   x = sp[-nargs];
 821
 822   /*
 823    * Subprogram call
 824    */
 825   if (SCM_PROGRAM_P (x))
 826     {
 827       program = x;
 828       CACHE_PROGRAM ();
 829       INIT_ARGS ();
 830       NEW_FRAME ();
 831       SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
 832       ENTER_HOOK ();
 833       APPLY_HOOK ();
 834       NEXT;
 835     }
 836   /*
 837    * Other interpreted or compiled call
 838    */
 839   if (!SCM_FALSEP (scm_procedure_p (x)))
 840     {
 841       /* At this point, the stack contains the procedure and each one of its
 842          arguments.  */
 843       POP_LIST (nargs);
 844       SYNC_REGISTER ();
 845       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 846       NULLSTACK_FOR_NONLOCAL_EXIT ();
 847       DROP ();
 848       if (SCM_VALUESP (*sp))
 849         {
 850           SCM values, len;
 851           POP (values);
 852           values = scm_struct_ref (values, SCM_INUM0);
 853           len = scm_length (values);
 854           PUSH_LIST (values, SCM_NULLP);
 855           PUSH (len);
 856           ip += offset;
 857         }
 858       NEXT;
 859     }
 860   /*
 861    * Continuation call
 862    */
 863   if (SCM_VM_CONT_P (x))
 864     {
 865       program = x;
 866       goto vm_call_continuation;
 867     }
 868
 869   program = x;
 870   goto vm_error_wrong_type_apply;
 871 }
 872
 873 VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
 874 {
 875   int len;
 876   SCM ls;
 877   POP (ls);
 878
 879   nargs = FETCH ();
 880   ASSERT (nargs >= 2);
 881
 882   len = scm_ilength (ls);
 883   if (len < 0)
 884     goto vm_error_wrong_type_arg;
 885
 886   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 887
 888   nargs += len - 2;
 889   goto vm_call;
 890 }
 891
 892 VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
 893 {
 894   int len;
 895   SCM ls;
 896   POP (ls);
 897
 898   nargs = FETCH ();
 899   ASSERT (nargs >= 2);
 900
 901   len = scm_ilength (ls);
 902   if (len < 0)
 903     goto vm_error_wrong_type_arg;
 904
 905   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 906
 907   nargs += len - 2;
 908   goto vm_goto_args;
 909 }
 910
 911 VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
 912 {
 913   int first;
 914   SCM proc, cont;
 915   POP (proc);
 916   SYNC_ALL ();
 917   cont = scm_make_continuation (&first);
 918   if (first)
 919     {
 920       PUSH (proc);
 921       PUSH (cont);
 922       nargs = 1;
 923       goto vm_call;
 924     }
 925   ASSERT (sp == vp->sp);
 926   ASSERT (fp == vp->fp);
 927   else if (SCM_VALUESP (cont))
 928     {
 929       /* multiple values returned to continuation */
 930       SCM values;
 931       values = scm_struct_ref (cont, SCM_INUM0);
 932       if (SCM_NULLP (values))
 933         goto vm_error_no_values;
 934       /* non-tail context does not accept multiple values? */
 935       PUSH (SCM_CAR (values));
 936       NEXT;
 937     }
 938   else
 939     {
 940       PUSH (cont);
 941       NEXT;
 942     }
 943 }
 944
 945 VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
 946 {
 947   int first;
 948   SCM proc, cont;
 949   POP (proc);
 950   SYNC_ALL ();
 951   cont = scm_make_continuation (&first);
 952   ASSERT (sp == vp->sp);
 953   ASSERT (fp == vp->fp);
 954   if (first)
 955     {
 956       PUSH (proc);
 957       PUSH (cont);
 958       nargs = 1;
 959       goto vm_goto_args;
 960     }
 961   else if (SCM_VALUESP (cont))
 962     {
 963       /* multiple values returned to continuation */
 964       SCM values;
 965       values = scm_struct_ref (cont, SCM_INUM0);
 966       nvalues = scm_ilength (values);
 967       PUSH_LIST (values, SCM_NULLP);
 968       goto vm_return_values;
 969     }
 970   else
 971     {
 972       PUSH (cont);
 973       goto vm_return;
 974     }
 975 }
 976
 977 VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
 978 {
 979  vm_return:
 980   EXIT_HOOK ();
 981   RETURN_HOOK ();
 982   SYNC_REGISTER ();
 983   SCM_TICK;     /* allow interrupt here */
 984   {
 985     SCM ret, *data;
 986     data = SCM_FRAME_DATA_ADDRESS (fp);
 987
 988     POP (ret);
 989     ASSERT (sp == stack_base);
 990     ASSERT (stack_base == data + 2);
 991
 992     /* Restore registers */
 993     sp = SCM_FRAME_LOWER_ADDRESS (fp);
 994     ip = SCM_FRAME_BYTE_CAST (data[2]);
 995     fp = SCM_FRAME_STACK_CAST (data[0]);
 996     {
 997 #ifdef VM_ENABLE_STACK_NULLING
 998       int nullcount = stack_base - sp;
 999 #endif
1000       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1001       NULLSTACK (nullcount);
1002     }
1003
1004     /* Set return value (sp is already pushed) */
1005     *sp = ret;
1006   }
1007
1008   /* Restore the last program */
1009   program = SCM_FRAME_PROGRAM (fp);
1010   CACHE_PROGRAM ();
1011   CHECK_IP ();
1012   NEXT;
1013 }
1014
1015 VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
1016 {
1017   /* nvalues declared at top level, because for some reason gcc seems to think
1018      that perhaps it might be used without declaration. Fooey to that, I say. */
1019   SCM *data;
1020
1021   nvalues = FETCH ();
1022  vm_return_values:
1023   EXIT_HOOK ();
1024   RETURN_HOOK ();
1025
1026   data = SCM_FRAME_DATA_ADDRESS (fp);
1027   ASSERT (stack_base == data + 2);
1028
1029   /* data[1] is the mv return address */
1030   if (nvalues != 1 && data[1])
1031     {
1032       int i;
1033       /* Restore registers */
1034       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1035       ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
1036       fp = SCM_FRAME_STACK_CAST (data[0]);
1037
1038       /* Push return values, and the number of values */
1039       for (i = 0; i < nvalues; i++)
1040         *++sp = stack_base[1+i];
1041       *++sp = SCM_I_MAKINUM (nvalues);
1042
1043       /* Finally set new stack_base */
1044       NULLSTACK (stack_base - sp + nvalues + 1);
1045       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1046     }
1047   else if (nvalues >= 1)
1048     {
1049       /* Multiple values for a single-valued continuation -- here's where I
1050          break with guile tradition and try and do something sensible. (Also,
1051          this block handles the single-valued return to an mv
1052          continuation.) */
1053       /* Restore registers */
1054       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1055       ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
1056       fp = SCM_FRAME_STACK_CAST (data[0]);
1057
1058       /* Push first value */
1059       *++sp = stack_base[1];
1060
1061       /* Finally set new stack_base */
1062       NULLSTACK (stack_base - sp + nvalues + 1);
1063       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1064     }
1065   else
1066     goto vm_error_no_values;
1067
1068   /* Restore the last program */
1069   program = SCM_FRAME_PROGRAM (fp);
1070   CACHE_PROGRAM ();
1071   CHECK_IP ();
1072   NEXT;
1073 }
1074
1075 VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
1076 {
1077   SCM l;
1078
1079   nvalues = FETCH ();
1080   ASSERT (nvalues >= 1);
1081
1082   nvalues--;
1083   POP (l);
1084   while (SCM_CONSP (l))
1085     {
1086       PUSH (SCM_CAR (l));
1087       l = SCM_CDR (l);
1088       nvalues++;
1089     }
1090   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1091     finish_args = scm_list_1 (l);
1092     goto vm_error_improper_list;
1093   }
1094
1095   goto vm_return_values;
1096 }
1097
1098 VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
1099 {
1100   SCM x;
1101   int nbinds, rest;
1102   POP (x);
1103   nvalues = scm_to_int (x);
1104   nbinds = FETCH ();
1105   rest = FETCH ();
1106
1107   if (rest)
1108     nbinds--;
1109
1110   if (nvalues < nbinds)
1111     goto vm_error_not_enough_values;
1112
1113   if (rest)
1114     POP_LIST (nvalues - nbinds);
1115   else
1116     DROPN (nvalues - nbinds);
1117
1118   NEXT;
1119 }
1120
1121 VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
1122 {
1123   SCM val;
1124   POP (val);
1125   SYNC_BEFORE_GC ();
1126   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1127   NEXT;
1128 }
1129
1130 /* for letrec:
1131    (let ((a *undef*) (b *undef*) ...)
1132      (set! a (lambda () (b ...)))
1133      ...)
1134  */
1135 VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
1136 {
1137   SYNC_BEFORE_GC ();
1138   LOCAL_SET (FETCH (),
1139              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1140   NEXT;
1141 }
1142
1143 VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1144 {
1145   SCM v = LOCAL_REF (FETCH ());
1146   ASSERT_BOUND_VARIABLE (v);
1147   PUSH (VARIABLE_REF (v));
1148   NEXT;
1149 }
1150
1151 VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
1152 {
1153   SCM v, val;
1154   v = LOCAL_REF (FETCH ());
1155   POP (val);
1156   ASSERT_VARIABLE (v);
1157   VARIABLE_SET (v, val);
1158   NEXT;
1159 }
1160
1161 VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
1162 {
1163   scm_t_uint8 idx = FETCH ();
1164
1165   CHECK_FREE_VARIABLE (idx);
1166   PUSH (FREE_VARIABLE_REF (idx));
1167   NEXT;
1168 }
1169
1170 /* no free-set -- if a var is assigned, it should be in a box */
1171
1172 VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1173 {
1174   SCM v;
1175   scm_t_uint8 idx = FETCH ();
1176   CHECK_FREE_VARIABLE (idx);
1177   v = FREE_VARIABLE_REF (idx);
1178   ASSERT_BOUND_VARIABLE (v);
1179   PUSH (VARIABLE_REF (v));
1180   NEXT;
1181 }
1182
1183 VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
1184 {
1185   SCM v, val;
1186   scm_t_uint8 idx = FETCH ();
1187   POP (val);
1188   CHECK_FREE_VARIABLE (idx);
1189   v = FREE_VARIABLE_REF (idx);
1190   ASSERT_BOUND_VARIABLE (v);
1191   VARIABLE_SET (v, val);
1192   NEXT;
1193 }
1194
1195 VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
1196 {
1197   SCM vect;
1198   POP (vect);
1199   SYNC_BEFORE_GC ();
1200   /* fixme underflow */
1201   SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
1202                 SCM_PROGRAM_OBJTABLE (*sp), vect);
1203   NEXT;
1204 }
1205
1206 VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
1207 {
1208   SYNC_BEFORE_GC ();
1209   /* fixme underflow */
1210   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1211   NEXT;
1212 }
1213
1214
1215 /*
1216 (defun renumber-ops ()
1217   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1218   (interactive "")
1219   (save-excursion
1220     (let ((counter -1)) (goto-char (point-min))
1221       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1222         (replace-match
1223          (number-to-string (setq counter (1+ counter)))
1224           t t nil 1)))))
1225 */
1226 /*
1227   Local Variables:
1228   c-file-style: "gnu"
1229   End:
1230 */