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