*** empty log message ***

module/system/repl/common.scm

@@ -37,7 +37,7 @@
   vm language module value-count value-history tm-stats vm-stats gc-stats)
 
 (define (make-repl lang)
-  (let ((vm (make-vm)))
+  (let ((vm (the-vm)))
     (make <repl>
 	  :vm vm
 	  :language (lookup-language lang)

module/system/vm/core.scm

@@ -25,9 +25,8 @@
 
 (export vms:cons vms:time vms:clock)
 
-(define (vms:cons stat) (vector-ref stat 0))
+(define (vms:time stat) (vector-ref stat 0))
-(define (vms:time stat) (vector-ref stat 1))
+(define (vms:clock stat) (vector-ref stat 1))
-(define (vms:clock stat) (vector-ref stat 2))
 
 (module-export! (current-module)
 		(delq! '%module-public-interface

module/system/vm/frame.scm

@@ -24,8 +24,16 @@
   :export (frame->call))
 
 (define (frame->call frame)
-  (let ((prog (frame-program frame)))
+  (let* ((prog (frame-program frame))
-    (cons prog (reverse! (vector->list (frame-variables frame))))))
+	 (nargs (car (program-arity prog))))
+    (do ((i 0 (1+ i))
+	 (l (reverse! (vector->list (frame-variables frame))) (cdr l))
+	 (r '() (cons (car l) r)))
+	((= i nargs) (cons (program-name prog) r)))))
+
+(define (program-name x)
+  (hash-fold (lambda (s v d) (if (eq? x (variable-ref v)) s d)) x
+	     (module-obarray (current-module))))
 
 ; (define-method (binding (prog <program>))
 ;   (fold (lambda (s v d) (if (eq? v prog) s d))

module/system/vm/load.scm

@@ -25,8 +25,6 @@
   :use-module (ice-9 regex)
   :export (load/compile))
 
-(define *the-vm* (make-vm))
-
 (define (load/compile file)
   (let* ((file (file-name-full-name file))
 	 (compiled (object-file-name file)))
@@ -36,7 +34,7 @@
     (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
       (call-with-input-file compiled
 	(lambda (p) (uniform-vector-read! bytes p)))
-      (vm-load *the-vm* bytes))))
+      (vm-load (the-vm) bytes))))
 
 (define (file-name-full-name filename)
   (let ((oldname (and (current-load-port)

module/system/vm/trace.scm

@@ -44,11 +44,8 @@
 
 (define (trace-next vm)
   (let ((frame (vm-current-frame vm)))
-    (format #t "0x~8X  ~20S~S\t~S\n"
+    (format #t "0x~8X  ~20S~S\n"
-	    (vm:ip vm)
+	    (vm:ip vm) (vm-fetch-code vm) (vm-fetch-stack vm))))
-	    (vm-fetch-code vm)
-	    (frame-variables frame)
-	    (vm-fetch-stack vm))))
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)

src/programs.c

@@ -117,17 +117,27 @@ program_free (SCM obj)
 
 static int
 program_print (SCM obj, SCM port, scm_print_state *pstate)
+{
+  SCM name = scm_object_property (obj, scm_sym_name);
+  if (SCM_FALSEP (name))
     {
       scm_puts ("#<program 0x", port);
       scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
       scm_putc ('>', port);
+    }
+  else
+    {
+      scm_puts ("#<program ", port);
+      scm_display (name, port);
+      scm_putc ('>', port);
+    }
   return 1;
 }
 
 static SCM
 program_apply (SCM program, SCM args)
 {
-  return scm_vm_apply (scm_make_vm (), program, args);
+  return scm_vm_apply (scm_the_vm (), program, args);
 }
 
 
@@ -150,9 +160,10 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
 #define FUNC_NAME s_scm_program_arity
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return SCM_LIST3 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)),
+  return SCM_LIST4 (SCM_MAKINUM (SCM_PROGRAM_NARGS (program)),
 		    SCM_MAKINUM (SCM_PROGRAM_NREST (program)),
-		    SCM_MAKINUM (SCM_PROGRAM_NLOCS (program)));
+		    SCM_MAKINUM (SCM_PROGRAM_NLOCS (program)),
+		    SCM_MAKINUM (SCM_PROGRAM_NEXTS (program)));
 }
 #undef FUNC_NAME
 

src/vm.c

@@ -228,8 +228,7 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
  * VM
  */
 
-#define VM_DEFAULT_STACK_SIZE	(16 * 1024)
+#define VM_DEFAULT_STACK_SIZE	(4 * 1024)
-#define VM_MAXIMUM_STACK_SIZE	(128 * 1024)
 
 #define VM_REGULAR_ENGINE	0
 #define VM_DEBUG_ENGINE		1
@@ -250,6 +249,8 @@ vm_fetch_length (scm_byte_t *ip, size_t *lenp)
 
 scm_bits_t scm_tc16_vm;
 
+static SCM the_vm;
+
 static SCM
 make_vm (void)
 #define FUNC_NAME "make_vm"
@@ -258,11 +259,10 @@ make_vm (void)
   struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
   vp->stack_size  = VM_DEFAULT_STACK_SIZE;
   vp->stack_base  = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM));
-  vp->stack_limit = vp->stack_base + vp->stack_size - 1;
+  vp->stack_limit = vp->stack_base + vp->stack_size;
   vp->ip    	   = NULL;
   vp->sp    	   = vp->stack_limit;
   vp->fp    	   = NULL;
