*** empty log message ***

module/system/repl/command.gs

@@ -281,20 +281,15 @@ Generate compiled code.
   -e    Stop after expanding syntax/macro
   -t    Stop after translating into GHIL
   -c    Stop after generating GLIL
-  -l    Stop before linking
-  -o    Compile into bytecode
 
   -O    Enable optimization
   -D    Add debug information"
   (let ((x (apply repl-compile repl form opts)))
     (cond ((null? opts)
-	   (puts x))
-	  ((memq :l opts)
 	   (disassemble-bytecode x))
 	  ((memq :c opts)
 	   (pprint-glil x))
-	  (else
+	  (else (puts x)))))
-	   (puts x)))))
 
 (define (compile-file repl file . opts)
   "compile-file [options] FILE

module/system/vm/assemble.scm

@@ -41,7 +41,7 @@
 (define-structure (venv parent nexts closure?))
 (define-structure (vmod id))
 (define-structure (vlink module name))
-(define-structure (bytespec nargs nrest nlocs bytes objs))
+(define-structure (bytespec nargs nrest nlocs nexts bytes objs))
 
 
 ;;;
@@ -146,11 +146,10 @@
 		(error "Unknown instruction:" inst)))))
        ;;
        ;; main
-       (if (> nexts 0) (push-code! `(external ,nexts)))
        (for-each generate-code body)
        (let ((bytes (apply string-append (stack-finalize (reverse! stack))))
 	     (objs (map car (reverse! object-alist))))
-	 (make-bytespec nargs nrest nlocs bytes objs))))))
+	 (make-bytespec nargs nrest nlocs nexts bytes objs))))))
 
 (define (stack-finalize stack)
   (let loop ((list '()) (stack stack) (addr 0))
@@ -208,15 +207,24 @@
       (let ((nargs (bytespec-nargs x))
 	    (nrest (bytespec-nrest x))
 	    (nlocs (bytespec-nlocs x))
+	    (nexts (bytespec-nexts x))
 	    (bytes (bytespec-bytes x))
 	    (objs  (bytespec-objs x)))
 	;; dump parameters
-	(if (and (< nargs 4) (< nlocs 16))
+	(cond ((and (< nargs 4) (< nlocs 8) (< nexts 4))
-	    (push-code! (object->code (+ (* nargs 32) (* nrest 16) nlocs)))
+	       ;; 8-bit representation
-	    (begin
+	       (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
+		 (push-code! `(make-int8 ,x))))
+	      ((and (< nargs 16) (< nlocs 128) (< nexts 16))
+	       ;; 16-bit representation
+	       (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
+		 (push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
+	      (else
+	       ;; Other cases
 	       (push-code! (object->code nargs))
 	       (push-code! (object->code nrest))
 	       (push-code! (object->code nlocs))
+	       (push-code! (object->code nexts))
 	       (push-code! (object->code #f))))
 	;; dump object table
 	(cond ((not (null? objs))

src/programs.c

@@ -58,13 +58,14 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
   p->nargs    = 0;
   p->nrest    = 0;
   p->nlocs    = 0;
+  p->nexts    = 0;
   p->meta     = SCM_EOL;
   p->objs     = zero_vector;
   p->external = SCM_EOL;
   p->holder   = holder;
 
   /* If nobody holds bytecode's address, then allocate a new memory */
-  if (SCM_FALSEP (p->holder))
+  if (SCM_FALSEP (holder))
     p->base = SCM_MUST_MALLOC (size);
   else
     p->base = addr;
@@ -74,7 +75,7 @@ scm_c_make_program (void *addr, size_t size, SCM holder)
 #undef FUNC_NAME
 
 SCM
-scm_c_make_vclosure (SCM program, SCM external)
+scm_c_make_closure (SCM program, SCM external)
 {
   struct scm_program *p;
   struct scm_program *q = SCM_PROGRAM_DATA (program);
@@ -83,6 +84,7 @@ scm_c_make_vclosure (SCM program, SCM external)
   p->nargs    = q->nargs;
   p->nrest    = q->nrest;
   p->nlocs    = q->nlocs;
+  p->nexts    = q->nexts;
   p->meta     = q->meta;
   p->objs     = q->objs;
   p->external = external;

src/programs.h

@@ -54,8 +54,9 @@ typedef unsigned char scm_byte_t;
 struct scm_program {
   size_t size;			/* the size of the program  */
   unsigned char nargs;		/* the number of arguments */
-  unsigned char nrest;		/* have a rest argument or not */
+  unsigned char nrest;		/* the number of rest argument (0 or 1) */
-  unsigned short nlocs;		/* the number of local variables */
+  unsigned char nlocs;		/* the number of local variables */
+  unsigned char nexts;		/* the number of external variables */
   scm_byte_t *base;		/* program base address */
   SCM meta;			/* meta information */
   SCM objs;			/* constant objects */
@@ -73,6 +74,7 @@ extern scm_bits_t scm_tc16_program;
 #define SCM_PROGRAM_NARGS(x)	(SCM_PROGRAM_DATA (x)->nargs)
 #define SCM_PROGRAM_NREST(x)	(SCM_PROGRAM_DATA (x)->nrest)
 #define SCM_PROGRAM_NLOCS(x)	(SCM_PROGRAM_DATA (x)->nlocs)
+#define SCM_PROGRAM_NEXTS(x)	(SCM_PROGRAM_DATA (x)->nexts)
 #define SCM_PROGRAM_BASE(x)	(SCM_PROGRAM_DATA (x)->base)
 #define SCM_PROGRAM_META(x)	(SCM_PROGRAM_DATA (x)->meta)
 #define SCM_PROGRAM_OBJS(x)	(SCM_PROGRAM_DATA (x)->objs)
@@ -81,7 +83,7 @@ extern scm_bits_t scm_tc16_program;
 #define SCM_PROGRAM_HOLDER(x)	(SCM_PROGRAM_DATA (x)->holder)
 
 extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
-extern SCM scm_c_make_vclosure (SCM program, SCM external);
+extern SCM scm_c_make_closure (SCM program, SCM external);
 
 extern void scm_init_programs (void);
 

src/vm.c

@@ -139,44 +139,44 @@ scm_bits_t scm_tc16_vm_cont;
 
 
 #define SCM_VM_CONT_P(OBJ)	SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_VMP(CONT)	((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
+#define SCM_VM_CONT_VP(CONT)	((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
 
 static SCM
-capture_vm_cont (struct scm_vm *vmp)
+capture_vm_cont (struct scm_vm *vp)
 {
   struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
-  p->stack_size = vmp->stack_limit - vmp->sp;
+  p->stack_size = vp->stack_limit - vp->sp;
   p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
 				   "capture_vm_cont");
   p->stack_limit = p->stack_base + p->stack_size - 2;
-  p->ip = vmp->ip;
+  p->ip = vp->ip;
-  p->sp = (SCM *) (vmp->stack_limit - vmp->sp);
+  p->sp = (SCM *) (vp->stack_limit - vp->sp);
-  p->fp = (SCM *) (vmp->stack_limit - vmp->fp);
+  p->fp = (SCM *) (vp->stack_limit - vp->fp);
-  memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM));
+  memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
   SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
 }
 
 static void
-reinstate_vm_cont (struct scm_vm *vmp, SCM cont)
+reinstate_vm_cont (struct scm_vm *vp, SCM cont)
 {
-  struct scm_vm *p = SCM_VM_CONT_VMP (cont);
+  struct scm_vm *p = SCM_VM_CONT_VP (cont);
-  if (vmp->stack_size < p->stack_size)
+  if (vp->stack_size < p->stack_size)
     {
       /* puts ("FIXME: Need to expand"); */
       abort ();
     }
-  vmp->ip = p->ip;
+  vp->ip = p->ip;
-  vmp->sp = vmp->stack_limit - (int) p->sp;
+  vp->sp = vp->stack_limit - (int) p->sp;
-  vmp->fp = vmp->stack_limit - (int) p->fp;
+  vp->fp = vp->stack_limit - (int) p->fp;
-  memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
+  memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
 }
 
 static SCM
 vm_cont_mark (SCM obj)
 {
   SCM *p;
-  struct scm_vm *vmp = SCM_VM_CONT_VMP (obj);
+  struct scm_vm *vp = SCM_VM_CONT_VP (obj);
-  for (p = vmp->stack_base; p <= vmp->stack_limit; p++)
+  for (p = vp->stack_base; p <= vp->stack_limit; p++)
     if (SCM_NIMP (*p))
       scm_gc_mark (*p);
   return SCM_BOOL_F;
@@ -185,7 +185,7 @@ vm_cont_mark (SCM obj)
 static scm_sizet
 vm_cont_free (SCM obj)
 {
-  struct scm_vm *p = SCM_VM_CONT_VMP (obj);
+  struct scm_vm *p = SCM_VM_CONT_VP (obj);
   int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
   scm_must_free (p->stack_base);
   scm_must_free (p);
@@ -255,20 +255,20 @@ make_vm (void)
 #define FUNC_NAME "make_vm"
 {
   int i;
-  struct scm_vm *vmp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
+  struct scm_vm *vp = SCM_MUST_MALLOC (sizeof (struct scm_vm));
-  vmp->stack_size  = VM_DEFAULT_STACK_SIZE;
+  vp->stack_size  = VM_DEFAULT_STACK_SIZE;
-  vmp->stack_base  = SCM_MUST_MALLOC (vmp->stack_size * sizeof (SCM));
+  vp->stack_base  = SCM_MUST_MALLOC (vp->stack_size * sizeof (SCM));
-  vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1;
+  vp->stack_limit = vp->stack_base + vp->stack_size - 1;
-  vmp->ip    	   = NULL;
+  vp->ip    	   = NULL;
-  vmp->sp    	   = vmp->stack_limit;
+  vp->sp    	   = vp->stack_limit;
-  vmp->fp    	   = NULL;
+  vp->fp    	   = NULL;
-  vmp->cons        = 0;
+  vp->cons        = 0;
-  vmp->time        = 0;
+  vp->time        = 0;
-  vmp->clock       = 0;
+  vp->clock       = 0;
-  vmp->options     = SCM_EOL;
+  vp->options     = SCM_EOL;
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
-    vmp->hooks[i] = SCM_BOOL_F;
+    vp->hooks[i] = SCM_BOOL_F;
-  SCM_RETURN_NEWSMOB (scm_tc16_vm, vmp);
+  SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
 }
 #undef FUNC_NAME
 
@@ -277,11 +277,11 @@ vm_mark (SCM obj)
 {
   int i;
   SCM *sp, *fp;
-  struct scm_vm *vmp = SCM_VM_DATA (obj);
+  struct scm_vm *vp = SCM_VM_DATA (obj);
 
   /* Mark the stack */
-  sp = vmp->sp;
+  sp = vp->sp;
-  fp = vmp->fp;
+  fp = vp->fp;
   while (fp)
     {
       SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
@@ -301,17 +301,17 @@ vm_mark (SCM obj)
 
   /* Mark the options */
   for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
-    scm_gc_mark (vmp->hooks[i]);
+    scm_gc_mark (vp->hooks[i]);
-  return vmp->options;
+  return vp->options;
 }
 
 static scm_sizet
 vm_free (SCM obj)
 {
-  struct scm_vm *vmp = SCM_VM_DATA (obj);
+  struct scm_vm *vp = SCM_VM_DATA (obj);
-  int size = (sizeof (struct scm_vm) + vmp->stack_size * sizeof (SCM));
+  int size = (sizeof (struct scm_vm) + vp->stack_size * sizeof (SCM));
-  scm_must_free (vmp->stack_base);
+  scm_must_free (vp->stack_base);
-  scm_must_free (vmp);
+  scm_must_free (vp);
   return size;
 }
 
@@ -387,12 +387,12 @@ SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
 
 #define VM_DEFINE_HOOK(n)				\
 {							\
-  struct scm_vm *vmp;					\
+  struct scm_vm *vp;					\
   SCM_VALIDATE_VM (1, vm);				\
-  vmp = SCM_VM_DATA (vm);				\
+  vp = SCM_VM_DATA (vm);				\
-  if (SCM_FALSEP (vmp->hooks[n]))			\
+  if (SCM_FALSEP (vp->hooks[n]))			\
-    vmp->hooks[n] = scm_make_hook (SCM_MAKINUM (1));	\
+    vp->hooks[n] = scm_make_hook (SCM_MAKINUM (1));	\
-  return vmp->hooks[n];					\
+  return vp->hooks[n];					\
 }
 
 SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,

src/vm.h

@@ -61,16 +61,16 @@
  */
 
 /*
-   |                  | <- fp + bp->nargs + bp->nlocs
+   |                  | <- fp + bp->nlocs + bp->nargs
-   +------------------+
+   +------------------+    = SCM_VM_FRAME_UPPER_ADDRESS (fp)
    | Argument 1       |
-   | Argument 2       |
+   | Argument 2       | <- fp + bp->nlocs
    | Local variable 1 |
    | Local varialbe 2 | <- fp
    | Program          |
    | Dynamic link     |
    | Return address   | <- fp - SCM_VM_FRAME_DATA_SIZE
-   +------------------+
+   +------------------+    = SCM_VM_FRAME_LOWER_ADDRESS (fp)
    |                  |
 */
 

src/vm_engine.c

@@ -53,16 +53,16 @@ vm_engine (SCM vm, SCM program, SCM args)
   register SCM *fp FP_REG;		/* frame pointer */
 
   /* Cache variables */
-  struct scm_vm *vmp = SCM_VM_DATA (vm);/* VM data pointer */
+  struct scm_vm *vp = SCM_VM_DATA (vm);	/* VM data pointer */
   struct scm_program *bp = NULL;	/* program base pointer */
   SCM external;				/* external environment */
   SCM *objects = NULL;			/* constant objects */
-  SCM *stack_base = vmp->stack_base;	/* stack base address */
+  SCM *stack_base = vp->stack_base;	/* stack base address */
-  SCM *stack_limit = vmp->stack_limit;	/* stack limit address */
+  SCM *stack_limit = vp->stack_limit;	/* stack limit address */
 
   /* Internal variables */
   int nargs = 0;
-  long run_time = scm_c_get_internal_run_time ();
+  long start_time = scm_c_get_internal_run_time ();
   // SCM dynwinds = SCM_EOL;
   SCM err_msg;
   SCM err_args;
@@ -83,20 +83,23 @@ vm_engine (SCM vm, SCM program, SCM args)
   };
 #endif
 
+  /* Initialization */
+  {
     /* Bootcode */
-  scm_byte_t code[3] = {scm_op_call, 0, scm_op_halt};
+    scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
-  SCM bootcode = scm_c_make_program (code, 3, SCM_BOOL_T);
+    SCM bootcode = scm_c_make_program (bytes, 3, SCM_BOOL_T);
-  code[1] = scm_ilength (args);
+    bytes[1] = scm_ilength (args);
 
     /* Initial frame */
-  bp = SCM_PROGRAM_DATA (bootcode);
+    CACHE_REGISTER ();
-  CACHE ();
+    CACHE_PROGRAM (bootcode);
     NEW_FRAME ();
 
     /* Initial arguments */
     for (; !SCM_NULLP (args); args = SCM_CDR (args))
       PUSH (SCM_CAR (args));
     PUSH (program);
+  }
 
   /* Let's go! */
   BOOT_HOOK ();

src/vm_engine.h

@@ -42,14 +42,11 @@
 /* This file is included in vm_engine.c */
 
 /*
- * VM Options
+ * Options
  */
 
-#define VM_OPTION(regular,debug) debug
+#define VM_USE_HOOKS	1	/* Various hooks */
-
+#define VM_USE_CLOCK	1	/* Bogoclock */
-#define VM_USE_HOOKS	VM_OPTION (0, 1)	/* Various hooks */
-#define VM_USE_CLOCK	VM_OPTION (0, 1)	/* Bogos clock */
-#define VM_CHECK_IP	VM_OPTION (0, 0)	/* Check IP  */
 
 
 /*
@@ -113,6 +110,42 @@
 #endif
 #endif
 
+
+/*
+ * Cache/Sync
+ */
+
+#define CACHE_REGISTER()			\
+{						\
+  ip = vp->ip;					\
+  sp = vp->sp;					\
+  fp = vp->fp;					\
+}
+
+#define SYNC_REGISTER()				\
+{						\
+  vp->ip = ip;					\
+  vp->sp = sp;					\
+  vp->fp = fp;					\
+}
+
+#define CACHE_PROGRAM(program)			\
+{						\
+  bp = SCM_PROGRAM_DATA (program);		\
+  objects  = SCM_VELTS (bp->objs);		\
+  external = bp->external;			\
+}
+
+#define SYNC_BEFORE_GC()			\
+{						\
+  SYNC_REGISTER ();				\
+}
+
+#define SYNC_ALL()				\
+{						\
+  SYNC_REGISTER ();				\
+}
+
 
 /*
  * Hooks
@@ -124,7 +157,7 @@
 {						\
   if (!SCM_FALSEP (h))				\
     {						\
-      SYNC ();					\
+      SYNC_BEFORE_GC ();			\
       scm_c_run_hook (h, hook_args);		\
     }						\
 }
@@ -132,45 +165,13 @@
 #define RUN_HOOK(h)
 #endif
 
-#define BOOT_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_BOOT_HOOK])
+#define BOOT_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_BOOT_HOOK])
-#define HALT_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_HALT_HOOK])
+#define HALT_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_HALT_HOOK])
-#define NEXT_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_NEXT_HOOK])
+#define NEXT_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_NEXT_HOOK])
-#define ENTER_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_ENTER_HOOK])
+#define ENTER_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_ENTER_HOOK])
-#define APPLY_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_APPLY_HOOK])
+#define APPLY_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_APPLY_HOOK])
-#define EXIT_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_EXIT_HOOK])
+#define EXIT_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_EXIT_HOOK])
-#define RETURN_HOOK()	RUN_HOOK (vmp->hooks[SCM_VM_RETURN_HOOK])
+#define RETURN_HOOK()	RUN_HOOK (vp->hooks[SCM_VM_RETURN_HOOK])
-
-
-/*
- * Basic operations
- */
-
-#define CACHE()					\
-{						\
-  ip = vmp->ip;					\
-  sp = vmp->sp;					\
-  fp = vmp->fp;					\
-}
-
-#define SYNC()					\
-{						\
-  vmp->ip = ip;					\
-  vmp->sp = sp;					\
-  vmp->fp = fp;					\
-}
-
-#define SYNC_TIME()					\
-{							\
-  long cur_time = scm_c_get_internal_run_time ();	\
-  vmp->time += cur_time - run_time;			\
-  run_time = cur_time;					\
-}
-
-#define SYNC_ALL()				\
-{						\
-  SYNC ();					\
-  SYNC_TIME ();					\
-}
 
 
 /*
@@ -192,7 +193,7 @@
 #define CONS(x,y,z)				\
 {						\
   SCM cell;					\
-  SYNC ()					\
+  SYNC_BEFORE_GC ();				\
   SCM_NEWCELL (cell);				\
   SCM_SET_CELL_OBJECT_0 (cell, y);		\
   SCM_SET_CELL_OBJECT_1 (cell, z);		\
@@ -219,23 +220,11 @@ do {						\
 
 #undef CLOCK
 #if VM_USE_CLOCK
-#define CLOCK(n)	vmp->clock += n
+#define CLOCK(n)	vp->clock += n
 #else
 #define CLOCK(n)
 #endif
 
-#undef NEXT_CHECK
-#if VM_CHECK_IP
-#define NEXT_CHECK()				\
-{						\
-  scm_byte_t *base = bp->base;			\
-  if (ip < base || ip >= base + bp->size)	\
-    goto vm_error_invalid_address;		\
-}
-#else
-#define NEXT_CHECK()
-#endif
-
 #undef NEXT_JUMP
 #ifdef HAVE_LABELS_AS_VALUES
 #define NEXT_JUMP()		goto *jump_table[FETCH ()]
@@ -246,7 +235,6 @@ do {						\
 #define NEXT					\
 {						\
   CLOCK (1);					\
-  NEXT_CHECK ();				\
   NEXT_HOOK ();					\
   NEXT_JUMP ();					\
 }
@@ -304,18 +292,6 @@ do {						\
     }						\
 }
 
-#define INIT_VARIABLES()				\
-{							\
-  int i;						\
-  for (i = 0; i < bp->nlocs; i++)			\
-    SCM_VM_FRAME_VARIABLE (fp, i) = SCM_UNDEFINED;	\
-}
-
-#define CACHE_PROGRAM()				\
-  bp = SCM_PROGRAM_DATA (program);		\
-  objects  = SCM_VELTS (bp->objs);		\
-  external = bp->external;
-
 /*
   Local Variables:
   c-file-style: "gnu"

src/vm_loader.c

@@ -118,16 +118,31 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
   if (SCM_INUMP (x))
     {
       int i = SCM_INUM (x);
-      SCM_PROGRAM_NARGS (prog) = i >> 5;	/* 6-5 bits */
+      if (-128 <= i && i <= 127)
-      SCM_PROGRAM_NREST (prog) = (i >> 4) & 1;	/* 4 bit */
+	{
-      SCM_PROGRAM_NLOCS (prog) = i & 15;	/* 3-0 bits */
+	  /* 8-bit representation */
+	  SCM_PROGRAM_NARGS (prog) = (i >> 6) & 0x03;	/* 7-6 bits */
+	  SCM_PROGRAM_NREST (prog) = (i >> 5) & 0x01;	/* 5 bit */
+	  SCM_PROGRAM_NLOCS (prog) = (i >> 2) & 0x07;	/* 4-2 bits */
+	  SCM_PROGRAM_NEXTS (prog) = i & 0x03;		/* 1-0 bits */
 	}
       else
 	{
-      SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[3]);
+	  /* 16-bit representation */
-      SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
+	  SCM_PROGRAM_NARGS (prog) = (i >> 12) & 0x07;	/* 15-12 bits */
-      SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[1]);
+	  SCM_PROGRAM_NREST (prog) = (i >> 11) & 0x01;	/* 11 bit */
-      sp += 3;
+	  SCM_PROGRAM_NLOCS (prog) = (i >> 4)  & 0x7f;	/* 10-4 bits */
+	  SCM_PROGRAM_NEXTS (prog) = i & 0x07;		/* 3-0 bits */
+	}
+    }
+  else
+    {
+      /* Other cases */
+      SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[4]);
+      SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[3]);
+      SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[2]);
+      SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[1]);
+      sp += 4;
     }
 
   *sp = prog;

src/vm_system.c

@@ -55,6 +55,7 @@ VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
 VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
 {
   SCM ret = *sp;
+  vp->time += scm_c_get_internal_run_time () - start_time;
   HALT_HOOK ();
   FREE_FRAME ();
   SYNC_ALL ();
@@ -154,14 +155,6 @@ VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
 #define VARIABLE_REF(v)		SCM_CDR (v)
 #define VARIABLE_SET(v,o)	SCM_SETCDR (v, o)
 
-VM_DEFINE_INSTRUCTION (external, "external", 1, 0, 0)
-{
-  int n = FETCH ();
-  while (n-- > 0)
-    CONS (external, SCM_UNDEFINED, external);
-  NEXT;
-}
-
 /* ref */
 
 VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
@@ -284,8 +277,8 @@ VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0)
 
 VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
 {
-  SYNC ();
+  SYNC_BEFORE_GC ();
-  *sp = scm_c_make_vclosure (*sp, external);
+  *sp = scm_c_make_closure (*sp, external);
   NEXT;
 }
 
@@ -300,10 +293,20 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
    */
   if (SCM_PROGRAM_P (program))
     {
-      CACHE_PROGRAM ();
+      int i;
+    vm_call_program:
+      CACHE_PROGRAM (program);
       INIT_ARGS ();
       NEW_FRAME ();
-      INIT_VARIABLES ();
+
+      /* Init local variables */
+      for (i = 0; i < bp->nlocs; i++)
+	LOCAL_SET (i, SCM_UNDEFINED);
+
+      /* Create external variables */
+      for (i = 0; i < bp->nexts; i++)
+	CONS (external, SCM_UNDEFINED, external);
+
       ENTER_HOOK ();
       APPLY_HOOK ();
       NEXT;
@@ -330,8 +333,8 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 
       /* Reinstate the continuation */
       EXIT_HOOK ();
-      reinstate_vm_cont (vmp, program);
+      reinstate_vm_cont (vp, program);
-      CACHE ();
+      CACHE_REGISTER ();
       /* We don't need to set the return value here
 	 because it is already on the top of the stack. */
       NEXT;
@@ -376,7 +379,6 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
   if (SCM_PROGRAM_P (program))
     {
       int i;
-      int n = SCM_VM_FRAME_LOWER_ADDRESS (fp) - sp;
       SCM *base = sp;
 
       /* Exit the current frame */
@@ -384,12 +386,12 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
       FREE_FRAME ();
 
       /* Move arguments */
-      sp -= n;
+      sp -= nargs;
-      for (i = 0; i < n; i++)
+      for (i = 0; i < nargs; i++)
 	sp[i] = base[i];
 
       /* Call the program */
-      goto vm_call;
+      goto vm_call_program;
     }
   /*
    * Function call
@@ -412,8 +414,8 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
 
 VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
 {
-  SYNC ();
+  SYNC_BEFORE_GC ();
-  PUSH (capture_vm_cont (vmp));
+  PUSH (capture_vm_cont (vp));
   POP (program);
   nargs = 1;
   goto vm_call;
@@ -430,7 +432,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
 
   /* Cache the last program */
   program = SCM_VM_FRAME_PROGRAM (fp);
-  CACHE_PROGRAM ();
+  CACHE_PROGRAM (program);
   PUSH (ret);
   NEXT;
 }