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