src/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 #include <string.h>
  43 #include "envs.h"
  44 #include "frames.h"
  45 #include "instructions.h"
  46 #include "objcodes.h"
  47 #include "programs.h"
  48 #include "vm.h"
  49
  50 /* I sometimes use this for debugging. */
  51 #define vm_puts(OBJ)                            \
  52 {                                               \
  53   scm_display (OBJ, scm_def_errp);              \
  54   scm_newline (scm_def_errp);                   \
  55 }
  56
  57 \f
  58 /*
  59  * VM Continuation
  60  */
  61
  62 scm_t_bits scm_tc16_vm_cont;
  63
  64
  65 #define SCM_VM_CONT_P(OBJ)      SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
  66 #define SCM_VM_CONT_VP(CONT)    ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
  67
  68 static SCM
  69 capture_vm_cont (struct scm_vm *vp)
  70 {
  71   struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
  72   p->stack_size = vp->stack_limit - vp->sp;
  73   p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
  74                                  "capture_vm_cont");
  75   p->stack_limit = p->stack_base + p->stack_size - 2;
  76   p->ip = vp->ip;
  77   p->sp = (SCM *) (vp->stack_limit - vp->sp);
  78   p->fp = (SCM *) (vp->stack_limit - vp->fp);
  79   memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
  80   SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
  81 }
  82
  83 static void
  84 reinstate_vm_cont (struct scm_vm *vp, SCM cont)
  85 {
  86   struct scm_vm *p = SCM_VM_CONT_VP (cont);
  87   if (vp->stack_size < p->stack_size)
  88     {
  89       /* puts ("FIXME: Need to expand"); */
  90       abort ();
  91     }
  92   vp->ip = p->ip;
  93   vp->sp = vp->stack_limit - (int) p->sp;
  94   vp->fp = vp->stack_limit - (int) p->fp;
  95   memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
  96 }
  97
  98 static SCM
  99 vm_cont_mark (SCM obj)
 100 {
 101   SCM *p;
 102   struct scm_vm *vp = SCM_VM_CONT_VP (obj);
 103   for (p = vp->stack_base; p <= vp->stack_limit; p++)
 104     if (SCM_NIMP (*p))
 105       scm_gc_mark (*p);
 106   return SCM_BOOL_F;
 107 }
 108
 109 static scm_sizet
 110 vm_cont_free (SCM obj)
 111 {
 112   struct scm_vm *p = SCM_VM_CONT_VP (obj);
 113
 114   scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
 115   scm_gc_free (p, sizeof (struct scm_vm), "vm");
 116
 117   return 0;
 118 }
 119
 120 \f
 121 /*
 122  * VM Internal functions
 123  */
 124
 125 SCM_SYMBOL (sym_vm_run, "vm-run");
 126 SCM_SYMBOL (sym_vm_error, "vm-error");
 127
 128 static scm_byte_t *
 129 vm_fetch_length (scm_byte_t *ip, size_t *lenp)
 130 {
 131   /* NOTE: format defined in system/vm/conv.scm */
 132   *lenp = *ip++;
 133   if (*lenp < 254)
 134     return ip;
 135   else if (*lenp == 254)
 136     {
 137       int b1 = *ip++;
 138       int b2 = *ip++;
 139       *lenp = (b1 << 8) + b2;
 140     }
 141   else
 142     {
 143       int b1 = *ip++;
 144       int b2 = *ip++;
 145       int b3 = *ip++;
 146       int b4 = *ip++;
 147       *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
 148     }
 149   return ip;
 150 }
 151
 152 static SCM
 153 vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
 154 {
 155   SCM frame;
 156   SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
 157   SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
 158   SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
 159
 160   if (!dl)
 161     {
 162       /* The top frame */
 163       frame = scm_c_make_heap_frame (fp);
 164       fp = SCM_HEAP_FRAME_POINTER (frame);
 165       SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
 166     }
 167   else
 168     {
 169       /* Child frames */
 170       SCM link = SCM_FRAME_HEAP_LINK (dl);
 171       if (!SCM_FALSEP (link))
 172         link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
 173       else
 174         link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
 175       frame = scm_c_make_heap_frame (fp);
 176       fp = SCM_HEAP_FRAME_POINTER (frame);
 177       SCM_FRAME_HEAP_LINK (fp)    = link;
 178       SCM_FRAME_DYNAMIC_LINK (fp) = SCM_HEAP_FRAME_POINTER (link);
 179     }
 180
 181   /* Move stack data */
 182   for (; src <= sp; src++, dest++)
 183     *dest = *src;
 184   *destp = dest;
 185
 186   return frame;
 187 }
 188
 189 static SCM
 190 vm_heapify_frames (SCM vm)
 191 {
 192   struct scm_vm *vp = SCM_VM_DATA (vm);
 193   if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
 194     {
 195       SCM *dest;
 196       vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
 197       vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
 198       vp->sp = dest - 1;
 199     }
 200   return vp->this_frame;
 201 }
 202
 203 \f
 204 /*
 205  * VM
 206  */
 207
 208 #define VM_DEFAULT_STACK_SIZE   (16 * 1024)
 209
 210 #define VM_REGULAR_ENGINE       0
 211 #define VM_DEBUG_ENGINE         1
 212
 213 #if 0
 214 #define VM_NAME   vm_regular_engine
 215 #define VM_ENGINE VM_REGULAR_ENGINE
 216 #include "vm_engine.c"
 217 #undef VM_NAME
 218 #undef VM_ENGINE
 219 #endif
 220
 221 #define VM_NAME   vm_debug_engine
 222 #define VM_ENGINE VM_DEBUG_ENGINE
 223 #include "vm_engine.c"
 224 #undef VM_NAME
 225 #undef VM_ENGINE
 226
 227 scm_t_bits scm_tc16_vm;
 228
 229 static SCM the_vm;
 230
 231 static SCM
 232 make_vm (void)
 233 #define FUNC_NAME "make_vm"
 234 {
 235   int i;
 236   struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 237
 238   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
 239   vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
 240                                    "stack-base");
 241   vp->stack_limit = vp->stack_base + vp->stack_size - 3;
 242   vp->ip          = NULL;
 243   vp->sp          = vp->stack_base - 1;
 244   vp->fp          = NULL;
 245   vp->time        = 0;
 246   vp->clock       = 0;
 247   vp->options     = SCM_EOL;
 248   vp->this_frame  = SCM_BOOL_F;
 249   vp->last_frame  = SCM_BOOL_F;
 250   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 251     vp->hooks[i] = SCM_BOOL_F;
 252   SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 253 }
 254 #undef FUNC_NAME
 255
 256 static SCM
 257 vm_mark (SCM obj)
 258 {
 259   int i;
 260   struct scm_vm *vp = SCM_VM_DATA (obj);
 261
 262   /* mark the stack conservatively */
 263   scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
 264                       sizeof (SCM) * (vp->sp - vp->stack_base + 1));
 265
 266   /* mark other objects  */
 267   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
 268     scm_gc_mark (vp->hooks[i]);
 269   scm_gc_mark (vp->this_frame);
 270   scm_gc_mark (vp->last_frame);
 271   return vp->options;
 272 }
 273
 274 static scm_sizet
 275 vm_free (SCM obj)
 276 {
 277   struct scm_vm *vp = SCM_VM_DATA (obj);
 278
 279   scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
 280                "stack-base");
 281   scm_gc_free (vp, sizeof (struct scm_vm), "vm");
 282
 283   return 0;
 284 }
 285
 286 SCM_SYMBOL (sym_debug, "debug");
 287
 288 SCM
 289 scm_vm_apply (SCM vm, SCM program, SCM args)
 290 #define FUNC_NAME "scm_vm_apply"
 291 {
 292   SCM_VALIDATE_PROGRAM (1, program);
 293   return vm_run (vm, program, args);
 294 }
 295 #undef FUNC_NAME
 296
 297 /* Scheme interface */
 298
 299 SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 300             (void),
 301             "")
 302 #define FUNC_NAME s_scm_vm_version
 303 {
 304   return scm_from_locale_string (VERSION);
 305 }
 306 #undef FUNC_NAME
 307
 308 SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
 309             (),
 310             "")
 311 #define FUNC_NAME s_scm_the_vm
 312 {
 313   return the_vm;
 314 }
 315 #undef FUNC_NAME
 316
 317
 318 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 319             (SCM obj),
 320             "")
 321 #define FUNC_NAME s_scm_vm_p
 322 {
 323   return SCM_BOOL (SCM_VM_P (obj));
 324 }
 325 #undef FUNC_NAME
 326
 327 SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
 328             (void),
 329             "")
 330 #define FUNC_NAME s_scm_make_vm,
 331 {
 332   return make_vm ();
 333 }
 334 #undef FUNC_NAME
 335
 336 SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
 337             (SCM vm),
 338             "")
 339 #define FUNC_NAME s_scm_vm_ip
 340 {
 341   SCM_VALIDATE_VM (1, vm);
 342   return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->ip);
 343 }
 344 #undef FUNC_NAME
 345
 346 SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
 347             (SCM vm),
 348             "")
 349 #define FUNC_NAME s_scm_vm_sp
 350 {
 351   SCM_VALIDATE_VM (1, vm);
 352   return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->sp);
 353 }
 354 #undef FUNC_NAME
 355
 356 SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 357             (SCM vm),
 358             "")
 359 #define FUNC_NAME s_scm_vm_fp
 360 {
 361   SCM_VALIDATE_VM (1, vm);
 362   return scm_ulong2num ((unsigned long) SCM_VM_DATA (vm)->fp);
 363 }
 364 #undef FUNC_NAME
 365
 366 #define VM_DEFINE_HOOK(n)                               \
 367 {                                                       \
 368   struct scm_vm *vp;                                    \
 369   SCM_VALIDATE_VM (1, vm);                              \
 370   vp = SCM_VM_DATA (vm);                                \
 371   if (SCM_FALSEP (vp->hooks[n]))                        \
 372     vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));   \
 373   return vp->hooks[n];                                  \
 374 }
 375
 376 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
 377             (SCM vm),
 378             "")
 379 #define FUNC_NAME s_scm_vm_boot_hook
 380 {
 381   VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
 382 }
 383 #undef FUNC_NAME
 384
 385 SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
 386             (SCM vm),
 387             "")
 388 #define FUNC_NAME s_scm_vm_halt_hook
 389 {
 390   VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
 391 }
 392 #undef FUNC_NAME
 393
 394 SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
 395             (SCM vm),
 396             "")
 397 #define FUNC_NAME s_scm_vm_next_hook
 398 {
 399   VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
 400 }
 401 #undef FUNC_NAME
 402
 403 SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
 404             (SCM vm),
 405             "")
 406 #define FUNC_NAME s_scm_vm_break_hook
 407 {
 408   VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
 409 }
 410 #undef FUNC_NAME
 411
 412 SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
 413             (SCM vm),
 414             "")
 415 #define FUNC_NAME s_scm_vm_enter_hook
 416 {
 417   VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
 418 }
 419 #undef FUNC_NAME
 420
 421 SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
 422             (SCM vm),
 423             "")
 424 #define FUNC_NAME s_scm_vm_apply_hook
 425 {
 426   VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
 427 }
 428 #undef FUNC_NAME
 429
 430 SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
 431             (SCM vm),
 432             "")
 433 #define FUNC_NAME s_scm_vm_exit_hook
 434 {
 435   VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
 436 }
 437 #undef FUNC_NAME
 438
 439 SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
 440             (SCM vm),
 441             "")
 442 #define FUNC_NAME s_scm_vm_return_hook
 443 {
 444   VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
 445 }
 446 #undef FUNC_NAME
 447
 448 SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
 449             (SCM vm, SCM key),
 450             "")
 451 #define FUNC_NAME s_scm_vm_option
 452 {
 453   SCM_VALIDATE_VM (1, vm);
 454   return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
 455 }
 456 #undef FUNC_NAME
 457
 458 SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
 459             (SCM vm, SCM key, SCM val),
 460             "")
 461 #define FUNC_NAME s_scm_set_vm_option_x
 462 {
 463   SCM_VALIDATE_VM (1, vm);
 464   SCM_VM_DATA (vm)->options
 465     = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
 466   return SCM_UNSPECIFIED;
 467 }
 468 #undef FUNC_NAME
 469
 470 SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 471             (SCM vm),
 472             "")
 473 #define FUNC_NAME s_scm_vm_stats
 474 {
 475   SCM stats;
 476
 477   SCM_VALIDATE_VM (1, vm);
 478
 479   stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
 480   scm_vector_set_x (stats, SCM_I_MAKINUM (0),
 481                     scm_from_ulong (SCM_VM_DATA (vm)->time));
 482   scm_vector_set_x (stats, SCM_I_MAKINUM (1),
 483                     scm_from_ulong (SCM_VM_DATA (vm)->clock));
 484
 485   return stats;
 486 }
 487 #undef FUNC_NAME
 488
 489 #define VM_CHECK_RUNNING(vm)                            \
 490   if (!SCM_VM_DATA (vm)->ip)                            \
 491     SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
 492
 493 SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
 494             (SCM vm),
 495             "")
 496 #define FUNC_NAME s_scm_vm_this_frame
 497 {
 498   SCM_VALIDATE_VM (1, vm);
 499   return SCM_VM_DATA (vm)->this_frame;
 500 }
 501 #undef FUNC_NAME
 502
 503 SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
 504             (SCM vm),
 505             "")
 506 #define FUNC_NAME s_scm_vm_last_frame
 507 {
 508   SCM_VALIDATE_VM (1, vm);
 509   return SCM_VM_DATA (vm)->last_frame;
 510 }
 511 #undef FUNC_NAME
 512
 513 SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
 514             (SCM vm),
 515             "")
 516 #define FUNC_NAME s_scm_vm_fetch_code
 517 {
 518   int i;
 519   SCM list;
 520   scm_byte_t *ip;
 521   struct scm_instruction *p;
 522
 523   SCM_VALIDATE_VM (1, vm);
 524   VM_CHECK_RUNNING (vm);
 525
 526   ip = SCM_VM_DATA (vm)->ip;
 527   p = SCM_INSTRUCTION (*ip);
 528
 529   list = SCM_LIST1 (scm_str2symbol (p->name));
 530   for (i = 1; i <= p->len; i++)
 531     list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
 532   return scm_reverse_x (list, SCM_EOL);
 533 }
 534 #undef FUNC_NAME
 535
 536 SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 537             (SCM vm),
 538             "")
 539 #define FUNC_NAME s_scm_vm_fetch_stack
 540 {
 541   SCM *sp;
 542   SCM ls = SCM_EOL;
 543   struct scm_vm *vp;
 544
 545   SCM_VALIDATE_VM (1, vm);
 546   VM_CHECK_RUNNING (vm);
 547
 548   vp = SCM_VM_DATA (vm);
 549   for (sp = vp->stack_base; sp <= vp->sp; sp++)
 550     ls = scm_cons (*sp, ls);
 551   return ls;
 552 }
 553 #undef FUNC_NAME
 554
 555 \f
 556 /*
 557  * Initialize
 558  */
 559
 560 void
 561 scm_init_vm (void)
 562 {
 563   scm_init_frames ();
 564   scm_init_instructions ();
 565   scm_init_objcodes ();
 566   scm_init_programs ();
 567
 568   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
 569   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
 570   scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
 571
 572   scm_tc16_vm = scm_make_smob_type ("vm", 0);
 573   scm_set_smob_mark (scm_tc16_vm, vm_mark);
 574   scm_set_smob_free (scm_tc16_vm, vm_free);
 575   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 576
 577   the_vm = scm_permanent_object (make_vm ());
 578
 579 #ifndef SCM_MAGIC_SNARFER
 580 #include "vm.x"
 581 #endif
 582 }
 583
 584 /*
 585   Local Variables:
 586   c-file-style: "gnu"
 587   End:
 588 */