libguile/vm.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #if HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <string.h>
  47 #include "vm-bootstrap.h"
  48 #include "frames.h"
  49 #include "instructions.h"
  50 #include "objcodes.h"
  51 #include "programs.h"
  52 #include "vm.h"
  53
  54 /* I sometimes use this for debugging. */
  55 #define vm_puts(OBJ)                            \
  56 {                                               \
  57   scm_display (OBJ, scm_current_error_port ()); \
  58   scm_newline (scm_current_error_port ());      \
  59 }
  60
  61 /* The VM has a number of internal assertions that shouldn't normally be
  62    necessary, but might be if you think you found a bug in the VM. */
  63 #define VM_ENABLE_ASSERTIONS
  64
  65 /* We can add a mode that ensures that all stack items above the stack pointer
  66    are NULL. This is useful for checking the internal consistency of the VM's
  67    assumptions and its operators, but isn't necessary for normal operation. It
  68    will ensure that assertions are enabled. */
  69 #define VM_ENABLE_STACK_NULLING
  70
  71 #if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
  72 #define VM_ENABLE_ASSERTIONS
  73 #endif
  74
  75 \f
  76 /*
  77  * VM Continuation
  78  */
  79
  80 scm_t_bits scm_tc16_vm_cont;
  81
  82 struct scm_vm_cont {
  83   scm_byte_t *ip;
  84   scm_t_ptrdiff sp;
  85   scm_t_ptrdiff fp;
  86   scm_t_ptrdiff stack_size;
  87   SCM *stack_base;
  88   scm_t_ptrdiff reloc;
  89 };
  90
  91
  92 #define SCM_VM_CONT_P(OBJ)      SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
  93 #define SCM_VM_CONT_DATA(CONT)  ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
  94
  95 static void
  96 vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
  97 {
  98   SCM *sp, *upper, *lower;
  99   sp = base + size - 1;
 100
 101   while (sp > base && fp)
 102     {
 103       upper = SCM_FRAME_UPPER_ADDRESS (fp);
 104       lower = SCM_FRAME_LOWER_ADDRESS (fp);
 105
 106       for (; sp >= upper; sp--)
 107         if (SCM_NIMP (*sp))
 108           {
 109             if (scm_in_heap_p (*sp))
 110               scm_gc_mark (*sp);
 111             else
 112               fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
 113           }
 114
 115
 116       /* skip ra, mvra */
 117       sp -= 2;
 118
 119       /* update fp from the dynamic link */
 120       fp = (SCM*)*sp-- + reloc;
 121
 122       /* mark from the hl down to the lower address */
 123       for (; sp >= lower; sp--)
 124         if (*sp && SCM_NIMP (*sp))
 125           scm_gc_mark (*sp);
 126     }
 127 }
 128
 129 static SCM
 130 vm_cont_mark (SCM obj)
 131 {
 132   struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
 133
 134   vm_mark_stack (p->stack_base, p->stack_size, p->stack_base + p->fp, p->reloc);
 135
 136   return SCM_BOOL_F;
 137 }
 138
 139 static scm_sizet
 140 vm_cont_free (SCM obj)
 141 {
 142   struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
 143
 144   scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
 145   scm_gc_free (p, sizeof (struct scm_vm), "vm");
 146
 147   return 0;
 148 }
 149
 150 static SCM
 151 capture_vm_cont (struct scm_vm *vp)
 152 {
 153   struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
 154   p->stack_size = vp->sp - vp->stack_base + 1;
 155   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
 156                                  "capture_vm_cont");
 157 #ifdef VM_ENABLE_STACK_NULLING
 158   if (vp->sp >= vp->stack_base)
 159     if (!vp->sp[0] || vp->sp[1])
 160       abort ();
 161   memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
 162 #endif
 163   p->ip = vp->ip;
 164   p->sp = vp->sp - vp->stack_base;
 165   p->fp = vp->fp - vp->stack_base;
 166   memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
 167   p->reloc = p->stack_base - vp->stack_base;
 168   SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
 169 }
 170
 171 static void
 172 reinstate_vm_cont (struct scm_vm *vp, SCM cont)
 173 {
 174   struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
 175   if (vp->stack_size < p->stack_size)
 176     {
 177       /* puts ("FIXME: Need to expand"); */
 178       abort ();
 179     }
 180 #ifdef VM_ENABLE_STACK_NULLING
 181   {
 182     scm_t_ptrdiff nzero = (vp->sp - vp->stack_base) - p->sp;
 183     if (nzero > 0)
 184       memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
 185     /* actually nzero should always be negative, because vm_reset_stack will
 186        unwind the stack to some point *below* this continuation */
 187   }
 188 #endif
 189   vp->ip = p->ip;
 190   vp->sp = vp->stack_base + p->sp;
 191   vp->fp = vp->stack_base + p->fp;
 192   memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
 193 }
 194
 195 /* In theory, a number of vm instances can be active in the call trace, and we
 196    only want to reify the continuations of those in the current continuation
 197    root. I don't see a nice way to do this -- ideally it would involve dynwinds,
 198    and previous values of the *the-vm* fluid within the current continuation
 199    root. But we don't have access to continuation roots in the dynwind stack.
 200    So, just punt for now -- take the current value of *the-vm*.
 201
 202    While I'm on the topic, ideally we could avoid copying the C stack if the
 203    continuation root is inside VM code, and call/cc was invoked within that same
 204    call to vm_run; but that's currently not implemented.
 205  */
 206 SCM
 207 scm_vm_capture_continuations (void)
 208 {
 209   SCM vm = scm_the_vm ();
 210   return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
 211 }
 212
 213 void
 214 scm_vm_reinstate_continuations (SCM conts)
 215 {
 216   for (; conts != SCM_EOL; conts = SCM_CDR (conts))
 217     reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
 218 }
 219
 220 struct vm_unwind_data
 221 {
 222   struct scm_vm *vp;
 223   SCM *sp;
 224   SCM *fp;
 225   SCM this_frame;
 226 };
 227
 228 static void
 229 vm_reset_stack (void *data)
 230 {
 231   struct vm_unwind_data *w = data;
 232   struct scm_vm *vp = w->vp;
 233
 234   vp->sp = w->sp;
 235   vp->fp = w->fp;
 236   vp->this_frame = w->this_frame;
 237 #ifdef VM_ENABLE_STACK_NULLING
 238   memset (vp->sp + 1, 0, (vp->stack_size - (vp->sp + 1 - vp->stack_base)) * sizeof(SCM));
 239 #endif
 240 }
 241
 242 \f
 243 /*
 244  * VM Internal functions
 245  */
 246
 247 static SCM sym_vm_run;
 248 static SCM sym_vm_error;
 249 static SCM sym_debug;
 250
 251 static scm_byte_t *
 252 vm_fetch_length (scm_byte_t *ip, size_t *lenp)
 253 {
 254   /* NOTE: format defined in system/vm/conv.scm */
 255   *lenp = *ip++;
 256   if (*lenp < 254)
 257     return ip;
 258   else if (*lenp == 254)
 259     {
 260       int b1 = *ip++;
 261       int b2 = *ip++;
 262       *lenp = (b1 << 8) + b2;
 263     }
 264   else
 265     {
 266       int b1 = *ip++;
 267       int b2 = *ip++;
 268       int b3 = *ip++;
 269       int b4 = *ip++;
 270       *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
 271     }
 272   return ip;
 273 }
 274
 275 static SCM
 276 vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
 277 {
 278   SCM frame;
 279   SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
 280 #if 0
 281   SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
 282 #endif
 283   SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
 284
 285   if (!dl)
 286     {
 287       /* The top frame */
 288       frame = scm_c_make_heap_frame (fp);
 289       fp = SCM_HEAP_FRAME_POINTER (frame);
 290       SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
 291     }
 292   else
 293     {
 294       /* Child frames */
 295       SCM link = SCM_FRAME_HEAP_LINK (dl);
 296       if (!SCM_FALSEP (link))
 297         link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
 298       else
 299         link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
 300       frame = scm_c_make_heap_frame (fp);
 301       fp = SCM_HEAP_FRAME_POINTER (frame);
 302       /* FIXME: I don't think we should be storing heap links on the stack. */
 303       SCM_FRAME_HEAP_LINK (fp)    = link;
 304       SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
 305     }
 306
 307   /* Apparently the intention here is to be able to have a frame on the heap,
 308      but data on the stack, so that you can push as much as you want on the
 309      stack; but I think that it's currently causing borkage with nonlocal exits
 310      and the unwind handler, which reinstates the sp and fp, but it's no longer
 311      pointing at a valid stack frame. So disable for now, we'll get back to
 312      this later. */
 313 #if 0
 314   /* Move stack data */
 315   for (; src <= sp; src++, dest++)
 316     *dest = *src;
 317   *destp = dest;
 318 #endif
 319
 320   return frame;
 321 }
 322
 323 static SCM
 324 vm_heapify_frames (SCM vm)
 325 {
 326   struct scm_vm *vp = SCM_VM_DATA (vm);
 327   if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
 328     {
 329       SCM *dest;
 330       vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
 331       vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
 332       vp->sp = dest - 1;
 333     }
 334   return vp->this_frame;
 335 }
 336
 337 \f
 338 /*
 339  * VM
 340  */
 341
 342 #define VM_DEFAULT_STACK_SIZE   (16 * 1024)
 343
 344 #define VM_REGULAR_ENGINE       0
 345 #define VM_DEBUG_ENGINE         1
 346
 347 #if 0
 348 #define VM_NAME   vm_regular_engine
 349 #define VM_ENGINE VM_REGULAR_ENGINE
 350 #include "vm-engine.c"
 351 #undef VM_NAME
 352 #undef VM_ENGINE
 353 #endif
 354
 355 #define VM_NAME   vm_debug_engine
 356 #define VM_ENGINE VM_DEBUG_ENGINE
 357 #include "vm-engine.c"
 358 #undef VM_NAME
 359 #undef VM_ENGINE
 360
 361 scm_t_bits scm_tc16_vm;
 362
 363 SCM scm_the_vm_fluid;
 364
 365 static SCM
 366 make_vm (void)
 367 #define FUNC_NAME "make_vm"
 368 {
 369   int i;
 370   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 371
 372   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 373   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 374                                    "stack-base");
 375   vp->stack_limit = vp->stack_base + vp->stack_size - 3;
 376   vp->ip          = NULL;
 377   vp->sp          = vp->stack_base - 1;
 378   vp->fp          = NULL;
 379   vp->time        = 0;
 380   vp->clock       = 0;
 381   vp->options     = SCM_EOL;
 382   vp->this_frame  = SCM_BOOL_F;
 383   vp->last_frame  = SCM_BOOL_F;
 384   vp->last_ip     = NULL;
 385   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 386     vp->hooks[i] = SCM_BOOL_F;
 387   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 388 }
 389 #undef FUNC_NAME
 390
 391 static SCM
 392 vm_mark (SCM obj)
 393 {
 394   int i;
 395   struct scm_vm *vp = SCM_VM_DATA (obj);
 396
 397 #ifdef VM_ENABLE_STACK_NULLING
 398   if (vp->sp >= vp->stack_base)
 399     if (!vp->sp[0] || vp->sp[1])
 400       abort ();
 401 #endif
 402
 403   /* mark the stack, precisely */
 404   vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
 405
 406   /* mark other objects  */
 407   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 408     scm_gc_mark (vp->hooks[i]);
 409   scm_gc_mark (vp->this_frame);
 410   scm_gc_mark (vp->last_frame);
 411   return vp->options;
 412 }
 413
 414 static scm_sizet
 415 vm_free (SCM obj)
 416 {
 417   struct scm_vm *vp = SCM_VM_DATA (obj);
 418
 419   scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
 420                "stack-base");
 421   scm_gc_free (vp, sizeof (struct scm_vm), "vm");
 422
 423   return 0;
 424 }
 425
 426 SCM
 427 scm_vm_apply (SCM vm, SCM program, SCM args)
 428 #define FUNC_NAME "scm_vm_apply"
 429 {
 430   SCM_VALIDATE_PROGRAM (1, program);
 431   return vm_run (vm, program, args);
 432 }
 433 #undef FUNC_NAME
 434
 435 /* Scheme interface */
 436
 437 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 438             (void),
 439             "")
 440 #define FUNC_NAME s_scm_vm_version
 441 {
 442   return scm_from_locale_string (PACKAGE_VERSION);
 443 }
 444 #undef FUNC_NAME
 445
 446 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 447             (void),
 448             "")
 449 #define FUNC_NAME s_scm_the_vm
 450 {
 451   SCM ret;
 452
 453   if (SCM_NFALSEP ((ret = scm_fluid_ref (scm_the_vm_fluid))))
 454     return ret;
 455
 456   ret = make_vm ();
 457   scm_fluid_set_x (scm_the_vm_fluid, ret);
 458   return ret;
 459 }
 460 #undef FUNC_NAME
 461
 462
 463 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 464             (SCM obj),
 465             "")
 466 #define FUNC_NAME s_scm_vm_p
 467 {
 468   return SCM_BOOL (SCM_VM_P (obj));
 469 }
 470 #undef FUNC_NAME
 471
 472 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 473             (void),
 474             "")
 475 #define FUNC_NAME s_scm_make_vm,
 476 {
 477   return make_vm ();
 478 }
 479 #undef FUNC_NAME
 480
 481 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 482             (SCM vm),
 483             "")
 484 #define FUNC_NAME s_scm_vm_ip
 485 {
 486   SCM_VALIDATE_VM (1, vm);
 487   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 488 }
 489 #undef FUNC_NAME
 490
 491 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 492             (SCM vm),
 493             "")
 494 #define FUNC_NAME s_scm_vm_sp
 495 {
 496   SCM_VALIDATE_VM (1, vm);
 497   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 498 }
 499 #undef FUNC_NAME
 500
 501 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 502             (SCM vm),
 503             "")
 504 #define FUNC_NAME s_scm_vm_fp
 505 {
 506   SCM_VALIDATE_VM (1, vm);
 507   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 508 }
 509 #undef FUNC_NAME
 510
 511 #define VM_DEFINE_HOOK(n)                               \
 512 {                                                       \
 513   struct scm_vm *vp;                                    \
 514   SCM_VALIDATE_VM (1, vm);                              \
 515   vp = SCM_VM_DATA (vm);                                \
 516   if (SCM_FALSEP (vp->hooks[n]))                        \
 517     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 518   return vp->hooks[n];                                  \
 519 }
 520
 521 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 522             (SCM vm),
 523             "")
 524 #define FUNC_NAME s_scm_vm_boot_hook
 525 {
 526   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 527 }
 528 #undef FUNC_NAME
 529
 530 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 531             (SCM vm),
 532             "")
 533 #define FUNC_NAME s_scm_vm_halt_hook
 534 {
 535   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 536 }
 537 #undef FUNC_NAME
 538
 539 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 540             (SCM vm),
 541             "")
 542 #define FUNC_NAME s_scm_vm_next_hook
 543 {
 544   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 545 }
 546 #undef FUNC_NAME
 547
 548 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 549             (SCM vm),
 550             "")
 551 #define FUNC_NAME s_scm_vm_break_hook
 552 {
 553   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 554 }
 555 #undef FUNC_NAME
 556
 557 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 558             (SCM vm),
 559             "")
 560 #define FUNC_NAME s_scm_vm_enter_hook
 561 {
 562   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 563 }
 564 #undef FUNC_NAME
 565
 566 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 567             (SCM vm),
 568             "")
 569 #define FUNC_NAME s_scm_vm_apply_hook
 570 {
 571   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 572 }
 573 #undef FUNC_NAME
 574
 575 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 576             (SCM vm),
 577             "")
 578 #define FUNC_NAME s_scm_vm_exit_hook
 579 {
 580   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 581 }
 582 #undef FUNC_NAME
 583
 584 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 585             (SCM vm),
 586             "")
 587 #define FUNC_NAME s_scm_vm_return_hook
 588 {
 589   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 590 }
 591 #undef FUNC_NAME
 592
 593 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 594             (SCM vm, SCM key),
 595             "")
 596 #define FUNC_NAME s_scm_vm_option
 597 {
 598   SCM_VALIDATE_VM (1, vm);
 599   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 600 }
 601 #undef FUNC_NAME
 602
 603 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 604             (SCM vm, SCM key, SCM val),
 605             "")
 606 #define FUNC_NAME s_scm_set_vm_option_x
 607 {
 608   SCM_VALIDATE_VM (1, vm);
 609   SCM_VM_DATA (vm)->options
 610     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 611   return SCM_UNSPECIFIED;
 612 }
 613 #undef FUNC_NAME
 614
 615 SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 616             (SCM vm),
 617             "")
 618 #define FUNC_NAME s_scm_vm_stats
 619 {
 620   SCM stats;
 621
 622   SCM_VALIDATE_VM (1, vm);
 623
 624   stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
 625   scm_vector_set_x (stats, SCM_I_MAKINUM (0),
 626                     scm_from_ulong (SCM_VM_DATA (vm)->time));
 627   scm_vector_set_x (stats, SCM_I_MAKINUM (1),
 628                     scm_from_ulong (SCM_VM_DATA (vm)->clock));
 629
 630   return stats;
 631 }
 632 #undef FUNC_NAME
 633
 634 #define VM_CHECK_RUNNING(vm)                            \
 635   if (!SCM_VM_DATA (vm)->ip)                            \
 636     SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
 637
 638 SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
 639             (SCM vm),
 640             "")
 641 #define FUNC_NAME s_scm_vm_this_frame
 642 {
 643   SCM_VALIDATE_VM (1, vm);
 644   return SCM_VM_DATA (vm)->this_frame;
 645 }
 646 #undef FUNC_NAME
 647
 648 SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
 649             (SCM vm),
 650             "")
 651 #define FUNC_NAME s_scm_vm_last_frame
 652 {
 653   SCM_VALIDATE_VM (1, vm);
 654   return SCM_VM_DATA (vm)->last_frame;
 655 }
 656 #undef FUNC_NAME
 657
 658 SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
 659             (SCM vm),
 660             "")
 661 #define FUNC_NAME s_scm_vm_last_ip
 662 {
 663   SCM_VALIDATE_VM (1, vm);
 664   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
 665 }
 666 #undef FUNC_NAME
 667
 668 SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
 669             (SCM vm),
 670             "")
 671 #define FUNC_NAME s_scm_vm_save_stack
 672 {
 673   struct scm_vm *vp;
 674   SCM *dest;
 675   SCM_VALIDATE_VM (1, vm);
 676   vp = SCM_VM_DATA (vm);
 677
 678   if (vp->fp)
 679     {
 680 #ifdef VM_ENABLE_STACK_NULLING
 681       if (vp->sp >= vp->stack_base)
 682         if (!vp->sp[0] || vp->sp[1])
 683           abort ();
 684 #endif
 685       vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
 686       vp->last_ip = vp->ip;
 687     }
 688   else
 689     {
 690       vp->last_frame = SCM_BOOL_F;
 691     }
 692
 693
 694   return vp->last_frame;
 695 }
 696 #undef FUNC_NAME
 697
 698 SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
 699             (SCM vm),
 700             "")
 701 #define FUNC_NAME s_scm_vm_fetch_code
 702 {
 703   int i;
 704   SCM list;
 705   scm_byte_t *ip;
 706   struct scm_instruction *p;
 707
 708   SCM_VALIDATE_VM (1, vm);
 709   VM_CHECK_RUNNING (vm);
 710
 711   ip = SCM_VM_DATA (vm)->ip;
 712   p = SCM_INSTRUCTION (*ip);
 713
 714   list = SCM_LIST1 (scm_str2symbol (p->name));
 715   for (i = 1; i <= p->len; i++)
 716     list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
 717   return scm_reverse_x (list, SCM_EOL);
 718 }
 719 #undef FUNC_NAME
 720
 721 SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 722             (SCM vm),
 723             "")
 724 #define FUNC_NAME s_scm_vm_fetch_stack
 725 {
 726   SCM *sp;
 727   SCM ls = SCM_EOL;
 728   struct scm_vm *vp;
 729
 730   SCM_VALIDATE_VM (1, vm);
 731   VM_CHECK_RUNNING (vm);
 732
 733   vp = SCM_VM_DATA (vm);
 734   for (sp = vp->stack_base; sp <= vp->sp; sp++)
 735     ls = scm_cons (*sp, ls);
 736   return ls;
 737 }
 738 #undef FUNC_NAME
 739
 740 \f
 741 /*
 742  * Initialize
 743  */
 744
 745 SCM scm_load_compiled_with_vm (SCM file)
 746 {
 747   SCM program = scm_objcode_to_program (scm_load_objcode (file));
 748
 749   return vm_run (scm_the_vm (), program, SCM_EOL);
 750 }
 751
 752 void
 753 scm_bootstrap_vm (void)
 754 {
 755   static int strappage = 0;
 756
 757   if (strappage)
 758     return;
 759
 760   scm_bootstrap_frames ();
 761   scm_bootstrap_instructions ();
 762   scm_bootstrap_objcodes ();
 763   scm_bootstrap_programs ();
 764
 765   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
 766   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
 767   scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
 768
 769   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 770   scm_set_smob_mark (scm_tc16_vm, vm_mark);
 771   scm_set_smob_free (scm_tc16_vm, vm_free);
 772   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 773
 774   scm_the_vm_fluid = scm_permanent_object (scm_make_fluid ());
 775   scm_fluid_set_x (scm_the_vm_fluid, make_vm ());
 776   scm_c_define ("*the-vm*", scm_the_vm_fluid);
 777
 778   scm_c_define ("load-compiled",
 779                 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
 780                                   scm_load_compiled_with_vm));
 781
 782   sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
 783   sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
 784   sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
 785
 786   strappage = 1;
 787 }
 788
 789 void
 790 scm_init_vm (void)
 791 {
 792   scm_bootstrap_vm ();
 793
 794 #ifndef SCM_MAGIC_SNARFER
 795 #include "vm.x"
 796 #endif
 797 }
 798
 799 /*
 800   Local Variables:
 801   c-file-style: "gnu"
 802   End:
 803 */