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   SCM ret;
 384
 385   if (SCM_NFALSEP ((ret = scm_fluid_ref (scm_the_vm_fluid))))
 386     return ret;
 387
 388   ret = make_vm ();
 389   scm_fluid_set_x (scm_the_vm_fluid, ret);
 390   return ret;
 391 }
 392 #undef FUNC_NAME
 393
 394
 395 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 396             (SCM obj),
 397             "")
 398 #define FUNC_NAME s_scm_vm_p
 399 {
 400   return SCM_BOOL (SCM_VM_P (obj));
 401 }
 402 #undef FUNC_NAME
 403
 404 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 405             (void),
 406             "")
 407 #define FUNC_NAME s_scm_make_vm,
 408 {
 409   return make_vm ();
 410 }
 411 #undef FUNC_NAME
 412
 413 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 414             (SCM vm),
 415             "")
 416 #define FUNC_NAME s_scm_vm_ip
 417 {
 418   SCM_VALIDATE_VM (1, vm);
 419   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
 420 }
 421 #undef FUNC_NAME
 422
 423 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 424             (SCM vm),
 425             "")
 426 #define FUNC_NAME s_scm_vm_sp
 427 {
 428   SCM_VALIDATE_VM (1, vm);
 429   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
 430 }
 431 #undef FUNC_NAME
 432
 433 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 434             (SCM vm),
 435             "")
 436 #define FUNC_NAME s_scm_vm_fp
 437 {
 438   SCM_VALIDATE_VM (1, vm);
 439   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
 440 }
 441 #undef FUNC_NAME
 442
 443 #define VM_DEFINE_HOOK(n)                               \
 444 {                                                       \
 445   struct scm_vm *vp;                                    \
 446   SCM_VALIDATE_VM (1, vm);                              \
 447   vp = SCM_VM_DATA (vm);                                \
 448   if (SCM_FALSEP (vp->hooks[n]))                        \
 449     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 450   return vp->hooks[n];                                  \
 451 }
 452
 453 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 454             (SCM vm),
 455             "")
 456 #define FUNC_NAME s_scm_vm_boot_hook
 457 {
 458   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 459 }
 460 #undef FUNC_NAME
 461
 462 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 463             (SCM vm),
 464             "")
 465 #define FUNC_NAME s_scm_vm_halt_hook
 466 {
 467   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 468 }
 469 #undef FUNC_NAME
 470
 471 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 472             (SCM vm),
 473             "")
 474 #define FUNC_NAME s_scm_vm_next_hook
 475 {
 476   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 477 }
 478 #undef FUNC_NAME
 479
 480 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 481             (SCM vm),
 482             "")
 483 #define FUNC_NAME s_scm_vm_break_hook
 484 {
 485   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 486 }
 487 #undef FUNC_NAME
 488
 489 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 490             (SCM vm),
 491             "")
 492 #define FUNC_NAME s_scm_vm_enter_hook
 493 {
 494   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 495 }
 496 #undef FUNC_NAME
 497
 498 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 499             (SCM vm),
 500             "")
 501 #define FUNC_NAME s_scm_vm_apply_hook
 502 {
 503   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 504 }
 505 #undef FUNC_NAME
 506
 507 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 508             (SCM vm),
 509             "")
 510 #define FUNC_NAME s_scm_vm_exit_hook
 511 {
 512   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 513 }
 514 #undef FUNC_NAME
 515
 516 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 517             (SCM vm),
 518             "")
 519 #define FUNC_NAME s_scm_vm_return_hook
 520 {
 521   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 522 }
 523 #undef FUNC_NAME
 524
 525 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 526             (SCM vm, SCM key),
 527             "")
 528 #define FUNC_NAME s_scm_vm_option
 529 {
 530   SCM_VALIDATE_VM (1, vm);
 531   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 532 }
 533 #undef FUNC_NAME
 534
 535 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 536             (SCM vm, SCM key, SCM val),
 537             "")
 538 #define FUNC_NAME s_scm_set_vm_option_x
 539 {
 540   SCM_VALIDATE_VM (1, vm);
 541   SCM_VM_DATA (vm)->options
 542     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 543   return SCM_UNSPECIFIED;
 544 }
 545 #undef FUNC_NAME
 546
 547 SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 548             (SCM vm),
 549             "")
 550 #define FUNC_NAME s_scm_vm_stats
 551 {
 552   SCM stats;
 553
 554   SCM_VALIDATE_VM (1, vm);
 555
 556   stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
 557   scm_vector_set_x (stats, SCM_I_MAKINUM (0),
 558                     scm_from_ulong (SCM_VM_DATA (vm)->time));
 559   scm_vector_set_x (stats, SCM_I_MAKINUM (1),
 560                     scm_from_ulong (SCM_VM_DATA (vm)->clock));
 561
 562   return stats;
 563 }
 564 #undef FUNC_NAME
 565
 566 #define VM_CHECK_RUNNING(vm)                            \
 567   if (!SCM_VM_DATA (vm)->ip)                            \
 568     SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
 569
 570 SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
 571             (SCM vm),
 572             "")
 573 #define FUNC_NAME s_scm_vm_this_frame
 574 {
 575   SCM_VALIDATE_VM (1, vm);
 576   return SCM_VM_DATA (vm)->this_frame;
 577 }
 578 #undef FUNC_NAME
 579
 580 SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
 581             (SCM vm),
 582             "")
 583 #define FUNC_NAME s_scm_vm_last_frame
 584 {
 585   SCM_VALIDATE_VM (1, vm);
 586   return SCM_VM_DATA (vm)->last_frame;
 587 }
 588 #undef FUNC_NAME
 589
 590 SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
 591             (SCM vm),
 592             "")
 593 #define FUNC_NAME s_scm_vm_last_ip
 594 {
 595   SCM_VALIDATE_VM (1, vm);
 596   return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
 597 }
 598 #undef FUNC_NAME
 599
 600 SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
 601             (SCM vm),
 602             "")
 603 #define FUNC_NAME s_scm_vm_save_stack
 604 {
 605   struct scm_vm *vp;
 606   SCM *dest;
 607   SCM_VALIDATE_VM (1, vm);
 608   vp = SCM_VM_DATA (vm);
 609
 610   if (vp->fp)
 611     {
 612       vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
 613       vp->last_ip = vp->ip;
 614     }
 615   else
 616     {
 617       vp->last_frame = SCM_BOOL_F;
 618     }
 619
 620
 621   return vp->last_frame;
 622 }
 623 #undef FUNC_NAME
 624
 625 SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
 626             (SCM vm),
 627             "")
 628 #define FUNC_NAME s_scm_vm_fetch_code
 629 {
 630   int i;
 631   SCM list;
 632   scm_byte_t *ip;
 633   struct scm_instruction *p;
 634
 635   SCM_VALIDATE_VM (1, vm);
 636   VM_CHECK_RUNNING (vm);
 637
 638   ip = SCM_VM_DATA (vm)->ip;
 639   p = SCM_INSTRUCTION (*ip);
 640
 641   list = SCM_LIST1 (scm_str2symbol (p->name));
 642   for (i = 1; i <= p->len; i++)
 643     list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
 644   return scm_reverse_x (list, SCM_EOL);
 645 }
 646 #undef FUNC_NAME
 647
 648 SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 649             (SCM vm),
 650             "")
 651 #define FUNC_NAME s_scm_vm_fetch_stack
 652 {
 653   SCM *sp;
 654   SCM ls = SCM_EOL;
 655   struct scm_vm *vp;
 656
 657   SCM_VALIDATE_VM (1, vm);
 658   VM_CHECK_RUNNING (vm);
 659
 660   vp = SCM_VM_DATA (vm);
 661   for (sp = vp->stack_base; sp <= vp->sp; sp++)
 662     ls = scm_cons (*sp, ls);
 663   return ls;
 664 }
 665 #undef FUNC_NAME
 666
 667 \f
 668 /*
 669  * Initialize
 670  */
 671
 672 SCM scm_load_compiled_with_vm (SCM file)
 673 {
 674   SCM program = scm_objcode_to_program (scm_load_objcode (file));
 675
 676   return vm_run (scm_the_vm (), program, SCM_EOL);
 677 }
 678
 679 void
 680 scm_bootstrap_vm (void)
 681 {
 682   static int strappage = 0;
 683
 684   if (strappage)
 685     return;
 686
 687   scm_bootstrap_frames ();
 688   scm_bootstrap_instructions ();
 689   scm_bootstrap_objcodes ();
 690   scm_bootstrap_programs ();
 691
 692   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
 693   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
 694   scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
 695
 696   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 697   scm_set_smob_mark (scm_tc16_vm, vm_mark);
 698   scm_set_smob_free (scm_tc16_vm, vm_free);
 699   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 700
 701   scm_the_vm_fluid = scm_permanent_object (scm_make_fluid ());
 702   scm_fluid_set_x (scm_the_vm_fluid, make_vm ());
 703   scm_c_define ("*the-vm*", scm_the_vm_fluid);
 704
 705   scm_c_define ("load-compiled",
 706                 scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
 707                                   scm_load_compiled_with_vm));
 708
 709   sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
 710   sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
 711   sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
 712
 713   strappage = 1;
 714 }
 715
 716 void
 717 scm_init_vm (void)
 718 {
 719   scm_bootstrap_vm ();
 720
 721 #ifndef SCM_MAGIC_SNARFER
 722 #include "vm.x"
 723 #endif
 724 }
 725
 726 /*
 727   Local Variables:
 728   c-file-style: "gnu"
 729   End:
 730 */