*** empty log message ***

module/system/base/language.scm

@@ -99,7 +99,7 @@
   (let ((compiled (object-file-name file)))
     (if (or (not (file-exists? compiled))
 	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
-	(compile-file-in file env lang))
+	(compile-file-in file env lang :O))
     (call-with-input-file compiled
       (lambda (p)
 	(let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))

module/system/il/compile.scm

@@ -39,14 +39,36 @@
 
 (define (optimize x)
   (match x
-    (($ <ghil-call> proc args)
+    (($ <ghil-set> env var val)
+     (make-<ghil-set> env var (optimize val)))
+
+    (($ <ghil-if> test then else)
+     (make-<ghil-if> (optimize test) (optimize then) (optimize else)))
+
+    (($ <ghil-begin> exps)
+     (make-<ghil-begin> (map optimize exps)))
+
+    (($ <ghil-bind> env vars vals body)
+     (make-<ghil-bind> env vars (map optimize vals) (optimize body)))
+
+    (($ <ghil-lambda> env vars rest body)
+     (make-<ghil-lambda> env vars rest (optimize body)))
+
+    (($ <ghil-inst> inst args)
+     (make-<ghil-inst> inst (map optimize args)))
+
+    (($ <ghil-call> env proc args)
      (match proc
        ;; ((@lambda (VAR...) BODY...) ARG...) =>
        ;;   (@let ((VAR ARG) ...) BODY...)
-       (($ <ghil-lambda> env vars #f body)
+       (($ <ghil-lambda> lambda-env vars #f body)
-	(optimize (make-<ghil-bind> vars args body)))
+	(for-each (lambda (v)
+		    (if (eq? v.kind 'argument) (set! v.kind 'local))
+		    (ghil-env-add! env v))
+		  lambda-env.variables)
+	(optimize (make-<ghil-bind> env vars args body)))
        (else
-	(make-<ghil-call> (optimize proc) (for-each optimize args)))))
+	(make-<ghil-call> env (optimize proc) (map optimize args)))))
     (else x)))
 
 
@@ -144,7 +166,7 @@
 		   (reverse vars))
 	 (comp-tail body))
 
-	(($ <ghil-lambda> vars rest body)
+	(($ <ghil-lambda> env vars rest body)
 	 (return-code! (codegen tree)))
 
 	(($ <ghil-inst> inst args)
@@ -155,12 +177,12 @@
 	 (if drop (push-code! *ia-drop*))
 	 (if tail (push-code! *ia-return*)))
 
-	(($ <ghil-call> proc args)
+	(($ <ghil-call> env proc args)
-	 ;; ARGS...
 	 ;; PROC
+	 ;; ARGS...
 	 ;; ([tail-]call NARGS)
-	 (for-each comp-push args)
 	 (comp-push proc)
+	 (for-each comp-push args)
 	 (let ((inst (if tail 'tail-call 'call)))
 	   (push-code! (make-<glil-call> inst (length args))))
 	 (if drop (push-code! *ia-drop*)))))

module/system/il/ghil.scm

@@ -37,7 +37,7 @@
    <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4
    make-<ghil-lambda> <ghil-lambda>?
    <ghil-lambda>-1 <ghil-lambda>-2 <ghil-lambda>-3 <ghil-lambda>-4
-   make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2
+   make-<ghil-call> <ghil-call>? <ghil-call>-1 <ghil-call>-2 <ghil-call>-3
    make-<ghil-inst> <ghil-inst>? <ghil-inst>-1 <ghil-inst>-2
    ))
 
@@ -53,8 +53,8 @@
 (define-structure (<ghil-if> test then else))
 (define-structure (<ghil-begin> exps))
 (define-structure (<ghil-bind> env vars vals body))
-(define-structure (<ghil-lambda> env args rest body))
+(define-structure (<ghil-lambda> env vars rest body))
-(define-structure (<ghil-call> proc args))
+(define-structure (<ghil-call> env proc args))
 (define-structure (<ghil-inst> inst args))
 
 
@@ -128,14 +128,13 @@
 (define-method (ghil-env-ref (env <ghil-env>) (sym <symbol>))
   (assq-ref env.table sym))
 
-(define-method (ghil-env-add! (env <ghil-env>) (sym <symbol>) kind)
+(export ghil-env-add!)
-  (let ((var (make-ghil-var env sym kind)))
+(define-method (ghil-env-add! (env <ghil-env>) (var <ghil-var>))
-    (set! env.table (acons sym var env.table))
+  (set! env.table (acons var.name var env.table))
-    (set! env.variables (cons var env.variables))
+  (set! env.variables (cons var env.variables)))
-    var))
 
