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