libguile/vm-i-system.c

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