-(define-method (ghil-env-remove! (env <ghil-env>) (sym <symbol>))
+(define-method (ghil-env-remove! (env <ghil-env>) (var <ghil-var>))
-  (set! env.table (assq-remove! env.table sym)))
+  (set! env.table (assq-remove! env.table var.name)))
 
 (define-method (ghil-lookup (env <ghil-env>) (sym <symbol>))
   (or (ghil-env-ref env sym)
@@ -173,7 +172,7 @@
 	(if (ghil-primitive-macro? head)
 	    (parse (apply (ghil-macro-expander head) tail) e)
 	    (parse-primitive head tail e))
-	(make-<ghil-call> (parse head e) (map-parse tail e)))))
+	(make-<ghil-call> e (parse head e) (map-parse tail e)))))
 
 (define (parse-primitive prim args e)
   (case prim
@@ -229,24 +228,17 @@
     ((@begin)
      (parse-body args e))
 
-    ;; (@let ((SYM INIT)...) BODY...)
-    ((@let)
-     (match args
-       ((((sym init) ...) body ...)
-	(let* ((vals (map-parse init e))
-	       (vars (map (lambda (s) (ghil-env-add! e s 'local)) sym))
-	       (body (parse-body body e)))
-	  (for-each (lambda (s) (ghil-env-remove! e s)) sym)
-	  (make-<ghil-bind> e vars vals body)))))
-
     ;; (@letrec ((SYM INIT)...) BODY...)
     ((@letrec)
      (match args
        ((((sym init) ...) body ...)
-	(let* ((vars (map (lambda (s) (ghil-env-add! e s 'local)) sym))
+	(let* ((vars (map (lambda (s)
+			    (let ((v (make-ghil-var e s 'local)))
+			      (ghil-env-add! e v) v))
+			  sym))
 	       (vals (map-parse init e))
 	       (body (parse-body body e)))
-	  (for-each (lambda (s) (ghil-env-remove! e s)) sym)
+	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
 	  (make-<ghil-bind> e vars vals body)))))
 
     ;; (@lambda FORMALS BODY...)
@@ -255,8 +247,11 @@
        ((formals . body)
 	(receive (syms rest) (parse-formals formals)
 	  (let* ((e (make-ghil-env e))
-		 (args (map (lambda (s) (ghil-env-add! e s 'argument)) syms)))
+		 (vars (map (lambda (s)
-	    (make-<ghil-lambda> e args rest (parse-body body e)))))))
+			      (let ((v (make-ghil-var e s 'argument)))
+				(ghil-env-add! e v) v))
+			    syms)))
+	    (make-<ghil-lambda> e vars rest (parse-body body e)))))))
 
     (else (error "Unknown primitive:" prim))))
 

module/system/il/macros.scm

@@ -260,9 +260,9 @@
 
 ;;;; 6.4 Control features
 
-;; (define (@procedure? x) `(@@ procedure? x))
+(define (@procedure? x) `((@ Core::procedure?) ,x))
 
-;; (define (@apply proc . args) ...)
+(define (@apply proc . args) `(@@ apply ,proc ,@args))
 
 ;;; (define (@force promise) `(@@ force promise))
 

module/system/repl/command.scm

@@ -353,7 +353,7 @@ Start debugger."
   (debug))
 
 (define (trace repl form . opts)
-  "trace [-a] FORM
+  "trace [-b] FORM
 Trace execution."
   (apply vm-trace repl.vm (repl-compile repl form) opts))
 

module/system/vm/assemble.scm

@@ -72,8 +72,7 @@
     (($ <vm-asm> venv ($ <glil-asm> nargs nrest nlocs nexts _) body)
      (let ((stack '())
 	   (label-alist '())
-	   (object-alist '())
+	   (object-alist '()))
-	   (nvars (+ nargs nlocs -1)))
        (define (push-code! code)
 	 (set! stack (optimizing-push code stack)))
        (define (push-object! x)
@@ -106,18 +105,17 @@
 		      (else (push-object! x)))))
 
 	   (($ <glil-argument> op index)
-	    (push-code! `(,(symbol-append 'local- op) ,(- nvars index))))
+	    (push-code! `(,(symbol-append 'local- op) ,index)))
 
 	   (($ <glil-local> op index)
-	    (push-code! `(,(symbol-append 'local- op)
+	    (push-code! `(,(symbol-append 'local- op) ,(+ nargs index))))
-			  ,(- nvars (+ nargs index)))))
 
 	   (($ <glil-external> op depth index)
 	    (do ((e venv (venv-parent e))
 		 (d depth (1- d))
-		 (i 0 (+ i (venv-nexts e))))
+		 (n 0 (+ n (venv-nexts e))))
 		((= d 0)
-		 (push-code! `(,(symbol-append 'external- op) ,(+ index i))))))
+		 (push-code! `(,(symbol-append 'external- op) ,(+ n index))))))
 
 	   (($ <glil-module> op module name)
 	    ;; (let ((vlink (make-vlink (make-vmod module) name)))

module/system/vm/disasm.scm

@@ -47,7 +47,7 @@
 	 (objs  (program-objects prog)))
     ;; Disassemble this bytecode
     (format #t "Disassembly of ~A:\n\n" prog)
-    (format #t "nargs = ~A  nrest = ~A  nlocs = ~A nexts ~A\n\n"
+    (format #t "nargs = ~A  nrest = ~A  nlocs = ~A  nexts = ~A\n\n"
 	    nargs nrest nlocs nexts)
     (format #t "Bytecode:\n\n")
     (disassemble-bytecode bytes objs)

module/system/vm/load.scm

@@ -30,7 +30,7 @@
 	 (compiled (object-file-name file)))
     (if (or (not (file-exists? compiled))
 	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
-	(compile-file-in file #f (lookup-language 'gscheme)))
+	(compile-file-in file #f (lookup-language 'gscheme) :O))
     (let ((bytes (make-uniform-vector (stat:size (stat compiled)) #\a)))
       (call-with-input-file compiled
 	(lambda (p) (uniform-vector-read! bytes p)))

module/system/vm/trace.scm

@@ -30,14 +30,14 @@
   (dynamic-wind
       (lambda ()
 	(set-vm-option! vm 'trace-first #t)
-	(if (memq :a opts)
+	(if (memq :b opts)
 	    (add-hook! (vm-next-hook vm) trace-next))
 	(add-hook! (vm-apply-hook vm) trace-apply)
 	(add-hook! (vm-return-hook vm) trace-return))
       (lambda ()
 	(vm-load vm bytes))
       (lambda ()
-	(if (memq :a opts)
+	(if (memq :b opts)
 	    (remove-hook! (vm-next-hook vm) trace-next))
 	(remove-hook! (vm-apply-hook vm) trace-apply)
 	(remove-hook! (vm-return-hook vm) trace-return))))

src/vm.c

@@ -54,39 +54,30 @@
 
 
 /*
- * VM Debug frame
+ * VM Heap frame
  */
 
-scm_bits_t scm_tc16_vm_debug_frame;
+scm_bits_t scm_tc16_vm_heap_frame;
 
 static SCM
-make_vm_debug_frame (SCM *fp)
+make_vm_heap_frame (SCM *fp)
 {
-  int i, size;
+  struct scm_vm_heap_frame *p =
-  struct scm_vm_debug_frame *p;
+    scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame");
-
+  p->fp           = fp;
-  if (!fp)
+  p->program      = SCM_UNDEFINED;
-    return SCM_BOOL_F;
+  p->variables    = SCM_UNDEFINED;
-
+  p->dynamic_link = SCM_UNDEFINED;
-  p = scm_must_malloc (sizeof (struct scm_vm_debug_frame), "make_vm_debug_frame");
+  SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p);
-  p->program      = SCM_VM_FRAME_PROGRAM (fp);
-  p->dynamic_link = make_vm_debug_frame (SCM_VM_FRAME_ADDRESS
-					 (SCM_VM_FRAME_DYNAMIC_LINK (fp)));
-
-  size = SCM_PROGRAM_NARGS (p->program) + SCM_PROGRAM_NLOCS (p->program);
-  p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
-  for (i = 0; i < size; i++)
-    SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i);
-
-  SCM_RETURN_NEWSMOB (scm_tc16_vm_debug_frame, p);
 }
 
 static SCM
-vm_debug_frame_mark (SCM obj)
+vm_heap_frame_mark (SCM obj)
 {
-  scm_gc_mark (SCM_VM_DEBUG_FRAME_PROGRAM (obj));
+  struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj);
-  scm_gc_mark (SCM_VM_DEBUG_FRAME_VARIABLES (obj));
+  scm_gc_mark (p->program);
-  return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (obj);
+  scm_gc_mark (p->variables);
+  return p->dynamic_link;
 }
 
 /* Scheme interface */
@@ -96,7 +87,7 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_frame_p
 {
-  return SCM_BOOL (SCM_VM_DEBUG_FRAME_P (obj));
+  return SCM_BOOL (SCM_VM_HEAP_FRAME_P (obj));
 }
 #undef FUNC_NAME
 
@@ -105,8 +96,8 @@ SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_frame_program
 {
-  SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
+  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
-  return SCM_VM_DEBUG_FRAME_PROGRAM (frame);
+  return SCM_VM_FRAME_PROGRAM (SCM_VM_HEAP_FRAME_DATA (frame)->fp);
 }
 #undef FUNC_NAME
 
@@ -115,8 +106,20 @@ SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_frame_variables
 {
-  SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
+  struct scm_vm_heap_frame *p;
-  return SCM_VM_DEBUG_FRAME_VARIABLES (frame);
+
+  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
+  p = SCM_VM_HEAP_FRAME_DATA (frame);
+
+  if (SCM_UNBNDP (p->variables))
+    {
+      SCM prog = scm_frame_program (frame);
+      int i, size = SCM_PROGRAM_NARGS (prog) + SCM_PROGRAM_NLOCS (prog);
+      p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
+      for (i = 0; i < size; i++)
+	SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (p->fp, i);
+    }
+  return p->variables;
 }
 #undef FUNC_NAME
 
@@ -125,8 +128,21 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_frame_dynamic_link
 {
-  SCM_VALIDATE_VM_DEBUG_FRAME (1, frame);
+  struct scm_vm_heap_frame *p;
-  return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (frame);
+
+  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
+  p = SCM_VM_HEAP_FRAME_DATA (frame);
+
+  if (SCM_UNBNDP (p->dynamic_link))
+    {
+      SCM *fp = SCM_VM_STACK_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (p->fp));
+      if (fp)
+	p->dynamic_link = make_vm_heap_frame (fp);
+      else
+	p->dynamic_link = SCM_BOOL_F;
+    }
+
+  return p->dynamic_link;
 }
 #undef FUNC_NAME
 
@@ -260,9 +276,9 @@ 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;
+  vp->stack_limit = vp->stack_base + vp->stack_size - 3;
   vp->ip    	  = NULL;
-  vp->sp    	   = vp->stack_limit;
+  vp->sp    	  = vp->stack_base - 1;
   vp->fp    	  = NULL;
   vp->time        = 0;
   vp->clock       = 0;
@@ -288,16 +304,14 @@ vm_mark (SCM obj)
       SCM *upper = SCM_VM_FRAME_UPPER_ADDRESS (fp);
       SCM *lower = SCM_VM_FRAME_LOWER_ADDRESS (fp);
       /* Mark intermediate data */
-      for (; sp < lower; sp++)
+      for (; sp >= upper; sp--)
 	if (SCM_NIMP (*sp))
 	  scm_gc_mark (*sp);
-      /* Mark frame data */
+      fp = SCM_VM_STACK_ADDRESS (*sp);		/* dynamic link */
-      scm_gc_mark (SCM_VM_FRAME_PROGRAM (fp));
+      /* Mark frame variables + program */
-      /* Mark frame variables */
+      for (sp -= 2; sp >= lower; sp--)
-      for (sp = fp; sp < upper; sp++)
 	if (SCM_NIMP (*sp))
 	  scm_gc_mark (*sp);
-      fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp));
     }
 
   /* Mark the options */
@@ -519,7 +533,7 @@ SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
 {
   SCM_VALIDATE_VM (1, vm);
   VM_CHECK_RUNNING (vm);
-  return make_vm_debug_frame (SCM_VM_DATA (vm)->fp);
+  return make_vm_heap_frame (SCM_VM_DATA (vm)->fp);
 }
 #undef FUNC_NAME
 
@@ -551,18 +565,17 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_vm_fetch_stack
 {
-  SCM *p;
+  SCM *sp;
-  SCM list = SCM_EOL;
+  SCM ls = SCM_EOL;
+  struct scm_vm *vp;
 
   SCM_VALIDATE_VM (1, vm);
   VM_CHECK_RUNNING (vm);
 
-  if (SCM_VM_DATA (vm)->fp)
+  vp = SCM_VM_DATA (vm);
-    for (p = SCM_VM_FRAME_LOWER_ADDRESS (SCM_VM_DATA (vm)->fp) - 1;
+  for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
-	 p >= SCM_VM_DATA (vm)->sp;
+    ls = scm_cons (*sp, ls);
-	 p--)
+  return ls;
-      list = scm_cons (*p, list);
-  return list;
 }
 #undef FUNC_NAME
 
@@ -606,8 +619,8 @@ scm_init_vm (void)
   scm_init_instructions ();
   scm_init_programs ();
 
-  scm_tc16_vm_debug_frame = scm_make_smob_type ("vm_frame", 0);
+  scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0);
-  scm_set_smob_mark (scm_tc16_vm_debug_frame, vm_debug_frame_mark);
+  scm_set_smob_mark (scm_tc16_vm_heap_frame, vm_heap_frame_mark);
 
   scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
   scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);

src/vm.h

@@ -50,62 +50,62 @@
  * VM Address
  */
 
-#define SCM_VM_MAKE_FRAME_ADDRESS(ptr)	SCM_PACK (ptr)
+#define SCM_VM_MAKE_STACK_ADDRESS(ptr)	SCM_PACK (ptr)
-#define SCM_VM_FRAME_ADDRESS(addr)	((SCM *) SCM_UNPACK (addr))
+#define SCM_VM_STACK_ADDRESS(addr)	((SCM *) SCM_UNPACK (addr))
 
 #define SCM_VM_MAKE_BYTE_ADDRESS(ptr)	SCM_PACK (ptr)
 #define SCM_VM_BYTE_ADDRESS(addr)	((scm_byte_t *) SCM_UNPACK (addr))
 
 /*
- * VM Frame
+ * VM Stack frame
  */
 
 /*
-   |                  | <- fp + bp->nlocs + bp->nargs
+   |                  | <- fp + bp->nargs + bp->nlocs + 2
    +------------------+    = SCM_VM_FRAME_UPPER_ADDRESS (fp)
-   | Argument 1       |
-   | Argument 2       | <- fp + bp->nlocs
-   | Local variable 1 |
-   | Local varialbe 2 | <- fp
-   | Program          |
    | Dynamic link     |
-   | Return address   | <- fp - SCM_VM_FRAME_DATA_SIZE
+   | Return address   | <- fp + bp->nargs + bp->nlocs
+   | Local varialbe 1 |    = SCM_VM_FRAME_DATA_ADDRESS (fp)
+   | Local variable 0 | <- fp + bp->nargs
+   | Argument 1       |
+   | Argument 0       | <- fp
+   | Program          | <- fp - 1
    +------------------+    = SCM_VM_FRAME_LOWER_ADDRESS (fp)
    |                  |
 */
 
-/* Frames are allocated on the stack */
+#define SCM_VM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
-#define SCM_VM_FRAME_DATA_SIZE		3
+#define SCM_VM_FRAME_DATA_ADDRESS(fp)			\
-#define SCM_VM_FRAME_VARIABLE(fp,i)	fp[i]
-#define SCM_VM_FRAME_PROGRAM(fp)	fp[-1]
-#define SCM_VM_FRAME_DYNAMIC_LINK(fp)	fp[-2]
-#define SCM_VM_FRAME_RETURN_ADDRESS(fp)	fp[-3]
-
-#define SCM_VM_FRAME_UPPER_ADDRESS(fp)			\
   (fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp))	\
       + SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp)))
-#define SCM_VM_FRAME_LOWER_ADDRESS(fp) \
+#define SCM_VM_FRAME_UPPER_ADDRESS(fp)			\
-  (fp - SCM_VM_FRAME_DATA_SIZE)
+  (SCM_VM_FRAME_DATA_ADDRESS (fp) + 2)
+
+#define SCM_VM_FRAME_DYNAMIC_LINK(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[1]
+#define SCM_VM_FRAME_RETURN_ADDRESS(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[2]
+#define SCM_VM_FRAME_VARIABLE(fp,i)	fp[i]
+#define SCM_VM_FRAME_PROGRAM(fp)	fp[-1]
 
 /*
- * VM Debug frame
+ * VM Heap frame
  */
 
-struct scm_vm_debug_frame {
+struct scm_vm_heap_frame {
+  SCM *fp;
   SCM program;
   SCM variables;
   SCM dynamic_link;
 };
 
-extern scm_bits_t scm_tc16_vm_debug_frame;
+extern scm_bits_t scm_tc16_vm_heap_frame;
 
-#define SCM_VM_DEBUG_FRAME_P(x)		SCM_SMOB_PREDICATE (scm_tc16_vm_debug_frame, x)
+#define SCM_VM_HEAP_FRAME_P(x)	SCM_SMOB_PREDICATE (scm_tc16_vm_heap_frame, x)
-#define SCM_VM_DEBUG_FRAME_DATA(f)	((struct scm_vm_debug_frame *) SCM_SMOB_DATA (f))
+#define SCM_VM_HEAP_FRAME_DATA(f) ((struct scm_vm_heap_frame *) SCM_SMOB_DATA (f))
-#define SCM_VALIDATE_VM_DEBUG_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, VM_DEBUG_FRAME_P)
+#define SCM_VALIDATE_VM_HEAP_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, VM_HEAP_FRAME_P)
 
-#define SCM_VM_DEBUG_FRAME_PROGRAM(f)		SCM_VM_DEBUG_FRAME_DATA (f)->program
+#define SCM_VM_HEAP_FRAME_PROGRAM(f)	SCM_VM_HEAP_FRAME_DATA (f)->program
-#define SCM_VM_DEBUG_FRAME_VARIABLES(f)		SCM_VM_DEBUG_FRAME_DATA (f)->variables
+#define SCM_VM_HEAP_FRAME_VARIABLES(f)	SCM_VM_HEAP_FRAME_DATA (f)->variables
-#define SCM_VM_DEBUG_FRAME_DYNAMIC_LINK(f)	SCM_VM_DEBUG_FRAME_DATA (f)->dynamic_link
+#define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link
 
 /*
  * VM

src/vm_engine.c

@@ -94,12 +94,13 @@ vm_engine (SCM vm, SCM program, SCM args)
     /* Initial frame */
     CACHE_REGISTER ();
     CACHE_PROGRAM ();
+    PUSH (program);
     NEW_FRAME ();
 
     /* Initial arguments */
+    PUSH (prog);
     for (; !SCM_NULLP (args); args = SCM_CDR (args))
       PUSH (SCM_CAR (args));
-    PUSH (prog);
   }
 
   /* Let's go! */

src/vm_engine.h

@@ -179,15 +179,15 @@
  */
 
 #define CHECK_OVERFLOW()			\
-  if (sp < stack_base)				\
+  if (sp > stack_limit)				\
     goto vm_error_stack_overflow
 
 #define CHECK_UNDERFLOW()			\
-  if (sp >= stack_limit)			\
+  if (sp < stack_base)				\
     goto vm_error_stack_underflow
 
-#define PUSH(x)	do { CHECK_OVERFLOW (); *--sp = x; } while (0)
+#define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
-#define DROP()	do { CHECK_UNDERFLOW (); sp++; } while (0)
+#define DROP()	do { CHECK_UNDERFLOW (); sp--; } while (0)
 #define POP(x)	do { x = *sp; DROP (); } while (0)
 
 #define CONS(x,y,z)				\
@@ -204,10 +204,10 @@
 do {						\
   int i;					\
   SCM l = SCM_EOL;				\
-  for (i = 0; i < n; i++)			\
+  sp -= n;					\
+  for (i = n; i; i--)				\
     CONS (l, sp[i], l);				\
-  sp += n - 1;					\
+  PUSH (l);					\
-  *sp = l;					\
 } while (0)
 
 
@@ -245,8 +245,8 @@ do {						\
  */
 
 #define ARGS1(a1)	SCM a1 = sp[0];
-#define ARGS2(a1,a2)	SCM a1 = sp[1], a2 = sp[0]; sp++;
+#define ARGS2(a1,a2)	SCM a1 = sp[-1], a2 = sp[0]; sp--;
-#define ARGS3(a1,a2,a3)	SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2;
+#define ARGS3(a1,a2,a3)	SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
 #define ARGSN(an)	int an = FETCH ();
 
 #define RETURN(x)	do { *sp = x; NEXT; } while (0)
@@ -256,26 +256,6 @@ do {						\
  * Frame allocation
  */
 
-#define NEW_FRAME()				\
-{						\
-  SCM ra = SCM_VM_MAKE_FRAME_ADDRESS (ip);	\
-  SCM dl = SCM_VM_MAKE_BYTE_ADDRESS (fp);	\
-  ip = bp->base;				\
-  fp = sp - bp->nlocs;				\
-  sp = SCM_VM_FRAME_LOWER_ADDRESS (fp);		\
-  CHECK_OVERFLOW ();				\
-  SCM_VM_FRAME_PROGRAM (fp) = program;		\
-  SCM_VM_FRAME_DYNAMIC_LINK (fp) = dl;		\
-  SCM_VM_FRAME_RETURN_ADDRESS (fp) = ra;	\
-}
-
-#define FREE_FRAME()						\
-{								\
-  sp = fp + bp->nargs + bp->nlocs;				\
-  ip = SCM_VM_BYTE_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (fp));	\
-  fp = SCM_VM_FRAME_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (fp));	\
-}
-
 #define INIT_ARGS()				\
 {						\
   if (bp->nrest)				\
@@ -292,6 +272,27 @@ do {						\
     }						\
 }
 
+/* See vm.h for the layout of stack frames */
+
+#define NEW_FRAME()				\
+{						\
+  sp[1] = SCM_VM_MAKE_BYTE_ADDRESS (ip);	\
+  sp[2] = SCM_VM_MAKE_STACK_ADDRESS (fp);	\
+  ip = bp->base;				\
+  fp = sp - bp->nargs + 1;			\
+  sp = sp + 2;					\
+  CHECK_OVERFLOW ();				\
+}
+
+#define FREE_FRAME()				\
+{						\
+  SCM *new_sp = fp - 2;				\
+  sp = fp + bp->nargs + bp->nlocs;		\
+  ip = SCM_VM_BYTE_ADDRESS (sp[0]);		\
+  fp = SCM_VM_STACK_ADDRESS (sp[1]);		\
+  sp = new_sp;					\
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"

src/vm_expand.h

@@ -56,6 +56,7 @@
 
 #undef VM_DEFINE_INSTRUCTION
 #undef VM_DEFINE_FUNCTION
+#undef VM_DEFINE_LOADER
 #ifdef VM_INSTRUCTION_TO_TABLE
 /*
  * These will go to scm_instruction_table in vm.c
@@ -64,6 +65,8 @@
   {VM_OPCODE (tag), name, len, npop, npush},
 #define VM_DEFINE_FUNCTION(tag,name,nargs) \
   {VM_OPCODE (tag), name, (nargs < 0) ? 1 : 0, nargs, 1},
+#define VM_DEFINE_LOADER(tag,name) \
+  {VM_OPCODE (tag), name, -1, 0, 1},
 
 #else
 #ifdef VM_INSTRUCTION_TO_LABEL
@@ -72,6 +75,7 @@
  */
 #define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush)	VM_ADDR (tag),
 #define VM_DEFINE_FUNCTION(tag,name,nargs)		VM_ADDR (tag),
+#define VM_DEFINE_LOADER(tag,name)			VM_ADDR (tag),
 
 #else
 #ifdef VM_INSTRUCTION_TO_OPCODE
@@ -80,6 +84,7 @@
  */
 #define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush)	VM_OPCODE (tag),
 #define VM_DEFINE_FUNCTION(tag,name,nargs)		VM_OPCODE (tag),
+#define VM_DEFINE_LOADER(tag,name)			VM_OPCODE (tag),
 
 #else /* Otherwise */
 /*
@@ -87,6 +92,7 @@
  */
 #define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush)	VM_TAG (tag)
 #define VM_DEFINE_FUNCTION(tag,name,nargs)		VM_TAG (tag)
+#define VM_DEFINE_LOADER(tag,name)			VM_TAG (tag)
 
 #endif /* VM_INSTRUCTION_TO_OPCODE */
 #endif /* VM_INSTRUCTION_TO_LABEL */

src/vm_loader.c

@@ -41,7 +41,7 @@
 
 /* This file is included in vm_engine.c */
 
-VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1)
+VM_DEFINE_LOADER (load_integer, "load-integer")
 {
   size_t len;
 
@@ -58,7 +58,7 @@ VM_DEFINE_INSTRUCTION (load_integer, "load-integer", -1, 0, 1)
     SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
 }
 
-VM_DEFINE_INSTRUCTION (load_number, "load-number", -1, 0, 1)
+VM_DEFINE_LOADER (load_number, "load-number")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -67,7 +67,7 @@ VM_DEFINE_INSTRUCTION (load_number, "load-number", -1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1)
+VM_DEFINE_LOADER (load_string, "load-string")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -76,7 +76,7 @@ VM_DEFINE_INSTRUCTION (load_string, "load-string", -1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
+VM_DEFINE_LOADER (load_symbol, "load-symbol")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -85,7 +85,7 @@ VM_DEFINE_INSTRUCTION (load_symbol, "load-symbol", -1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1)
+VM_DEFINE_LOADER (load_keyword, "load-keyword")
 {
   SCM sym;
   size_t len;
@@ -96,7 +96,7 @@ VM_DEFINE_INSTRUCTION (load_keyword, "load-keyword", -1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (load_module, "load-module", -1, 0, 1)
+VM_DEFINE_LOADER (load_module, "load-module")
 {
   size_t len;
   FETCH_LENGTH (len);
@@ -105,7 +105,7 @@ VM_DEFINE_INSTRUCTION (load_module, "load-module", -1, 0, 1)
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
+VM_DEFINE_LOADER (load_program, "load-program")
 {
   size_t len;
   SCM prog, x;
@@ -148,11 +148,11 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
   else
     {
       /* Other cases */
-      SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[4]);
+      sp -= 4;
-      SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[3]);
+      SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[1]);
-      SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[2]);
+      SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
-      SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[1]);
+      SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[3]);
-      sp += 4;
+      SCM_PROGRAM_NEXTS (prog) = SCM_INUM (sp[4]);
     }
 
   *sp = prog;
@@ -161,8 +161,8 @@ VM_DEFINE_INSTRUCTION (load_program, "load-program", -1, 0, 1)
 
 VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
 {
-  sp[1] = scm_c_env_vcell (sp[1], sp[0], 1);
+  sp--;
-  DROP ();
+  *sp = scm_c_env_vcell (sp[0], sp[1], 1);
   NEXT;
 }
 

src/vm_scheme.c

@@ -169,8 +169,7 @@ VM_DEFINE_FUNCTION (vector, "vector", -1)
 {
   ARGSN (n);
   POP_LIST (n);
-  *sp = scm_vector (*sp);
+  RETURN (scm_vector (*sp));
-  NEXT;
 }
 
 

src/vm_system.c

@@ -209,9 +209,9 @@ 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]);
+  VARIABLE_SET (sp[0], sp[-1]);
-  scm_set_object_property_x (sp[1], scm_sym_name, SCM_CAR (sp[0]));
+  scm_set_object_property_x (sp[-1], scm_sym_name, SCM_CAR (sp[0]));
-  sp += 2;
+  sp -= 2;
   NEXT;
 }
 
@@ -279,23 +279,27 @@ VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
 
 VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 {
-  POP (program);
+  SCM x;
   nargs = FETCH ();
+  x = sp[-nargs];
 
  vm_call:
   /*
    * Subprogram call
    */
-  if (SCM_PROGRAM_P (program))
+  if (SCM_PROGRAM_P (x))
     {
-      int i;
+      int i, last;
+
+      program = x;
     vm_call_program:
       CACHE_PROGRAM ();
       INIT_ARGS ();
       NEW_FRAME ();
 
       /* Init local variables */
-      for (i = 0; i < bp->nlocs; i++)
+      last = bp->nargs + bp->nlocs;
+      for (i = bp->nargs; i < last; i++)
 	LOCAL_SET (i, SCM_UNDEFINED);
 
       /* Create external variables */
@@ -309,29 +313,29 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
   /*
    * Function call
    */
-  if (!SCM_FALSEP (scm_procedure_p (program)))
+  if (!SCM_FALSEP (scm_procedure_p (x)))
     {
       POP_LIST (nargs);
-      *sp = scm_apply (program, *sp, SCM_EOL);
+      sp[-1] = scm_apply (x, *sp, SCM_EOL);
-      program = SCM_VM_FRAME_PROGRAM (fp);
+      sp--;
       NEXT;
     }
   /*
    * Continuation call
    */
-  if (SCM_VM_CONT_P (program))
+  if (SCM_VM_CONT_P (x))
     {
     vm_call_cc:
       /* Check the number of arguments */
       if (nargs != 1)
-	scm_wrong_num_args (program);
+	scm_wrong_num_args (x);
 
       /* Reinstate the continuation */
       EXIT_HOOK ();
-      reinstate_vm_cont (vp, program);
+      reinstate_vm_cont (vp, x);
       CACHE_REGISTER ();
-      /* We don't need to set the return value here
+      program = SCM_VM_FRAME_PROGRAM (fp);
-	 because it is already on the top of the stack. */
+      CACHE_PROGRAM ();
       NEXT;
     }
 
@@ -341,8 +345,8 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
 {
   SCM x;
-  POP (x);
   nargs = FETCH ();
+  x = sp[-nargs];
 
   SCM_TICK;	/* allow interrupt here */
 
@@ -357,56 +361,60 @@ VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
       if (bp->nargs)
 	{
 	  int i;
-	  SCM *base = fp + bp->nlocs;
+	  sp -= bp->nargs - 1;
 	  for (i = 0; i < bp->nargs; i++)
-	    base[i] = sp[i];
+	    LOCAL_SET (i, sp[i]);
+	  sp -= 2;
 	}
 
       ip = bp->base;
-      sp = SCM_VM_FRAME_LOWER_ADDRESS (fp);
       APPLY_HOOK ();
       NEXT;
     }
-  program = x;
   /*
    * Proper tail call
    */
-  if (SCM_PROGRAM_P (program))
+  if (SCM_PROGRAM_P (x))
     {
-      int i;
+      SCM *limit = sp;
-      SCM *base = sp;
+      SCM *base  = sp - nargs - 1;
 
       /* Exit the current frame */
       EXIT_HOOK ();
       FREE_FRAME ();
 
       /* Move arguments */
-      sp -= nargs;
+      while (base < limit)
-      for (i = 0; i < nargs; i++)
+	*++sp = *++base;
-	sp[i] = base[i];
 
       /* Call the program */
+      program = x;
       goto vm_call_program;
     }
   /*
    * Function call
    */
-  if (!SCM_FALSEP (scm_procedure_p (program)))
+  if (!SCM_FALSEP (scm_procedure_p (x)))
     {
       POP_LIST (nargs);
-      *sp = scm_apply (program, *sp, SCM_EOL);
+      sp[-1] = scm_apply (x, *sp, SCM_EOL);
-      program = SCM_VM_FRAME_PROGRAM (fp);
+      sp--;
       goto vm_return;
     }
   /*
    * Continuation call
    */
-  if (SCM_VM_CONT_P (program))
+  if (SCM_VM_CONT_P (x))
     goto vm_call_cc;
 
   goto vm_error_wrong_type_apply;
 }
 
+VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
+{
+  
+}
+
 VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
 {
   SYNC_BEFORE_GC ();