-  vp->cons        = 0;
   vp->time        = 0;
   vp->clock       = 0;
   vp->options     = SCM_EOL;
@@ -337,6 +337,16 @@ SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
+	    (),
+	    "")
+#define FUNC_NAME s_scm_the_vm
+{
+  return the_vm;
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
 	    (SCM obj),
 	    "")
@@ -489,10 +499,9 @@ SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
 
   SCM_VALIDATE_VM (1, vm);
 
-  stats = scm_c_make_vector (3, SCM_MAKINUM (0));
+  stats = scm_c_make_vector (2, SCM_MAKINUM (0));
-  SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->cons);
+  SCM_VELTS (stats)[0] = scm_long2num (SCM_VM_DATA (vm)->time);
-  SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->time);
+  SCM_VELTS (stats)[1] = scm_long2num (SCM_VM_DATA (vm)->clock);
-  SCM_VELTS (stats)[2] = scm_long2num (SCM_VM_DATA (vm)->clock);
 
   return stats;
 }
@@ -596,6 +605,8 @@ scm_init_vm (void)
   scm_set_smob_free (scm_tc16_vm, vm_free);
   scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
 
+  the_vm = scm_permanent_object (make_vm ());
+
 #ifndef SCM_MAGIC_SNARFER
 #include "vm.x"
 #endif

src/vm.h

@@ -129,7 +129,6 @@ struct scm_vm {
   SCM *stack_limit;		/* stack limit address */
   SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
   SCM options;			/* options */
-  unsigned long cons;		/* cons count */
   unsigned long time;		/* time spent */
   unsigned long clock;		/* bogos clock */
 };
@@ -138,6 +137,7 @@ struct scm_vm {
 #define SCM_VM_DATA(vm)		((struct scm_vm *) SCM_SMOB_DATA (vm))
 #define SCM_VALIDATE_VM(pos,x)	SCM_MAKE_VALIDATE (pos, x, VM_P)
 
+extern SCM scm_the_vm ();
 extern SCM scm_make_vm (void);
 extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
 extern SCM scm_vm_option_ref (SCM vm, SCM key);

src/vm_engine.c

@@ -85,20 +85,22 @@ vm_engine (SCM vm, SCM program, SCM args)
 
   /* Initialization */
   {
-    /* Bootcode */
+    SCM prog = program;
+
+    /* Boot program */
     scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
-    SCM bootcode = scm_c_make_program (bytes, 3, SCM_BOOL_T);
     bytes[1] = scm_ilength (args);
+    program = scm_c_make_program (bytes, 3, SCM_BOOL_T);
 
     /* Initial frame */
     CACHE_REGISTER ();
-    CACHE_PROGRAM (bootcode);
+    CACHE_PROGRAM ();
     NEW_FRAME ();
 
     /* Initial arguments */
     for (; !SCM_NULLP (args); args = SCM_CDR (args))
       PUSH (SCM_CAR (args));
-    PUSH (program);
+    PUSH (prog);
   }
 
   /* Let's go! */

src/vm_engine.h

@@ -129,7 +129,7 @@
   vp->fp = fp;					\
 }
 
-#define CACHE_PROGRAM(program)			\
+#define CACHE_PROGRAM()				\
 {						\
   bp = SCM_PROGRAM_DATA (program);		\
   objects  = SCM_VELTS (bp->objs);		\
@@ -183,7 +183,7 @@
     goto vm_error_stack_overflow
 
 #define CHECK_UNDERFLOW()			\
-  if (sp > stack_limit)				\
+  if (sp >= stack_limit)			\
     goto vm_error_stack_underflow
 
 #define PUSH(x)	do { CHECK_OVERFLOW (); *--sp = x; } while (0)

src/vm_system.c

@@ -62,7 +62,7 @@ VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
   return ret;
 }
 
-VM_DEFINE_INSTRUCTION (drop, "drop", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
 {
   DROP ();
   NEXT;
@@ -216,6 +216,7 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
 VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 {
   VARIABLE_SET (sp[0], sp[1]);
+  scm_set_object_property_x (sp[1], scm_sym_name, SCM_CAR (sp[0]));
   sp += 2;
   NEXT;
 }
@@ -295,7 +296,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
     {
       int i;
     vm_call_program:
-      CACHE_PROGRAM (program);
+      CACHE_PROGRAM ();
       INIT_ARGS ();
       NEW_FRAME ();
 
@@ -317,6 +318,7 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
   if (!SCM_FALSEP (scm_procedure_p (program)))
     {
       POP_LIST (nargs);
+      SYNC_BEFORE_GC ();
       *sp = scm_apply (program, *sp, SCM_EOL);
       program = SCM_VM_FRAME_PROGRAM (fp);
       NEXT;
@@ -399,6 +401,7 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
   if (!SCM_FALSEP (scm_procedure_p (program)))
     {
       POP_LIST (nargs);
+      SYNC_BEFORE_GC ();
       *sp = scm_apply (program, *sp, SCM_EOL);
       program = SCM_VM_FRAME_PROGRAM (fp);
       goto vm_return;
@@ -432,7 +435,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
 
   /* Cache the last program */
   program = SCM_VM_FRAME_PROGRAM (fp);
-  CACHE_PROGRAM (program);
+  CACHE_PROGRAM ();
   PUSH (ret);
   NEXT;
 }