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   memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
 159 #endif
 160   p->ip = vp->ip;
 161   p->sp = vp->sp - vp->stack_base;
 162   p->fp = vp->fp - vp->stack_base;
 163   memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
 164   p->reloc = p->stack_base - vp->stack_base;
 165   SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
 166 }
 167
 168 static void
 169 reinstate_vm_cont (struct scm_vm *vp, SCM cont)
 170 {
 171   struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
 172   if (vp->stack_size < p->stack_size)
 173     {
 174       /* puts ("FIXME: Need to expand"); */
 175       abort ();
 176     }
 177 #ifdef VM_ENABLE_STACK_NULLING
 178   {
 179     scm_t_ptrdiff nzero = (vp->sp - vp->stack_base) - p->sp;
 180     if (nzero > 0)
 181       memset (vp->stack_base + p->stack_size, 0, nzero);
 182   }
 183 #endif
 184   vp->ip = p->ip;
 185   vp->sp = vp->stack_base + p->sp;
 186   vp->fp = vp->stack_base + p->fp;
 187   memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
 188 }
 189
 190 /* In theory, a number of vm instances can be active in the call trace, and we
 191    only want to reify the continuations of those in the current continuation
 192    root. I don't see a nice way to do this -- ideally it would involve dynwinds,
 193    and previous values of the *the-vm* fluid within the current continuation
 194    root. But we don't have access to continuation roots in the dynwind stack.
 195    So, just punt for now -- take the current value of *the-vm*.
 196
 197    While I'm on the topic, ideally we could avoid copying the C stack if the
 198    continuation root is inside VM code, and call/cc was invoked within that same
 199    call to vm_run; but that's currently not implemented.
 200  */
 201 SCM
 202 scm_vm_capture_continuations (void)
 203 {
 204   SCM vm = scm_the_vm ();
 205   return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
 206 }
 207
 208 void
 209 scm_vm_reinstate_continuations (SCM conts)
 210 {
 211   for (; conts != SCM_EOL; conts = SCM_CDR (conts))
 212     reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
 213 }
 214
 215 struct vm_unwind_data
 216 {
 217   struct scm_vm *vp;
 218   SCM *sp;
 219   SCM *fp;
 220   SCM this_frame;
 221 };
 222
 223 static void
 224 vm_reset_stack (void *data)
 225 {
 226   struct vm_unwind_data *w = data;
 227
 228   w->vp->sp = w->sp;
 229   w->vp->fp = w->fp;
 230   w->vp->this_frame = w->this_frame;
 231 #ifdef VM_ENABLE_STACK_NULLING
 232   memset (w->vp->sp + 1, 0, w->vp->stack_size - (w->vp->sp + 1 - w->vp->stack_base));
 233 #endif
 234 }
 235
 236 \f
 237 /*
 238  * VM Internal functions
 239  */
 240
 241 static SCM sym_vm_run;
 242 static SCM sym_vm_error;
 243 static SCM sym_debug;
 244
 245 static scm_byte_t *
 246 vm_fetch_length (scm_byte_t *ip, size_t *lenp)
 247 {
 248   /* NOTE: format defined in system/vm/conv.scm */
 249   *lenp = *ip++;
 250   if (*lenp < 254)
 251     return ip;
 252   else if (*lenp == 254)
 253     {
 254       int b1 = *ip++;
 255       int b2 = *ip++;
 256       *lenp = (b1 << 8) + b2;
 257     }
 258   else
 259     {
 260       int b1 = *ip++;
 261       int b2 = *ip++;
 262       int b3 = *ip++;
 263       int b4 = *ip++;
 264       *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
 265     }
 266   return ip;
 267 }
 268
 269 static SCM
 270 vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
 271 {
 272   SCM frame;
 273   SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
 274 #if 0
 275   SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
 276 #endif
 277   SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
 278
 279   if (!dl)
 280     {
 281       /* The top frame */
 282       frame = scm_c_make_heap_frame (fp);
 283       fp = SCM_HEAP_FRAME_POINTER (frame);
 284       SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
 285     }
 286   else
 287     {
 288       /* Child frames */
 289       SCM link = SCM_FRAME_HEAP_LINK (dl);
 290       if (!SCM_FALSEP (link))
 291         link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
 292       else
 293         link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
 294       frame = scm_c_make_heap_frame (fp);
 295       fp = SCM_HEAP_FRAME_POINTER (frame);
 296       SCM_FRAME_HEAP_LINK (fp)    = link;
 297       SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
 298     }
 299
 300   /* Apparently the intention here is to be able to have a frame on the heap,
 301      but data on the stack, so that you can push as much as you want on the
 302      stack; but I think that it's currently causing borkage with nonlocal exits
 303      and the unwind handler, which reinstates the sp and fp, but it's no longer
 304      pointing at a valid stack frame. So disable for now, we'll get back to
 305      this later. */
 306 #if 0
 307   /* Move stack data */
 308   for (; src <= sp; src++, dest++)
 309     *dest = *src;
 310   *destp = dest;
 311 #endif
 312
 313   return frame;
 314 }
 315
 316 static SCM
 317 vm_heapify_frames (SCM vm)
 318 {
 319   struct scm_vm *vp = SCM_VM_DATA (vm);
 320   if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
 321     {
 322       SCM *dest;
 323       vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
 324       vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
 325       vp->sp = dest - 1;
 326     }
 327   return vp->this_frame;
 328 }
 329
 330 \f
 331 /*
 332  * VM
 333  */
 334
 335 #define VM_DEFAULT_STACK_SIZE   (16 * 1024)
 336
 337 #define VM_REGULAR_ENGINE       0
 338 #define VM_DEBUG_ENGINE         1
 339
 340 #if 0
 341 #define VM_NAME   vm_regular_engine
 342 #define VM_ENGINE VM_REGULAR_ENGINE
 343 #include "vm-engine.c"
 344 #undef VM_NAME
 345 #undef VM_ENGINE
 346 #endif
 347
 348 #define VM_NAME   vm_debug_engine
 349 #define VM_ENGINE VM_DEBUG_ENGINE
 350 #include "vm-engine.c"
 351 #undef VM_NAME
 352 #undef VM_ENGINE
 353
 354 scm_t_bits scm_tc16_vm;
 355
 356 SCM scm_the_vm_fluid;
 357
 358 static SCM
 359 make_vm (void)
 360 #define FUNC_NAME "make_vm"
 361 {
 362   int i;
 363   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 364
 365   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 366   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 367                                    "stack-base");
 368   vp->stack_limit = vp->stack_base + vp->stack_size - 3;
 369   vp->ip          = NULL;
 370   vp->sp          = vp->stack_base - 1;
 371   vp->fp          = NULL;
 372   vp->time        = 0;
 373   vp->clock       = 0;
 374   vp->options     = SCM_EOL;
 375   vp->this_frame  = SCM_BOOL_F;
 376   vp->last_frame  = SCM_BOOL_F;
 377   vp->last_ip     = NULL;
 378   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 379     vp->hooks[i] = SCM_BOOL_F;
 380   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 381 }
 382 #undef FUNC_NAME
 383
 384 static SCM
 385 vm_mark (SCM obj)
 386 {
 387   int i;
 388   struct scm_vm *vp = SCM_VM_DATA (obj);
 389
 390 #ifdef VM_ENABLE_STACK_NULLING
 391   if (vp->sp >= vp->stack_base)
 392     if (!vp->sp[0] || vp->sp[1])
 393       abort ();
 394 #endif
 395
 396   /* mark the stack, precisely */
 397   vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
 398
 399   /* mark other objects  */
 400   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 401     scm_gc_mark (vp->hooks[i]);
 402   scm_gc_mark (vp->this_frame);
 403   scm_gc_mark (vp->last_frame);
 404   return vp->options;
 405 }
 406
 407 static scm_sizet
 408 vm_free (SCM obj)
 409 {
 410   struct scm_vm *vp = SCM_VM_DATA (obj);
 411
 412   scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
 413                "stack-base");
 414   scm_gc_free (vp, sizeof (struct scm_vm), "vm");
 415
 416   return 0;
 417 }
 418
 419 SCM
 420 scm_vm_apply (SCM vm, SCM program, SCM args)
 421 #define FUNC_NAME "scm_vm_apply"
 422 {
 423   SCM_VALIDATE_PROGRAM (1, program);
 424   return vm_run (vm, program, args);
 425 }
 426 #undef FUNC_NAME
 427
 428 /* Scheme interface */
 429
 430 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 431             (void),
 432             "")
 433 #define FUNC_NAME s_scm_vm_version
 434 {
 435   return scm_from_locale_string (PACKAGE_VERSION);
 436 }
 437 #undef FUNC_NAME
 438
 439 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 440             (void),
 441             "")
 442 #define FUNC_NAME s_scm_the_vm
 443 {
 444   SCM ret;
 445
 446   if (SCM_NFALSEP ((ret = scm_fluid_ref (scm_the_vm_fluid))))
 447     return ret;
 448
 449   ret = make_vm ();
 450   scm_fluid_set_x (scm_the_vm_fluid, ret);
 451   return ret;
 452 }
 453 #undef FUNC_NAME
 454
 455
 456 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 457             (SCM obj),
 458             "")
 459 #define FUNC_NAME s_scm_vm_p
 460 {
 461   return SCM_BOOL (SCM_VM_P (obj));
 462 }
 463 #undef FUNC_NAME
 464
 465 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 466             (void),
 467             "")
 468 #define FUNC_NAME s_scm_make_vm,
 469 {
 470   return make_vm ();
 471 }
 472 #undef FUNC_NAME
 473
 474 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 475             (SCM vm),
 476             "")
 477 #define FUNC_NAME s_scm_vm_ip
 478 {
 479   SCM_VALIDATE_VM (1, vm);
 480   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 481 }
 482 #undef FUNC_NAME
 483
 484 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 485             (SCM vm),
 486             "")
 487 #define FUNC_NAME s_scm_vm_sp
 488 {
 489   SCM_VALIDATE_VM (1, vm);
 490   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 491 }
 492 #undef FUNC_NAME
 493
 494 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 495             (SCM vm),
 496             "")
 497 #define FUNC_NAME s_scm_vm_fp
 498 {
 499   SCM_VALIDATE_VM (1, vm);
 500   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 501 }
 502 #undef FUNC_NAME
 503
 504 #define VM_DEFINE_HOOK(n)                               \
 505 {                                                       \
 506   struct scm_vm *vp;                                    \
 507   SCM_VALIDATE_VM (1, vm);                              \
 508   vp = SCM_VM_DATA (vm);                                \
 509   if (SCM_FALSEP (vp->hooks[n]))                        \
 510     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 511   return vp->hooks[n];                                  \
 512 }
 513
 514 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 515             (SCM vm),
 516             "")
 517 #define FUNC_NAME s_scm_vm_boot_hook
 518 {
 519   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 520 }
 521 #undef FUNC_NAME
 522
 523 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 524             (SCM vm),
 525             "")
 526 #define FUNC_NAME s_scm_vm_halt_hook
 527 {
 528   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 529 }
 530 #undef FUNC_NAME
 531
 532 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 533             (SCM vm),
 534             "")
 535 #define FUNC_NAME s_scm_vm_next_hook
 536 {
 537   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 538 }
 539 #undef FUNC_NAME
 540
 541 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 542             (SCM vm),
 543             "")
 544 #define FUNC_NAME s_scm_vm_break_hook
 545 {
 546   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 547 }
 548 #undef FUNC_NAME
 549
 550 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 551             (SCM vm),
 552             "")
 553 #define FUNC_NAME s_scm_vm_enter_hook
 554 {
 555   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 556 }
 557 #undef FUNC_NAME
 558
 559 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 560             (SCM vm),
 561             "")
 562 #define FUNC_NAME s_scm_vm_apply_hook
 563 {
 564   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 565 }
 566 #undef FUNC_NAME
 567
 568 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 569             (SCM vm),
 570             "")
 571 #define FUNC_NAME s_scm_vm_exit_hook
 572 {
 573   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 574 }
 575 #undef FUNC_NAME
 576
 577 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 578             (SCM vm),
 579             "")
 580 #define FUNC_NAME s_scm_vm_return_hook
 581 {
 582   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 583 }
 584 #undef FUNC_NAME
 585
 586 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 587             (SCM vm, SCM key),
 588             "")
 589 #define FUNC_NAME s_scm_vm_option
 590 {
 591   SCM_VALIDATE_VM (1, vm);
 592   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 593 }
 594 #undef FUNC_NAME
 595
 596 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 597             (SCM vm, SCM key, SCM val),
 598             "")
 599 #define FUNC_NAME s_scm_set_vm_option_x
 600 {
 601   SCM_VALIDATE_VM (1, vm);
 602   SCM_VM_DATA (vm)->options
 603     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 604   return SCM_UNSPECIFIED;
 605 }
 606 #undef FUNC_NAME
 607
 608 SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 609             (SCM vm),
 610             "")
 611 #define FUNC_NAME s_scm_vm_stats
 612 {
 613   SCM stats;
 614
 615   SCM_VALIDATE_VM (1, vm);
 616
 617   stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
 618   scm_vector_set_x (stats, SCM_I_MAKINUM (0),
 619                     scm_from_ulong (SCM_VM_DATA (vm)->time));
 620   scm_vector_set_x (stats, SCM_I_MAKINUM (1),
 621                     scm_from_ulong (SCM_VM_DATA (vm)->clock));
 622
 623   return stats;
 624 }
 625 #undef FUNC_NAME
 626
 627 #define VM_CHECK_RUNNING(vm)                            \
 628   if (!SCM_VM_DATA (vm)->ip)                            \
 629     SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
 630
 631 SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
 632             (SCM vm),
 633             "")
 634 #define FUNC_NAME s_scm_vm_this_frame
 635 {
 636   SCM_VALIDATE_VM (1, vm);
 637   return SCM_VM_DATA (vm)->this_frame;
 638 }
 639 #undef FUNC_NAME
 640
 641 SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
 642             (SCM vm),
 643             "")
 644 #define FUNC_NAME s_scm_vm_last_frame
 645 {
 646   SCM_VALIDATE_VM (1, vm);
 647   return SCM_VM_DATA (vm)->last_frame;
 648 }
 649 #undef FUNC_NAME
 650
 651 SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
 652             (SCM vm),
 653             "")
 654 #define FUNC_NAME s_scm_vm_last_ip
 655 {
 656   SCM_VALIDATE_VM (1, vm);
 657   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
 658 }
 659 #undef FUNC_NAME
 660
 661 SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
 662             (SCM vm),
 663             "")
 664 #define FUNC_NAME s_scm_vm_save_stack
 665 {
 666   struct scm_vm *vp;
 667   SCM *dest;
 668   SCM_VALIDATE_VM (1, vm);
 669   vp = SCM_VM_DATA (vm);
 670
 671   if (vp->fp)
 672     {
 673       vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
 674       vp->last_ip = vp->ip;
 675     }
 676   else
 677     {
 678       vp->last_frame = SCM_BOOL_F;
 679     }
 680
 681
 682   return vp->last_frame;
 683 }
 684 #undef FUNC_NAME
 685
 686 SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
 687             (SCM vm),
 688             "")
 689 #define FUNC_NAME s_scm_vm_fetch_code
 690 {
 691   int i;
 692   SCM list;
 693   scm_byte_t *ip;
 694   struct scm_instruction *p;
 695
 696   SCM_VALIDATE_VM (1, vm);
 697   VM_CHECK_RUNNING (vm);
 698
 699   ip = SCM_VM_DATA (vm)->ip;
 700   p = SCM_INSTRUCTION (*ip);
 701
 702   list = SCM_LIST1 (scm_str2symbol (p->name));
 703   for (i = 1; i <= p->len; i++)
 704     list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
 705   return scm_reverse_x (list, SCM_EOL);
 706 }
 707 #undef FUNC_NAME
 708
 709 SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 710             (SCM vm),
 711             "")
 712 #define FUNC_NAME s_scm_vm_fetch_stack
 713 {
 714   SCM *sp;
 715   SCM ls = SCM_EOL;
 716   struct scm_vm *vp;
 717
 718   SCM_VALIDATE_VM (1, vm);
 719   VM_CHECK_RUNNING (vm);
 720
 721   vp = SCM_VM_DATA (vm);
 722   for (sp = vp->stack_base; sp <= vp->sp; sp++)
 723     ls = scm_cons (*sp, ls);
 724   return ls;
 725 }
 726 #undef FUNC_NAME
 727
 728 \f
 729 /*
 730  * Initialize
 731  */
 732
 733 SCM scm_load_compiled_with_vm (SCM file)
 734 {
 735   SCM program = scm_objcode_to_program (scm_load_objcode (file));
 736
 737   return vm_run (scm_the_vm (), program, SCM_EOL);
 738 }
 739
 740 void
 741 scm_bootstrap_vm (void)
 742 {
 743   static int strappage = 0;
 744
 745   if (strappage)
 746     return;
 747
 748   scm_bootstrap_frames ();
 749   scm_bootstrap_instructions ();
 750   scm_bootstrap_objcodes ();
 751   scm_bootstrap_programs ();
 752
 753   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
 754   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
 755   scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
 756
 757   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 758   scm_set_smob_mark (scm_tc16_vm, vm_mark);
 759   scm_set_smob_free (scm_tc16_vm, vm_free);
 760   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 761
 762   scm_the_vm_fluid = scm_permanent_object (scm_make_fluid ());
 763   scm_fluid_set_x (scm_the_vm_fluid, make_vm ());
 764   scm_c_define ("*the-vm*", scm_the_vm_fluid);
 765
 766   scm_c_define ("load-compiled",
 767                 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
 768                                   scm_load_compiled_with_vm));
 769
 770   sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
 771   sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
 772   sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
 773
 774   strappage = 1;
 775 }
 776
 777 void
 778 scm_init_vm (void)
 779 {
 780   scm_bootstrap_vm ();
 781
 782 #ifndef SCM_MAGIC_SNARFER
 783 #include "vm.x"
 784 #endif
 785 }
 786
 787 /*
 788   Local Variables:
 789   c-file-style: "gnu"
 790   End:
 791 */