libguile/vm-i-system.c

   1 /* Copyright (C) 2001, 2008, 2009, 2010, 2011,
   2  *   2012 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 /* This file is included in vm_engine.c */
  22
  23 /* Compiler barrier, to prevent instruction reordering, apparently due
  24    to a bug in GCC 4.3.2 on sparc-linux-gnu and on hppa2.0-linux-gnu.
  25    See <http://bugs.gnu.org/10520>, for details.  */
  26
  27 #ifdef __GNUC__
  28 # define COMPILER_BARRIER  __asm__ __volatile__ ("")
  29 #else
  30 # define COMPILER_BARRIER  do { } while (0)
  31 #endif
  32
  33
  34 \f
  35 /*
  36  * Basic operations
  37  */
  38
  39 VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
  40 {
  41   NEXT;
  42 }
  43
  44 VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
  45 {
  46   nvalues = SCM_I_INUM (*sp--);
  47   NULLSTACK (1);
  48   if (nvalues == 1)
  49     POP (finish_args);
  50   else
  51     {
  52       POP_LIST (nvalues);
  53       POP (finish_args);
  54       SYNC_REGISTER ();
  55       finish_args = scm_values (finish_args);
  56     }
  57
  58   {
  59 #ifdef VM_ENABLE_STACK_NULLING
  60     SCM *old_sp = sp;
  61 #endif
  62
  63     /* Restore registers */
  64     sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
  65     /* Setting the ip here doesn't actually affect control flow, as the calling
  66        code will restore its own registers, but it does help when walking the
  67        stack */
  68     ip = SCM_FRAME_RETURN_ADDRESS (fp);
  69     fp = SCM_FRAME_DYNAMIC_LINK (fp);
  70     COMPILER_BARRIER;
  71     NULLSTACK (old_sp - sp);
  72   }
  73
  74   goto vm_done;
  75 }
  76
  77 VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
  78 {
  79   DROP ();
  80   NEXT;
  81 }
  82
  83 VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1)
  84 {
  85   SCM x = *sp;
  86   PUSH (x);
  87   NEXT;
  88 }
  89
  90 \f
  91 /*
  92  * Object creation
  93  */
  94
  95 VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
  96 {
  97   PUSH (SCM_UNSPECIFIED);
  98   NEXT;
  99 }
 100
 101 VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1)
 102 {
 103   PUSH (SCM_BOOL_T);
 104   NEXT;
 105 }
 106
 107 VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1)
 108 {
 109   PUSH (SCM_BOOL_F);
 110   NEXT;
 111 }
 112
 113 VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1)
 114 {
 115   PUSH (SCM_ELISP_NIL);
 116   NEXT;
 117 }
 118
 119 VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
 120 {
 121   PUSH (SCM_EOL);
 122   NEXT;
 123 }
 124
 125 VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
 126 {
 127   PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
 128   NEXT;
 129 }
 130
 131 VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
 132 {
 133   PUSH (SCM_INUM0);
 134   NEXT;
 135 }
 136
 137 VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
 138 {
 139   PUSH (SCM_I_MAKINUM (1));
 140   NEXT;
 141 }
 142
 143 VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
 144 {
 145   int h = FETCH ();
 146   int l = FETCH ();
 147   PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
 148   NEXT;
 149 }
 150
 151 VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
 152 {
 153   scm_t_uint64 v = 0;
 154   v += FETCH ();
 155   v <<= 8; v += FETCH ();
 156   v <<= 8; v += FETCH ();
 157   v <<= 8; v += FETCH ();
 158   v <<= 8; v += FETCH ();
 159   v <<= 8; v += FETCH ();
 160   v <<= 8; v += FETCH ();
 161   v <<= 8; v += FETCH ();
 162   PUSH (scm_from_int64 ((scm_t_int64) v));
 163   NEXT;
 164 }
 165
 166 VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
 167 {
 168   scm_t_uint64 v = 0;
 169   v += FETCH ();
 170   v <<= 8; v += FETCH ();
 171   v <<= 8; v += FETCH ();
 172   v <<= 8; v += FETCH ();
 173   v <<= 8; v += FETCH ();
 174   v <<= 8; v += FETCH ();
 175   v <<= 8; v += FETCH ();
 176   v <<= 8; v += FETCH ();
 177   PUSH (scm_from_uint64 (v));
 178   NEXT;
 179 }
 180
 181 VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
 182 {
 183   scm_t_uint8 v = 0;
 184   v = FETCH ();
 185
 186   PUSH (SCM_MAKE_CHAR (v));
 187   /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())).  The
 188      contents of SCM_MAKE_CHAR may be evaluated more than once,
 189      resulting in a double fetch.  */
 190   NEXT;
 191 }
 192
 193 VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
 194 {
 195   scm_t_wchar v = 0;
 196   v += FETCH ();
 197   v <<= 8; v += FETCH ();
 198   v <<= 8; v += FETCH ();
 199   v <<= 8; v += FETCH ();
 200   PUSH (SCM_MAKE_CHAR (v));
 201   NEXT;
 202 }
 203
 204
 205
 206 VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
 207 {
 208   unsigned h = FETCH ();
 209   unsigned l = FETCH ();
 210   unsigned len = ((h << 8) + l);
 211   POP_LIST (len);
 212   NEXT;
 213 }
 214
 215 VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
 216 {
 217   unsigned h = FETCH ();
 218   unsigned l = FETCH ();
 219   unsigned len = ((h << 8) + l);
 220   SCM vect;
 221
 222   SYNC_REGISTER ();
 223   sp++; sp -= len;
 224   CHECK_UNDERFLOW ();
 225   vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
 226   memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
 227   NULLSTACK (len);
 228   *sp = vect;
 229
 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)      (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
 250
 251 #define FREE_VARIABLE_REF(i)    SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
 252
 253 /* ref */
 254
 255 VM_DEFINE_INSTRUCTION (19, 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 (20, 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 (21, 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 (22, long_local_ref, "long-local-ref", 2, 0, 1)
 282 {
 283   unsigned int i = FETCH ();
 284   i <<= 8;
 285   i += FETCH ();
 286   PUSH (LOCAL_REF (i));
 287   ASSERT_BOUND (*sp);
 288   NEXT;
 289 }
 290
 291 VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
 292 {
 293   PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
 294   NEXT;
 295 }
 296
 297 VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
 298 {
 299   unsigned int i = FETCH ();
 300   i <<= 8;
 301   i += FETCH ();
 302   PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
 303   NEXT;
 304 }
 305
 306 VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1)
 307 {
 308   SCM x = *sp;
 309
 310   /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because,
 311      unlike in top-variable-ref, it really isn't an internal assertion
 312      that can be optimized out -- the variable could be coming directly
 313      from the user.  */
 314   if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
 315     {
 316       func_name = "variable-ref";
 317       finish_args = x;
 318       goto vm_error_not_a_variable;
 319     }
 320   else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
 321     {
 322       SCM var_name;
 323
 324       /* Attempt to provide the variable name in the error message.  */
 325       var_name = scm_module_reverse_lookup (scm_current_module (), x);
 326       finish_args = scm_is_true (var_name) ? var_name : x;
 327       goto vm_error_unbound;
 328     }
 329   else
 330     {
 331       SCM o = VARIABLE_REF (x);
 332       *sp = o;
 333     }
 334
 335   NEXT;
 336 }
 337
 338 VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1)
 339 {
 340   SCM x = *sp;
 341
 342   if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
 343     {
 344       func_name = "variable-bound?";
 345       finish_args = x;
 346       goto vm_error_not_a_variable;
 347     }
 348   else
 349     *sp = scm_from_bool (VARIABLE_BOUNDP (x));
 350   NEXT;
 351 }
 352
 353 VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
 354 {
 355   unsigned objnum = FETCH ();
 356   SCM what, resolved;
 357   CHECK_OBJECT (objnum);
 358   what = OBJECT_REF (objnum);
 359
 360   if (!SCM_VARIABLEP (what))
 361     {
 362       SYNC_REGISTER ();
 363       resolved = resolve_variable (what, scm_program_module (program));
 364       if (!VARIABLE_BOUNDP (resolved))
 365         {
 366           finish_args = what;
 367           goto vm_error_unbound;
 368         }
 369       what = resolved;
 370       OBJECT_SET (objnum, what);
 371     }
 372
 373   PUSH (VARIABLE_REF (what));
 374   NEXT;
 375 }
 376
 377 VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
 378 {
 379   SCM what, resolved;
 380   unsigned int objnum = FETCH ();
 381   objnum <<= 8;
 382   objnum += FETCH ();
 383   CHECK_OBJECT (objnum);
 384   what = OBJECT_REF (objnum);
 385
 386   if (!SCM_VARIABLEP (what))
 387     {
 388       SYNC_REGISTER ();
 389       resolved = resolve_variable (what, scm_program_module (program));
 390       if (!VARIABLE_BOUNDP (resolved))
 391         {
 392           finish_args = what;
 393           goto vm_error_unbound;
 394         }
 395       what = resolved;
 396       OBJECT_SET (objnum, what);
 397     }
 398
 399   PUSH (VARIABLE_REF (what));
 400   NEXT;
 401 }
 402
 403 /* set */
 404
 405 VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
 406 {
 407   SCM x;
 408   POP (x);
 409   LOCAL_SET (FETCH (), x);
 410   NEXT;
 411 }
 412
 413 VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
 414 {
 415   SCM x;
 416   unsigned int i = FETCH ();
 417   i <<= 8;
 418   i += FETCH ();
 419   POP (x);
 420   LOCAL_SET (i, x);
 421   NEXT;
 422 }
 423
 424 VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
 425 {
 426   if (SCM_UNLIKELY (!SCM_VARIABLEP (sp[0])))
 427     {
 428       func_name = "variable-set!";
 429       finish_args = sp[0];
 430       goto vm_error_not_a_variable;
 431     }
 432   VARIABLE_SET (sp[0], sp[-1]);
 433   DROPN (2);
 434   NEXT;
 435 }
 436
 437 VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
 438 {
 439   unsigned objnum = FETCH ();
 440   SCM what;
 441   CHECK_OBJECT (objnum);
 442   what = OBJECT_REF (objnum);
 443
 444   if (!SCM_VARIABLEP (what))
 445     {
 446       SYNC_BEFORE_GC ();
 447       what = resolve_variable (what, scm_program_module (program));
 448       OBJECT_SET (objnum, what);
 449     }
 450
 451   VARIABLE_SET (what, *sp);
 452   DROP ();
 453   NEXT;
 454 }
 455
 456 VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
 457 {
 458   SCM what;
 459   unsigned int objnum = FETCH ();
 460   objnum <<= 8;
 461   objnum += FETCH ();
 462   CHECK_OBJECT (objnum);
 463   what = OBJECT_REF (objnum);
 464
 465   if (!SCM_VARIABLEP (what))
 466     {
 467       SYNC_BEFORE_GC ();
 468       what = resolve_variable (what, scm_program_module (program));
 469       OBJECT_SET (objnum, what);
 470     }
 471
 472   VARIABLE_SET (what, *sp);
 473   DROP ();
 474   NEXT;
 475 }
 476
 477 \f
 478 /*
 479  * branch and jump
 480  */
 481
 482 /* offset must be at least 24 bits wide, and signed */
 483 #define FETCH_OFFSET(offset)                    \
 484 {                                               \
 485   offset = FETCH () << 16;                      \
 486   offset += FETCH () << 8;                      \
 487   offset += FETCH ();                           \
 488   offset -= (offset & (1<<23)) << 1;            \
 489 }
 490
 491 #define BR(p)                                   \
 492 {                                               \
 493   scm_t_int32 offset;                           \
 494   FETCH_OFFSET (offset);                        \
 495   if (p)                                        \
 496     ip += offset;                               \
 497   if (offset < 0)                               \
 498     VM_HANDLE_INTERRUPTS;                       \
 499   NEXT;                                         \
 500 }
 501
 502 VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
 503 {
 504   scm_t_int32 offset;
 505   FETCH_OFFSET (offset);
 506   ip += offset;
 507   if (offset < 0)
 508     VM_HANDLE_INTERRUPTS;
 509   NEXT;
 510 }
 511
 512 VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
 513 {
 514   SCM x;
 515   POP (x);
 516   BR (scm_is_true (x));
 517 }
 518
 519 VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
 520 {
 521   SCM x;
 522   POP (x);
 523   BR (scm_is_false (x));
 524 }
 525
 526 VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
 527 {
 528   SCM x, y;
 529   POP2 (y, x);
 530   BR (scm_is_eq (x, y));
 531 }
 532
 533 VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
 534 {
 535   SCM x, y;
 536   POP2 (y, x);
 537   BR (!scm_is_eq (x, y));
 538 }
 539
 540 VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
 541 {
 542   SCM x;
 543   POP (x);
 544   BR (scm_is_null (x));
 545 }
 546
 547 VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
 548 {
 549   SCM x;
 550   POP (x);
 551   BR (!scm_is_null (x));
 552 }
 553
 554 \f
 555 /*
 556  * Subprogram call
 557  */
 558
 559 VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
 560 {
 561   scm_t_ptrdiff n;
 562   scm_t_int32 offset;
 563   n = FETCH () << 8;
 564   n += FETCH ();
 565   FETCH_OFFSET (offset);
 566   if (sp - (fp - 1) != n)
 567     ip += offset;
 568   NEXT;
 569 }
 570
 571 VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
 572 {
 573   scm_t_ptrdiff n;
 574   scm_t_int32 offset;
 575   n = FETCH () << 8;
 576   n += FETCH ();
 577   FETCH_OFFSET (offset);
 578   if (sp - (fp - 1) < n)
 579     ip += offset;
 580   NEXT;
 581 }
 582
 583 VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
 584 {
 585   scm_t_ptrdiff n;
 586   scm_t_int32 offset;
 587
 588   n = FETCH () << 8;
 589   n += FETCH ();
 590   FETCH_OFFSET (offset);
 591   if (sp - (fp - 1) > n)
 592     ip += offset;
 593   NEXT;
 594 }
 595
 596 VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
 597 {
 598   scm_t_ptrdiff n;
 599   n = FETCH () << 8;
 600   n += FETCH ();
 601   if (sp - (fp - 1) != n)
 602     goto vm_error_wrong_num_args;
 603   NEXT;
 604 }
 605
 606 VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
 607 {
 608   scm_t_ptrdiff n;
 609   n = FETCH () << 8;
 610   n += FETCH ();
 611   if (sp - (fp - 1) < n)
 612     goto vm_error_wrong_num_args;
 613   NEXT;
 614 }
 615
 616 VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
 617 {
 618   scm_t_ptrdiff n;
 619   n = FETCH () << 8;
 620   n += FETCH ();
 621   while (sp - (fp - 1) < n)
 622     PUSH (SCM_UNDEFINED);
 623   NEXT;
 624 }
 625
 626 VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
 627 {
 628   SCM *walk;
 629   scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
 630   nreq = FETCH () << 8;
 631   nreq += FETCH ();
 632   nreq_and_opt = FETCH () << 8;
 633   nreq_and_opt += FETCH ();
 634   ntotal = FETCH () << 8;
 635   ntotal += FETCH ();
 636
 637   /* look in optionals for first keyword or last positional */
 638   /* starting after the last required positional arg */
 639   walk = fp + nreq;
 640   while (/* while we have args */
 641          walk <= sp
 642          /* and we still have positionals to fill */
 643          && walk - fp < nreq_and_opt
 644          /* and we haven't reached a keyword yet */
 645          && !scm_is_keyword (*walk))
 646     /* bind this optional arg (by leaving it in place) */
 647     walk++;
 648   /* now shuffle up, from walk to ntotal */
 649   {
 650     scm_t_ptrdiff nshuf = sp - walk + 1, i;
 651     sp = (fp - 1) + ntotal + nshuf;
 652     CHECK_OVERFLOW ();
 653     for (i = 0; i < nshuf; i++)
 654       sp[-i] = walk[nshuf-i-1];
 655   }
 656   /* and fill optionals & keyword args with SCM_UNDEFINED */
 657   while (walk <= (fp - 1) + ntotal)
 658     *walk++ = SCM_UNDEFINED;
 659
 660   NEXT;
 661 }
 662
 663 /* Flags that determine whether other keywords are allowed, and whether a
 664    rest argument is expected.  These values must match those used by the
 665    glil->assembly compiler.  */
 666 #define F_ALLOW_OTHER_KEYS  1
 667 #define F_REST              2
 668
 669 VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
 670 {
 671   scm_t_uint16 idx;
 672   scm_t_ptrdiff nkw;
 673   int kw_and_rest_flags;
 674   SCM kw;
 675   idx = FETCH () << 8;
 676   idx += FETCH ();
 677   /* XXX: We don't actually use NKW.  */
 678   nkw = FETCH () << 8;
 679   nkw += FETCH ();
 680   kw_and_rest_flags = FETCH ();
 681
 682   if (!(kw_and_rest_flags & F_REST)
 683       && ((sp - (fp - 1) - nkw) % 2))
 684     goto vm_error_kwargs_length_not_even;
 685
 686   CHECK_OBJECT (idx);
 687   kw = OBJECT_REF (idx);
 688
 689   /* Switch NKW to be a negative index below SP.  */
 690   for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++)
 691     {
 692       SCM walk;
 693
 694       if (scm_is_keyword (sp[nkw]))
 695         {
 696           for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
 697             {
 698               if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
 699                 {
 700                   SCM si = SCM_CDAR (walk);
 701                   LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
 702                              sp[nkw + 1]);
 703                   break;
 704                 }
 705             }
 706           if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
 707             goto vm_error_kwargs_unrecognized_keyword;
 708
 709           nkw++;
 710         }
 711       else if (!(kw_and_rest_flags & F_REST))
 712         goto vm_error_kwargs_invalid_keyword;
 713     }
 714
 715   NEXT;
 716 }
 717
 718 #undef F_ALLOW_OTHER_KEYS
 719 #undef F_REST
 720
 721
 722 VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
 723 {
 724   scm_t_ptrdiff n;
 725   SCM rest = SCM_EOL;
 726   n = FETCH () << 8;
 727   n += FETCH ();
 728   while (sp - (fp - 1) > n)
 729     /* No need to check for underflow. */
 730     CONS (rest, *sp--, rest);
 731   PUSH (rest);
 732   NEXT;
 733 }
 734
 735 VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
 736 {
 737   scm_t_ptrdiff n;
 738   scm_t_uint32 i;
 739   SCM rest = SCM_EOL;
 740   n = FETCH () << 8;
 741   n += FETCH ();
 742   i = FETCH () << 8;
 743   i += FETCH ();
 744   while (sp - (fp - 1) > n)
 745     /* No need to check for underflow. */
 746     CONS (rest, *sp--, rest);
 747   LOCAL_SET (i, rest);
 748   NEXT;
 749 }
 750
 751 VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
 752 {
 753   SCM *old_sp;
 754   scm_t_int32 n;
 755   n = FETCH () << 8;
 756   n += FETCH ();
 757   old_sp = sp;
 758   sp = (fp - 1) + n;
 759
 760   if (old_sp < sp)
 761     {
 762       CHECK_OVERFLOW ();
 763       while (old_sp < sp)
 764         *++old_sp = SCM_UNDEFINED;
 765     }
 766   else
 767     NULLSTACK (old_sp - sp);
 768
 769   NEXT;
 770 }
 771
 772 VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
 773 {
 774   /* NB: if you change this, see frames.c:vm-frame-num-locals */
 775   /* and frames.h, vm-engine.c, etc of course */
 776
 777   /* We don't initialize the dynamic link here because we don't actually
 778      know that this frame will point to the current fp: it could be
 779      placed elsewhere on the stack if captured in a partial
 780      continuation, and invoked from some other context.  */
 781   PUSH (SCM_PACK (0)); /* dynamic link */
 782   PUSH (SCM_PACK (0)); /* mvra */
 783   PUSH (SCM_PACK (0)); /* ra */
 784   NEXT;
 785 }
 786
 787 VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
 788 {
 789   nargs = FETCH ();
 790
 791  vm_call:
 792   program = sp[-nargs];
 793
 794   VM_HANDLE_INTERRUPTS;
 795
 796   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 797     {
 798       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 799         {
 800           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
 801           goto vm_call;
 802         }
 803       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
 804                && SCM_SMOB_APPLICABLE_P (program))
 805         {
 806           SYNC_REGISTER ();
 807           sp[-nargs] = scm_i_smob_apply_trampoline (program);
 808           goto vm_call;
 809         }
 810       else
 811         goto vm_error_wrong_type_apply;
 812     }
 813
 814   CACHE_PROGRAM ();
 815
 816   {
 817     SCM *old_fp = fp;
 818
 819     fp = sp - nargs + 1;
 820
 821     ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
 822     ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
 823     ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
 824     SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
 825     SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
 826     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
 827   }
 828
 829   ip = SCM_C_OBJCODE_BASE (bp);
 830   PUSH_CONTINUATION_HOOK ();
 831   APPLY_HOOK ();
 832   NEXT;
 833 }
 834
 835 VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
 836 {
 837   nargs = FETCH ();
 838
 839  vm_tail_call:
 840   program = sp[-nargs];
 841
 842   VM_HANDLE_INTERRUPTS;
 843
 844   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
 845     {
 846       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
 847         {
 848           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
 849           goto vm_tail_call;
 850         }
 851       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
 852                && SCM_SMOB_APPLICABLE_P (program))
 853         {
 854           SYNC_REGISTER ();
 855           sp[-nargs] = scm_i_smob_apply_trampoline (program);
 856           goto vm_tail_call;
 857         }
 858       else
 859         goto vm_error_wrong_type_apply;
 860     }
 861   else
 862     {
 863       int i;
 864 #ifdef VM_ENABLE_STACK_NULLING
 865       SCM *old_sp = sp;
 866       CHECK_STACK_LEAK ();
 867 #endif
 868
 869       /* switch programs */
 870       CACHE_PROGRAM ();
 871       /* shuffle down the program and the arguments */
 872       for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
 873         SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 874
 875       sp = fp + i - 1;
 876
 877       NULLSTACK (old_sp - sp);
 878
 879       ip = SCM_C_OBJCODE_BASE (bp);
 880
 881       APPLY_HOOK ();
 882       NEXT;
 883     }
 884 }
 885
 886 VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
 887 {
 888   SCM pointer, ret;
 889   SCM (*subr)();
 890
 891   nargs = FETCH ();
 892   POP (pointer);
 893
 894   subr = SCM_POINTER_VALUE (pointer);
 895
 896   VM_HANDLE_INTERRUPTS;
 897   SYNC_REGISTER ();
 898
 899   switch (nargs)
 900     {
 901     case 0:
 902       ret = subr ();
 903       break;
 904     case 1:
 905       ret = subr (sp[0]);
 906       break;
 907     case 2:
 908       ret = subr (sp[-1], sp[0]);
 909       break;
 910     case 3:
 911       ret = subr (sp[-2], sp[-1], sp[0]);
 912       break;
 913     case 4:
 914       ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
 915       break;
 916     case 5:
 917       ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 918       break;
 919     case 6:
 920       ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 921       break;
 922     case 7:
 923       ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 924       break;
 925     case 8:
 926       ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 927       break;
 928     case 9:
 929       ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 930       break;
 931     case 10:
 932       ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
 933       break;
 934     default:
 935       abort ();
 936     }
 937
 938   NULLSTACK_FOR_NONLOCAL_EXIT ();
 939
 940   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 941     {
 942       /* multiple values returned to continuation */
 943       ret = scm_struct_ref (ret, SCM_INUM0);
 944       nvalues = scm_ilength (ret);
 945       PUSH_LIST (ret, scm_is_null);
 946       goto vm_return_values;
 947     }
 948   else
 949     {
 950       PUSH (ret);
 951       goto vm_return;
 952     }
 953 }
 954
 955 VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
 956 {
 957   SCM smob, ret;
 958   SCM (*subr)();
 959   nargs = FETCH ();
 960   POP (smob);
 961
 962   subr = SCM_SMOB_DESCRIPTOR (smob).apply;
 963
 964   VM_HANDLE_INTERRUPTS;
 965   SYNC_REGISTER ();
 966
 967   switch (nargs)
 968     {
 969     case 0:
 970       ret = subr (smob);
 971       break;
 972     case 1:
 973       ret = subr (smob, sp[0]);
 974       break;
 975     case 2:
 976       ret = subr (smob, sp[-1], sp[0]);
 977       break;
 978     case 3:
 979       ret = subr (smob, sp[-2], sp[-1], sp[0]);
 980       break;
 981     default:
 982       abort ();
 983     }
 984
 985   NULLSTACK_FOR_NONLOCAL_EXIT ();
 986
 987   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
 988     {
 989       /* multiple values returned to continuation */
 990       ret = scm_struct_ref (ret, SCM_INUM0);
 991       nvalues = scm_ilength (ret);
 992       PUSH_LIST (ret, scm_is_null);
 993       goto vm_return_values;
 994     }
 995   else
 996     {
 997       PUSH (ret);
 998       goto vm_return;
 999     }
1000 }
1001
1002 VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
1003 {
1004   SCM foreign, ret;
1005   nargs = FETCH ();
1006   POP (foreign);
1007
1008   VM_HANDLE_INTERRUPTS;
1009   SYNC_REGISTER ();
1010
1011   ret = scm_i_foreign_call (foreign, sp - nargs + 1);
1012
1013   NULLSTACK_FOR_NONLOCAL_EXIT ();
1014
1015   if (SCM_UNLIKELY (SCM_VALUESP (ret)))
1016     {
1017       /* multiple values returned to continuation */
1018       ret = scm_struct_ref (ret, SCM_INUM0);
1019       nvalues = scm_ilength (ret);
1020       PUSH_LIST (ret, scm_is_null);
1021       goto vm_return_values;
1022     }
1023   else
1024     {
1025       PUSH (ret);
1026       goto vm_return;
1027     }
1028 }
1029
1030 VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
1031 {
1032   SCM contregs;
1033   POP (contregs);
1034
1035   SYNC_ALL ();
1036   scm_i_check_continuation (contregs);
1037   vm_return_to_continuation (scm_i_contregs_vm (contregs),
1038                              scm_i_contregs_vm_cont (contregs),
1039                              sp - (fp - 1), fp);
1040   scm_i_reinstate_continuation (contregs);
1041
1042   /* no NEXT */
1043   abort ();
1044 }
1045
1046 VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
1047 {
1048   SCM vmcont, intwinds, prevwinds;
1049   POP2 (intwinds, vmcont);
1050   SYNC_REGISTER ();
1051   if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
1052     { finish_args = vmcont;
1053       goto vm_error_continuation_not_rewindable;
1054     }
1055   prevwinds = scm_i_dynwinds ();
1056   vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
1057                                      vm_cookie);
1058
1059   /* Rewind prompt jmpbuffers, if any. */
1060   {
1061     SCM winds = scm_i_dynwinds ();
1062     for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
1063       if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
1064         break;
1065   }
1066
1067   CACHE_REGISTER ();
1068   program = SCM_FRAME_PROGRAM (fp);
1069   CACHE_PROGRAM ();
1070   NEXT;
1071 }
1072
1073 VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
1074 {
1075   SCM x;
1076   POP (x);
1077   nargs = scm_to_int (x);
1078   /* FIXME: should truncate values? */
1079   goto vm_tail_call;
1080 }
1081
1082 VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
1083 {
1084   SCM x;
1085   POP (x);
1086   nargs = scm_to_int (x);
1087   /* FIXME: should truncate values? */
1088   goto vm_call;
1089 }
1090
1091 VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
1092 {
1093   scm_t_int32 offset;
1094   scm_t_uint8 *mvra;
1095
1096   nargs = FETCH ();
1097   FETCH_OFFSET (offset);
1098   mvra = ip + offset;
1099
1100  vm_mv_call:
1101   program = sp[-nargs];
1102
1103   VM_HANDLE_INTERRUPTS;
1104
1105   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
1106     {
1107       if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
1108         {
1109           sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
1110           goto vm_mv_call;
1111         }
1112       else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
1113                && SCM_SMOB_APPLICABLE_P (program))
1114         {
1115           SYNC_REGISTER ();
1116           sp[-nargs] = scm_i_smob_apply_trampoline (program);
1117           goto vm_mv_call;
1118         }
1119       else
1120         goto vm_error_wrong_type_apply;
1121     }
1122
1123   CACHE_PROGRAM ();
1124
1125   {
1126     SCM *old_fp = fp;
1127
1128     fp = sp - nargs + 1;
1129
1130     ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
1131     ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
1132     ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
1133     SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
1134     SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
1135     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
1136   }
1137
1138   ip = SCM_C_OBJCODE_BASE (bp);
1139   PUSH_CONTINUATION_HOOK ();
1140   APPLY_HOOK ();
1141   NEXT;
1142 }
1143
1144 VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
1145 {
1146   int len;
1147   SCM ls;
1148   POP (ls);
1149
1150   nargs = FETCH ();
1151   ASSERT (nargs >= 2);
1152
1153   len = scm_ilength (ls);
1154   if (SCM_UNLIKELY (len < 0))
1155     {
1156       finish_args = ls;
1157       goto vm_error_apply_to_non_list;
1158     }
1159
1160   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1161
1162   nargs += len - 2;
1163   goto vm_call;
1164 }
1165
1166 VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
1167 {
1168   int len;
1169   SCM ls;
1170   POP (ls);
1171
1172   nargs = FETCH ();
1173   ASSERT (nargs >= 2);
1174
1175   len = scm_ilength (ls);
1176   if (SCM_UNLIKELY (len < 0))
1177     {
1178       finish_args = ls;
1179       goto vm_error_apply_to_non_list;
1180     }
1181
1182   PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
1183
1184   nargs += len - 2;
1185   goto vm_tail_call;
1186 }
1187
1188 VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
1189 {
1190   int first;
1191   SCM proc, vm_cont, cont;
1192   POP (proc);
1193   SYNC_ALL ();
1194   vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
1195   cont = scm_i_make_continuation (&first, vm, vm_cont);
1196   if (first)
1197     {
1198       PUSH (SCM_PACK (0)); /* dynamic link */
1199       PUSH (SCM_PACK (0));  /* mvra */
1200       PUSH (SCM_PACK (0));  /* ra */
1201       PUSH (proc);
1202       PUSH (cont);
1203       nargs = 1;
1204       goto vm_call;
1205     }
1206   else
1207     {
1208       /* Otherwise, the vm continuation was reinstated, and
1209          vm_return_to_continuation pushed on one value. We know only one
1210          value was returned because we are in value context -- the
1211          previous block jumped to vm_call, not vm_mv_call, after all.
1212
1213          So, pull our regs back down from the vp, and march on to the
1214          next instruction. */
1215       CACHE_REGISTER ();
1216       program = SCM_FRAME_PROGRAM (fp);
1217       CACHE_PROGRAM ();
1218       RESTORE_CONTINUATION_HOOK ();
1219       NEXT;
1220     }
1221 }
1222
1223 VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
1224 {
1225   int first;
1226   SCM proc, vm_cont, cont;
1227   POP (proc);
1228   SYNC_ALL ();
1229   /* In contrast to call/cc, tail-call/cc captures the continuation without the
1230      stack frame. */
1231   vm_cont = scm_i_vm_capture_stack (vp->stack_base,
1232                                     SCM_FRAME_DYNAMIC_LINK (fp),
1233                                     SCM_FRAME_LOWER_ADDRESS (fp) - 1,
1234                                     SCM_FRAME_RETURN_ADDRESS (fp),
1235                                     SCM_FRAME_MV_RETURN_ADDRESS (fp),
1236                                     0);
1237   cont = scm_i_make_continuation (&first, vm, vm_cont);
1238   if (first)
1239     {
1240       PUSH (proc);
1241       PUSH (cont);
1242       nargs = 1;
1243       goto vm_tail_call;
1244     }
1245   else
1246     {
1247       /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
1248          does a return from the frame, either to the RA or
1249          MVRA. */
1250       CACHE_REGISTER ();
1251       program = SCM_FRAME_PROGRAM (fp);
1252       CACHE_PROGRAM ();
1253       /* Unfortunately we don't know whether we are at the RA, and thus
1254          have one value without an nvalues marker, or we are at the
1255          MVRA and thus have multiple values and the nvalues
1256          marker. Instead of adding heuristics here, we will let hook
1257          client code do that. */
1258       RESTORE_CONTINUATION_HOOK ();
1259       NEXT;
1260     }
1261 }
1262
1263 VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
1264 {
1265  vm_return:
1266   POP_CONTINUATION_HOOK (1);
1267
1268   VM_HANDLE_INTERRUPTS;
1269
1270   {
1271     SCM ret;
1272
1273     POP (ret);
1274
1275 #ifdef VM_ENABLE_STACK_NULLING
1276     SCM *old_sp = sp;
1277 #endif
1278
1279     /* Restore registers */
1280     sp = SCM_FRAME_LOWER_ADDRESS (fp);
1281     ip = SCM_FRAME_RETURN_ADDRESS (fp);
1282     fp = SCM_FRAME_DYNAMIC_LINK (fp);
1283     COMPILER_BARRIER;
1284
1285 #ifdef VM_ENABLE_STACK_NULLING
1286     NULLSTACK (old_sp - sp);
1287 #endif
1288
1289     /* Set return value (sp is already pushed) */
1290     *sp = ret;
1291   }
1292
1293   /* Restore the last program */
1294   program = SCM_FRAME_PROGRAM (fp);
1295   CACHE_PROGRAM ();
1296   CHECK_IP ();
1297   NEXT;
1298 }
1299
1300 VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1)
1301 {
1302   /* nvalues declared at top level, because for some reason gcc seems to think
1303      that perhaps it might be used without declaration. Fooey to that, I say. */
1304   nvalues = FETCH ();
1305  vm_return_values:
1306   POP_CONTINUATION_HOOK (nvalues);
1307
1308   VM_HANDLE_INTERRUPTS;
1309
1310   if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
1311     {
1312       /* A multiply-valued continuation */
1313       SCM *vals = sp - nvalues;
1314       int i;
1315       /* Restore registers */
1316       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1317       ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
1318       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1319       COMPILER_BARRIER;
1320
1321       /* Push return values, and the number of values */
1322       for (i = 0; i < nvalues; i++)
1323         *++sp = vals[i+1];
1324       *++sp = SCM_I_MAKINUM (nvalues);
1325
1326       /* Finally null the end of the stack */
1327       NULLSTACK (vals + nvalues - sp);
1328     }
1329   else if (nvalues >= 1)
1330     {
1331       /* Multiple values for a single-valued continuation -- here's where I
1332          break with guile tradition and try and do something sensible. (Also,
1333          this block handles the single-valued return to an mv
1334          continuation.) */
1335       SCM *vals = sp - nvalues;
1336       /* Restore registers */
1337       sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
1338       ip = SCM_FRAME_RETURN_ADDRESS (fp);
1339       fp = SCM_FRAME_DYNAMIC_LINK (fp);
1340       COMPILER_BARRIER;
1341
1342       /* Push first value */
1343       *++sp = vals[1];
1344
1345       /* Finally null the end of the stack */
1346       NULLSTACK (vals + nvalues - sp);
1347     }
1348   else
1349     goto vm_error_no_values;
1350
1351   /* Restore the last program */
1352   program = SCM_FRAME_PROGRAM (fp);
1353   CACHE_PROGRAM ();
1354   CHECK_IP ();
1355   NEXT;
1356 }
1357
1358 VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
1359 {
1360   SCM l;
1361
1362   nvalues = FETCH ();
1363   ASSERT (nvalues >= 1);
1364
1365   nvalues--;
1366   POP (l);
1367   while (scm_is_pair (l))
1368     {
1369       PUSH (SCM_CAR (l));
1370       l = SCM_CDR (l);
1371       nvalues++;
1372     }
1373   if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
1374     finish_args = scm_list_1 (l);
1375     goto vm_error_improper_list;
1376   }
1377
1378   goto vm_return_values;
1379 }
1380
1381 VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
1382 {
1383   SCM n;
1384   POP (n);
1385   nvalues = scm_to_int (n);
1386   ASSERT (nvalues >= 0);
1387   goto vm_return_values;
1388 }
1389
1390 VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
1391 {
1392   SCM x;
1393   int nbinds, rest;
1394   POP (x);
1395   nvalues = scm_to_int (x);
1396   nbinds = FETCH ();
1397   rest = FETCH ();
1398
1399   if (rest)
1400     nbinds--;
1401
1402   if (nvalues < nbinds)
1403     goto vm_error_not_enough_values;
1404
1405   if (rest)
1406     POP_LIST (nvalues - nbinds);
1407   else
1408     DROPN (nvalues - nbinds);
1409
1410   NEXT;
1411 }
1412
1413 VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
1414 {
1415   SCM val;
1416   POP (val);
1417   SYNC_BEFORE_GC ();
1418   LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
1419   NEXT;
1420 }
1421
1422 /* for letrec:
1423    (let ((a *undef*) (b *undef*) ...)
1424      (set! a (lambda () (b ...)))
1425      ...)
1426  */
1427 VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
1428 {
1429   SYNC_BEFORE_GC ();
1430   LOCAL_SET (FETCH (),
1431              scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1432   NEXT;
1433 }
1434
1435 VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
1436 {
1437   SCM v = LOCAL_REF (FETCH ());
1438   ASSERT_BOUND_VARIABLE (v);
1439   PUSH (VARIABLE_REF (v));
1440   NEXT;
1441 }
1442
1443 VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
1444 {
1445   SCM v, val;
1446   v = LOCAL_REF (FETCH ());
1447   POP (val);
1448   ASSERT_VARIABLE (v);
1449   VARIABLE_SET (v, val);
1450   NEXT;
1451 }
1452
1453 VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
1454 {
1455   scm_t_uint8 idx = FETCH ();
1456
1457   CHECK_FREE_VARIABLE (idx);
1458   PUSH (FREE_VARIABLE_REF (idx));
1459   NEXT;
1460 }
1461
1462 /* no free-set -- if a var is assigned, it should be in a box */
1463
1464 VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
1465 {
1466   SCM v;
1467   scm_t_uint8 idx = FETCH ();
1468   CHECK_FREE_VARIABLE (idx);
1469   v = FREE_VARIABLE_REF (idx);
1470   ASSERT_BOUND_VARIABLE (v);
1471   PUSH (VARIABLE_REF (v));
1472   NEXT;
1473 }
1474
1475 VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
1476 {
1477   SCM v, val;
1478   scm_t_uint8 idx = FETCH ();
1479   POP (val);
1480   CHECK_FREE_VARIABLE (idx);
1481   v = FREE_VARIABLE_REF (idx);
1482   ASSERT_BOUND_VARIABLE (v);
1483   VARIABLE_SET (v, val);
1484   NEXT;
1485 }
1486
1487 VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
1488 {
1489   size_t n, len;
1490   SCM closure;
1491
1492   len = FETCH ();
1493   len <<= 8;
1494   len += FETCH ();
1495   SYNC_BEFORE_GC ();
1496   closure = scm_words (scm_tc7_program | (len<<16), len + 3);
1497   SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
1498   SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
1499   sp[-len] = closure;
1500   for (n = 0; n < len; n++)
1501     SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
1502   DROPN (len);
1503   NEXT;
1504 }
1505
1506 VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
1507 {
1508   SYNC_BEFORE_GC ();
1509   /* fixme underflow */
1510   PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
1511   NEXT;
1512 }
1513
1514 VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
1515 {
1516   SCM x;
1517   unsigned int i = FETCH ();
1518   size_t n, len;
1519   i <<= 8;
1520   i += FETCH ();
1521   /* FIXME CHECK_LOCAL (i) */
1522   x = LOCAL_REF (i);
1523   /* FIXME ASSERT_PROGRAM (x); */
1524   len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
1525   for (n = 0; n < len; n++)
1526     SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
1527   DROPN (len);
1528   NEXT;
1529 }
1530
1531 VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
1532 {
1533   SCM sym, val;
1534   POP2 (sym, val);
1535   SYNC_REGISTER ();
1536   VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
1537                              SCM_BOOL_T),
1538                 val);
1539   NEXT;
1540 }
1541
1542 VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
1543 {
1544   CHECK_UNDERFLOW ();
1545   SYNC_REGISTER ();
1546   *sp = scm_symbol_to_keyword (*sp);
1547   NEXT;
1548 }
1549
1550 VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
1551 {
1552   CHECK_UNDERFLOW ();
1553   SYNC_REGISTER ();
1554   *sp = scm_string_to_symbol (*sp);
1555   NEXT;
1556 }
1557
1558 VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
1559 {
1560   scm_t_int32 offset;
1561   scm_t_uint8 escape_only_p;
1562   SCM k, prompt;
1563
1564   escape_only_p = FETCH ();
1565   FETCH_OFFSET (offset);
1566   POP (k);
1567
1568   SYNC_REGISTER ();
1569   /* Push the prompt onto the dynamic stack. */
1570   prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
1571                               scm_i_dynwinds ());
1572   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
1573   if (SCM_PROMPT_SETJMP (prompt))
1574     {
1575       /* The prompt exited nonlocally. Cache the regs back from the vp, and go
1576          to the handler.
1577
1578          Note, at this point, we must assume that any variable local to
1579          vm_engine that can be assigned *has* been assigned. So we need to pull
1580          all our state back from the ip/fp/sp.
1581       */
1582       CACHE_REGISTER ();
1583       program = SCM_FRAME_PROGRAM (fp);
1584       CACHE_PROGRAM ();
1585       /* The stack contains the values returned to this prompt, along
1586          with a number-of-values marker -- like an MV return. */
1587       ABORT_CONTINUATION_HOOK ();
1588       NEXT;
1589     }
1590
1591   /* Otherwise setjmp returned for the first time, so we go to execute the
1592      prompt's body. */
1593   NEXT;
1594 }
1595
1596 VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
1597 {
1598   SCM wind, unwind;
1599   POP2 (unwind, wind);
1600   SYNC_REGISTER ();
1601   /* Push wind and unwind procedures onto the dynamic stack. Note that neither
1602      are actually called; the compiler should emit calls to wind and unwind for
1603      the normal dynamic-wind control flow. */
1604   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
1605     {
1606       finish_args = wind;
1607       goto vm_error_not_a_thunk;
1608     }
1609   if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
1610     {
1611       finish_args = unwind;
1612       goto vm_error_not_a_thunk;
1613     }
1614   scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
1615   NEXT;
1616 }
1617
1618 VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
1619 {
1620   unsigned n = FETCH ();
1621   SYNC_REGISTER ();
1622   if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
1623     goto vm_error_stack_underflow;
1624   vm_abort (vm, n, vm_cookie);
1625   /* vm_abort should not return */
1626   abort ();
1627 }
1628
1629 VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
1630 {
1631   /* A normal exit from the dynamic extent of an expression. Pop the top entry
1632      off of the dynamic stack. */
1633   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1634   NEXT;
1635 }
1636
1637 VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
1638 {
1639   unsigned n = FETCH ();
1640   SCM wf;
1641
1642   SYNC_REGISTER ();
1643   sp -= 2 * n;
1644   CHECK_UNDERFLOW ();
1645   wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
1646   NULLSTACK (2 * n);
1647
1648   scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
1649   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
1650   NEXT;
1651 }
1652
1653 VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
1654 {
1655   SCM wf;
1656   wf = scm_car (scm_i_dynwinds ());
1657   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
1658   scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
1659   NEXT;
1660 }
1661
1662 VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
1663 {
1664   size_t num;
1665   SCM fluids;
1666
1667   CHECK_UNDERFLOW ();
1668   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
1669   if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
1670       || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1671     {
1672       /* Punt dynstate expansion and error handling to the C proc. */
1673       SYNC_REGISTER ();
1674       *sp = scm_fluid_ref (*sp);
1675     }
1676   else
1677     {
1678       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
1679       if (scm_is_eq (val, SCM_UNDEFINED))
1680         val = SCM_I_FLUID_DEFAULT (*sp);
1681       if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
1682         {
1683           finish_args = *sp;
1684           goto vm_error_unbound_fluid;
1685         }
1686       *sp = val;
1687     }
1688
1689   NEXT;
1690 }
1691
1692 VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
1693 {
1694   size_t num;
1695   SCM val, fluid, fluids;
1696
1697   POP2 (val, fluid);
1698   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
1699   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
1700       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
1701     {
1702       /* Punt dynstate expansion and error handling to the C proc. */
1703       SYNC_REGISTER ();
1704       scm_fluid_set_x (fluid, val);
1705     }
1706   else
1707     SCM_SIMPLE_VECTOR_SET (fluids, num, val);
1708
1709   NEXT;
1710 }
1711
1712 VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
1713 {
1714   scm_t_ptrdiff n;
1715   SCM *old_sp;
1716
1717   /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
1718   n = FETCH ();
1719
1720   if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
1721     goto vm_error_wrong_num_args;
1722
1723   old_sp = sp;
1724   sp += (n >> 3);
1725   CHECK_OVERFLOW ();
1726   while (old_sp < sp)
1727     *++old_sp = SCM_UNDEFINED;
1728
1729   NEXT;
1730 }
1731
1732 #undef COMPILER_BARRIER
1733
1734 /*
1735 (defun renumber-ops ()
1736   "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
1737   (interactive "")
1738   (save-excursion
1739     (let ((counter -1)) (goto-char (point-min))
1740       (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
1741         (replace-match
1742          (number-to-string (setq counter (1+ counter)))
1743           t t nil 1)))))
1744 (renumber-ops)
1745 */
1746 /*
1747   Local Variables:
1748   c-file-style: "gnu"
1749   End:
1750 */