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             {
 288               SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 289               if (scm_is_false (v))
 290                 SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what));
 291               else
 292                 what = v;
 293             }
 294         }
 295       else
 296         {
 297           SCM mod;
 298           /* compilation of @ or @@
 299              `what' is a three-element list: (MODNAME SYM INTERFACE?)
 300              INTERFACE? is #t if we compiled @ or #f if we compiled @@
 301           */
 302           mod = scm_resolve_module (SCM_CAR (what));
 303           if (scm_is_true (SCM_CADDR (what)))
 304             mod = scm_module_public_interface (mod);
 305           if (SCM_FALSEP (mod))
 306             {
 307               finish_args = scm_list_1 (mod);
 308               goto vm_error_no_such_module;
 309             }
 310           /* might longjmp */
 311           what = scm_module_lookup (mod, SCM_CADR (what));
 312         }
 313
 314       if (!VARIABLE_BOUNDP (what))
 315         {
 316           finish_args = scm_list_1 (what);
 317           goto vm_error_unbound;
 318         }
 319
 320       OBJECT_SET (objnum, what);
 321     }
 322
 323   PUSH (VARIABLE_REF (what));
 324   NEXT;
 325 }
 326
 327 /* set */
 328
 329 VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
 330 {
 331   LOCAL_SET (FETCH (), *sp);
 332   DROP ();
 333   NEXT;
 334 }
 335
 336 VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0)
 337 {
 338   unsigned int i;
 339   SCM e = external;
 340   for (i = FETCH (); i; i--)
 341     {
 342       CHECK_EXTERNAL(e);
 343       e = SCM_CDR (e);
 344     }
 345   CHECK_EXTERNAL(e);
 346   SCM_SETCAR (e, *sp);
 347   DROP ();
 348   NEXT;
 349 }
 350
 351 VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
 352 {
 353   VARIABLE_SET (sp[0], sp[-1]);
 354   DROPN (2);
 355   NEXT;
 356 }
 357
 358 VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
 359 {
 360   unsigned objnum = FETCH ();
 361   SCM what;
 362   CHECK_OBJECT (objnum);
 363   what = OBJECT_REF (objnum);
 364
 365   if (!SCM_VARIABLEP (what))
 366     {
 367       SYNC_BEFORE_GC ();
 368       if (SCM_LIKELY (SCM_SYMBOLP (what)))
 369         {
 370           SCM mod = SCM_EOL;
 371           if (SCM_LIKELY (scm_module_system_booted_p
 372                           && scm_is_true ((mod = scm_program_module (program)))))
 373             /* might longjmp */
 374             what = scm_module_lookup (mod, what);
 375           else
 376             {
 377               SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
 378               if (scm_is_false (v))
 379                 SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (what));
 380               else
 381                 what = v;
 382             }
 383         }
 384       else
 385         {
 386           SCM mod;
 387           /* compilation of @ or @@
 388              `what' is a three-element list: (MODNAME SYM INTERFACE?)
 389              INTERFACE? is #t if we compiled @ or #f if we compiled @@
 390           */
 391           mod = scm_resolve_module (SCM_CAR (what));
 392           if (scm_is_true (SCM_CADDR (what)))
 393             mod = scm_module_public_interface (mod);
 394           if (SCM_FALSEP (mod))
 395             {
 396               finish_args = scm_list_1 (what);
 397               goto vm_error_no_such_module;
 398             }
 399           /* might longjmp */
 400           what = scm_module_lookup (mod, SCM_CADR (what));
 401         }
 402
 403       OBJECT_SET (objnum, what);
 404     }
 405
 406   VARIABLE_SET (what, *sp);
 407   DROP ();
 408   NEXT;
 409 }
 410
 411 VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
 412 {
 413   PUSH (external);
 414   NEXT;
 415 }
 416
 417 \f
 418 /*
 419  * branch and jump
 420  */
 421
 422 /* offset must be a signed short!!! */
 423 #define FETCH_OFFSET(offset)                    \
 424 {                                               \
 425   int h = FETCH ();                             \
 426   int l = FETCH ();                             \
 427   offset = (h << 8) + l;                        \
 428 }
 429
 430 #define BR(p)                                   \
 431 {                                               \
 432   signed short offset;                          \
 433   FETCH_OFFSET (offset);                        \
 434   if (p)                                        \
 435     ip += offset;                               \
 436   NULLSTACK (1);                                \
 437   DROP ();                                      \
 438   NEXT;                                         \
 439 }
 440
 441 VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
 442 {
 443   int h = FETCH ();
 444   int l = FETCH ();
 445   ip += (signed short) (h << 8) + l;
 446   NEXT;
 447 }
 448
 449 VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
 450 {
 451   BR (!SCM_FALSEP (*sp));
 452 }
 453
 454 VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
 455 {
 456   BR (SCM_FALSEP (*sp));
 457 }
 458
 459 VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
 460 {
 461   sp--; /* underflow? */
 462   BR (SCM_EQ_P (sp[0], sp[1]));
 463 }
 464
 465 VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
 466 {
 467   sp--; /* underflow? */
 468   BR (!SCM_EQ_P (sp[0], sp[1]));
 469 }
 470
 471 VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
 472 {
 473   BR (SCM_NULLP (*sp));
 474 }
 475
 476 VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
 477 {
 478   BR (!SCM_NULLP (*sp));
 479 }
 480
 481 \f
 482 /*
 483  * Subprogram call
 484  */
 485
 486 VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1)
 487 {
 488   SYNC_BEFORE_GC ();
 489   SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
 490                 SCM_PROGRAM_OBJTABLE (*sp), external);
 491   NEXT;
 492 }
 493
 494 VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
 495 {
 496   SCM x;
 497   nargs = FETCH ();
 498
 499  vm_call:
 500   x = sp[-nargs];
 501
 502   SYNC_REGISTER ();
 503   SCM_TICK;     /* allow interrupt here */
 504
 505   /*
 506    * Subprogram call
 507    */
 508   if (SCM_PROGRAM_P (x))
 509     {
 510       program = x;
 511       CACHE_PROGRAM ();
 512       INIT_ARGS ();
 513       NEW_FRAME ();
 514       ENTER_HOOK ();
 515       APPLY_HOOK ();
 516       NEXT;
 517     }
 518 #ifdef ENABLE_TRAMPOLINE
 519   /* Seems to slow down the fibo test, dunno why */
 520   /*
 521    * Subr call
 522    */
 523   switch (nargs)
 524     {
 525     case 0:
 526       {
 527         scm_t_trampoline_0 call = scm_trampoline_0 (x);
 528         if (call)
 529           {
 530             SYNC_ALL ();
 531             *sp = call (x);
 532             NEXT;
 533           }
 534         break;
 535       }
 536     case 1:
 537       {
 538         scm_t_trampoline_1 call = scm_trampoline_1 (x);
 539         if (call)
 540           {
 541             SCM arg1;
 542             POP (arg1);
 543             SYNC_ALL ();
 544             *sp = call (x, arg1);
 545             NEXT;
 546           }
 547         break;
 548       }
 549     case 2:
 550       {
 551         scm_t_trampoline_2 call = scm_trampoline_2 (x);
 552         if (call)
 553           {
 554             SCM arg1, arg2;
 555             POP (arg2);
 556             POP (arg1);
 557             SYNC_ALL ();
 558             *sp = call (x, arg1, arg2);
 559             NEXT;
 560           }
 561         break;
 562       }
 563     }
 564 #endif
 565   /*
 566    * Other interpreted or compiled call
 567    */
 568   if (!SCM_FALSEP (scm_procedure_p (x)))
 569     {
 570       /* At this point, the stack contains the procedure and each one of its
 571          arguments.  */
 572       POP_LIST (nargs);
 573       SYNC_REGISTER ();
 574       /* keep args on stack so they are marked */
 575       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 576       NULLSTACK_FOR_NONLOCAL_EXIT ();
 577       DROP ();
 578       if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
 579         {
 580           /* truncate values */
 581           SCM values;
 582           POP (values);
 583           values = scm_struct_ref (values, SCM_INUM0);
 584           if (scm_is_null (values))
 585             goto vm_error_not_enough_values;
 586           PUSH (SCM_CAR (values));
 587         }
 588       NEXT;
 589     }
 590   /*
 591    * Continuation call
 592    */
 593   if (SCM_VM_CONT_P (x))
 594     {
 595       program = x;
 596     vm_call_continuation:
 597       /* Check the number of arguments */
 598       /* FIXME multiple args */
 599       if (nargs != 1)
 600         scm_wrong_num_args (program);
 601
 602       /* Reinstate the continuation */
 603       EXIT_HOOK ();
 604       reinstate_vm_cont (vp, program);
 605       CACHE_REGISTER ();
 606       program = SCM_FRAME_PROGRAM (fp);
 607       CACHE_PROGRAM ();
 608       NEXT;
 609     }
 610
 611   program = x;
 612   goto vm_error_wrong_type_apply;
 613 }
 614
 615 VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
 616 {
 617   register SCM x;
 618   nargs = FETCH ();
 619  vm_goto_args:
 620   x = sp[-nargs];
 621
 622   SYNC_REGISTER ();
 623   SCM_TICK;     /* allow interrupt here */
 624
 625   /*
 626    * Tail recursive call
 627    */
 628   if (SCM_EQ_P (x, program))
 629     {
 630       int i;
 631
 632       /* Move arguments */
 633       INIT_ARGS ();
 634       sp -= bp->nargs - 1;
 635       for (i = 0; i < bp->nargs; i++)
 636         LOCAL_SET (i, sp[i]);
 637
 638       /* Drop the first argument and the program itself.  */
 639       sp -= 2;
 640       NULLSTACK (bp->nargs + 1);
 641
 642       /* Freshen the externals */
 643       external = SCM_PROGRAM_EXTERNALS (x);
 644       for (i = 0; i < bp->nexts; i++)
 645         CONS (external, SCM_UNDEFINED, external);
 646       SCM_FRAME_DATA_ADDRESS (fp)[0] = external;
 647
 648       /* Init locals to valid SCM values */
 649       for (i = 0; i < bp->nlocs; i++)
 650         LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
 651
 652       /* Call itself */
 653       ip = bp->base;
 654       APPLY_HOOK ();
 655       NEXT;
 656     }
 657
 658   /*
 659    * Tail call, but not to self -- reuse the frame, keeping the ra and dl
 660    */
 661   if (SCM_PROGRAM_P (x))
 662     {
 663       SCM *data, *tail_args, *dl;
 664       int i;
 665       scm_byte_t *ra, *mvra;
 666 #ifdef VM_ENABLE_STACK_NULLING
 667       SCM *old_sp;
 668 #endif
 669
 670       EXIT_HOOK ();
 671
 672       /* save registers */
 673       tail_args = stack_base + 2;
 674       ra = SCM_FRAME_RETURN_ADDRESS (fp);
 675       mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp);
 676       dl = SCM_FRAME_DYNAMIC_LINK (fp);
 677
 678       /* switch programs */
 679       program = x;
 680       CACHE_PROGRAM ();
 681       INIT_ARGS ();
 682       /* delay updating the frame so that if INIT_ARGS has to cons up a rest
 683          arg, going into GC, the stack still makes sense */
 684       fp[-1] = program;
 685       nargs = bp->nargs;
 686
 687 #ifdef VM_ENABLE_STACK_NULLING
 688       old_sp = sp;
 689       CHECK_STACK_LEAK ();
 690 #endif
 691
 692       /* new registers -- logically this would be better later, but let's make
 693          sure we have space for the locals now */
 694       data = SCM_FRAME_DATA_ADDRESS (fp);
 695       ip = bp->base;
 696       stack_base = data + 3;
 697       sp = stack_base;
 698       CHECK_OVERFLOW ();
 699
 700       /* copy args, bottom-up */
 701       for (i = 0; i < nargs; i++)
 702         fp[i] = tail_args[i];
 703
 704       NULLSTACK (old_sp - sp);
 705
 706       /* init locals */
 707       for (i = bp->nlocs; i; i--)
 708         data[-i] = SCM_UNDEFINED;
 709
 710       /* Set frame data */
 711       data[3] = (SCM)ra;
 712       data[2] = (SCM)mvra;
 713       data[1] = (SCM)dl;
 714
 715       /* Postpone initializing external vars, because if the CONS causes a GC,
 716          we want the stack marker to see the data array formatted as expected. */
 717       data[0] = SCM_UNDEFINED;
 718       external = SCM_PROGRAM_EXTERNALS (fp[-1]);
 719       for (i = 0; i < bp->nexts; i++)
 720         CONS (external, SCM_UNDEFINED, external);
 721       data[0] = external;
 722
 723       ENTER_HOOK ();
 724       APPLY_HOOK ();
 725       NEXT;
 726     }
 727 #ifdef ENABLE_TRAMPOLINE
 728   /* This seems to actually slow down the fibo test -- dunno why */
 729   /*
 730    * Subr call
 731    */
 732   switch (nargs)
 733     {
 734     case 0:
 735       {
 736         scm_t_trampoline_0 call = scm_trampoline_0 (x);
 737         if (call)
 738           {
 739             SYNC_ALL ();
 740             *sp = call (x);
 741             goto vm_return;
 742           }
 743         break;
 744       }
 745     case 1:
 746       {
 747         scm_t_trampoline_1 call = scm_trampoline_1 (x);
 748         if (call)
 749           {
 750             SCM arg1;
 751             POP (arg1);
 752             SYNC_ALL ();
 753             *sp = call (x, arg1);
 754             goto vm_return;
 755           }
 756         break;
 757       }
 758     case 2:
 759       {
 760         scm_t_trampoline_2 call = scm_trampoline_2 (x);
 761         if (call)
 762           {
 763             SCM arg1, arg2;
 764             POP (arg2);
 765             POP (arg1);
 766             SYNC_ALL ();
 767             *sp = call (x, arg1, arg2);
 768             goto vm_return;
 769           }
 770         break;
 771       }
 772     }
 773 #endif
 774
 775   /*
 776    * Other interpreted or compiled call
 777    */
 778   if (!SCM_FALSEP (scm_procedure_p (x)))
 779     {
 780       POP_LIST (nargs);
 781       SYNC_REGISTER ();
 782       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 783       NULLSTACK_FOR_NONLOCAL_EXIT ();
 784       DROP ();
 785       if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
 786         {
 787           /* multiple values returned to continuation */
 788           SCM values;
 789           POP (values);
 790           values = scm_struct_ref (values, SCM_INUM0);
 791           nvalues = scm_ilength (values);
 792           PUSH_LIST (values, SCM_NULLP);
 793           goto vm_return_values;
 794         }
 795       goto vm_return;
 796     }
 797
 798   program = x;
 799
 800   /*
 801    * Continuation call
 802    */
 803   if (SCM_VM_CONT_P (program))
 804     goto vm_call_continuation;
 805
 806   goto vm_error_wrong_type_apply;
 807 }
 808
 809 VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
 810 {
 811   SCM x;
 812   POP (x);
 813   nargs = scm_to_int (x);
 814   /* FIXME: should truncate values? */
 815   goto vm_goto_args;
 816 }
 817
 818 VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
 819 {
 820   SCM x;
 821   POP (x);
 822   nargs = scm_to_int (x);
 823   /* FIXME: should truncate values? */
 824   goto vm_call;
 825 }
 826
 827 VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
 828 {
 829   SCM x;
 830   signed short offset;
 831
 832   nargs = FETCH ();
 833   FETCH_OFFSET (offset);
 834
 835   x = sp[-nargs];
 836
 837   /*
 838    * Subprogram call
 839    */
 840   if (SCM_PROGRAM_P (x))
 841     {
 842       program = x;
 843       CACHE_PROGRAM ();
 844       INIT_ARGS ();
 845       NEW_FRAME ();
 846       SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
 847       ENTER_HOOK ();
 848       APPLY_HOOK ();
 849       NEXT;
 850     }
 851   /*
 852    * Other interpreted or compiled call
 853    */
 854   if (!SCM_FALSEP (scm_procedure_p (x)))
 855     {
 856       /* At this point, the stack contains the procedure and each one of its
 857          arguments.  */
 858       POP_LIST (nargs);
 859       SYNC_REGISTER ();
 860       sp[-1] = scm_apply (x, sp[0], SCM_EOL);
 861       NULLSTACK_FOR_NONLOCAL_EXIT ();
 862       DROP ();
 863       if (SCM_VALUESP (*sp))
 864         {
 865           SCM values, len;
 866           POP (values);
 867           values = scm_struct_ref (values, SCM_INUM0);
 868           len = scm_length (values);
 869           PUSH_LIST (values, SCM_NULLP);
 870           PUSH (len);
 871           ip += offset;
 872         }
 873       NEXT;
 874     }
 875   /*
 876    * Continuation call
 877    */
 878   if (SCM_VM_CONT_P (x))
 879     {
 880       program = x;
 881       goto vm_call_continuation;
 882     }
 883
 884   program = x;
 885   goto vm_error_wrong_type_apply;
 886 }
 887
 888 VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
 889 {
 890   int len;
 891   SCM ls;
 892   POP (ls);
 893
 894   nargs = FETCH ();
 895   ASSERT (nargs >= 2);
 896
 897   len = scm_ilength (ls);
 898   if (len < 0)
 899     goto vm_error_wrong_type_arg;
 900
 901   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 902
 903   nargs += len - 2;
 904   goto vm_call;
 905 }
 906
 907 VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
 908 {
 909   int len;
 910   SCM ls;
 911   POP (ls);
 912
 913   nargs = FETCH ();
 914   ASSERT (nargs >= 2);
 915
 916   len = scm_ilength (ls);
 917   if (len < 0)
 918     goto vm_error_wrong_type_arg;
 919
 920   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
 921
 922   nargs += len - 2;
 923   goto vm_goto_args;
 924 }
 925
 926 VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
 927 {
 928   int first;
 929   SCM proc, cont;
 930   POP (proc);
 931   SYNC_ALL ();
 932   cont = scm_make_continuation (&first);
 933   if (first)
 934     {
 935       PUSH (proc);
 936       PUSH (cont);
 937       nargs = 1;
 938       goto vm_call;
 939     }
 940   ASSERT (sp == vp->sp);
 941   ASSERT (fp == vp->fp);
 942   else if (SCM_VALUESP (cont))
 943     {
 944       /* multiple values returned to continuation */
 945       SCM values;
 946       values = scm_struct_ref (cont, SCM_INUM0);
 947       if (SCM_NULLP (values))
 948         goto vm_error_no_values;
 949       /* non-tail context does not accept multiple values? */
 950       PUSH (SCM_CAR (values));
 951       NEXT;
 952     }
 953   else
 954     {
 955       PUSH (cont);
 956       NEXT;
 957     }
 958 }
 959
 960 VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
 961 {
 962   int first;
 963   SCM proc, cont;
 964   POP (proc);
 965   SYNC_ALL ();
 966   cont = scm_make_continuation (&first);
 967   ASSERT (sp == vp->sp);
 968   ASSERT (fp == vp->fp);
 969   if (first)
 970     {
 971       PUSH (proc);
 972       PUSH (cont);
 973       nargs = 1;
 974       goto vm_goto_args;
 975     }
 976   else if (SCM_VALUESP (cont))
 977     {
 978       /* multiple values returned to continuation */
 979       SCM values;
 980       values = scm_struct_ref (cont, SCM_INUM0);
 981       nvalues = scm_ilength (values);
 982       PUSH_LIST (values, SCM_NULLP);
 983       goto vm_return_values;
 984     }
 985   else
 986     {
 987       PUSH (cont);
 988       goto vm_return;
 989     }
 990 }
 991
 992 VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
 993 {
 994  vm_return:
 995   EXIT_HOOK ();
 996   RETURN_HOOK ();
 997   SYNC_REGISTER ();
 998   SCM_TICK;     /* allow interrupt here */
 999   {
1000     SCM ret, *data;
1001     data = SCM_FRAME_DATA_ADDRESS (fp);
1002
1003     POP (ret);
1004     ASSERT (sp == stack_base);
1005     ASSERT (stack_base == data + 3);
1006
1007     /* Restore registers */
1008     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1009     ip = SCM_FRAME_BYTE_CAST (data[3]);
1010     fp = SCM_FRAME_STACK_CAST (data[1]);
1011     {
1012 #ifdef VM_ENABLE_STACK_NULLING
1013       int nullcount = stack_base - sp;
1014 #endif
1015       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1016       NULLSTACK (nullcount);
1017     }
1018
1019     /* Set return value (sp is already pushed) */
1020     *sp = ret;
1021   }
1022
1023   /* Restore the last program */
1024   program = SCM_FRAME_PROGRAM (fp);
1025   CACHE_PROGRAM ();
1026   CACHE_EXTERNAL ();
1027   CHECK_IP ();
1028   NEXT;
1029 }
1030
1031 VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
1032 {
1033   /* nvalues declared at top level, because for some reason gcc seems to think
1034      that perhaps it might be used without declaration. Fooey to that, I say. */
1035   SCM *data;
1036
1037   nvalues = FETCH ();
1038  vm_return_values:
1039   EXIT_HOOK ();
1040   RETURN_HOOK ();
1041
1042   data = SCM_FRAME_DATA_ADDRESS (fp);
1043   ASSERT (stack_base == data + 3);
1044
1045   /* data[2] is the mv return address */
1046   if (nvalues != 1 && data[2])
1047     {
1048       int i;
1049       /* Restore registers */
1050       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1051       ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
1052       fp = SCM_FRAME_STACK_CAST (data[1]);
1053
1054       /* Push return values, and the number of values */
1055       for (i = 0; i < nvalues; i++)
1056         *++sp = stack_base[1+i];
1057       *++sp = SCM_I_MAKINUM (nvalues);
1058
1059       /* Finally set new stack_base */
1060       NULLSTACK (stack_base - sp + nvalues + 1);
1061       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1062     }
1063   else if (nvalues >= 1)
1064     {
1065       /* Multiple values for a single-valued continuation -- here's where I
1066          break with guile tradition and try and do something sensible. (Also,
1067          this block handles the single-valued return to an mv
1068          continuation.) */
1069       /* Restore registers */
1070       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1071       ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */
1072       fp = SCM_FRAME_STACK_CAST (data[1]);
1073
1074       /* Push first value */
1075       *++sp = stack_base[1];
1076
1077       /* Finally set new stack_base */
1078       NULLSTACK (stack_base - sp + nvalues + 1);
1079       stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
1080     }
1081   else
1082     goto vm_error_no_values;
1083
1084   /* Restore the last program */
1085   program = SCM_FRAME_PROGRAM (fp);
1086   CACHE_PROGRAM ();
1087   CACHE_EXTERNAL ();
1088   CHECK_IP ();
1089   NEXT;
1090 }
1091
1092 VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
1093 {
1094   SCM l;
1095
1096   nvalues = FETCH ();
1097   ASSERT (nvalues >= 1);
1098
1099   nvalues--;
1100   POP (l);
1101   while (SCM_CONSP (l))
1102     {
1103       PUSH (SCM_CAR (l));
1104       l = SCM_CDR (l);
1105       nvalues++;
1106     }
1107   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1108     finish_args = scm_list_1 (l);
1109     goto vm_error_improper_list;
1110   }
1111
1112   goto vm_return_values;
1113 }
1114
1115 VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
1116 {
1117   SCM x;
1118   int nbinds, rest;
1119   POP (x);
1120   nvalues = scm_to_int (x);
1121   nbinds = FETCH ();
1122   rest = FETCH ();
1123
1124   if (rest)
1125     nbinds--;
1126
1127   if (nvalues < nbinds)
1128     goto vm_error_not_enough_values;
1129
1130   if (rest)
1131     POP_LIST (nvalues - nbinds);
1132   else
1133     DROPN (nvalues - nbinds);
1134
1135   NEXT;
1136 }
1137
1138 /*
1139 (defun renumber-ops ()
1140   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1141   (interactive "")
1142   (save-excursion
1143     (let ((counter -1)) (goto-char (point-min))
1144       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1145         (replace-match
1146          (number-to-string (setq counter (1+ counter)))
1147           t t nil 1)))))
1148 */
1149 /*
1150   Local Variables:
1151   c-file-style: "gnu"
1152   End:
1153 */