summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-07 09:39:38 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-07 09:39:38 +0000
commit3616e9e96305df6aedef5cf508ca0ee9ad71a973 (patch)
treef19087580444eafc3995ea04f74d4d2768a5bd22
parent4bfb26f58fff7b0febef86cbbeb0cc537ccb5c20 (diff)
downloadguile-3616e9e96305df6aedef5cf508ca0ee9ad71a973.tar.gz
*** empty log message ***
-rw-r--r--module/system/base/language.scm2
-rw-r--r--module/system/il/compile.scm38
-rw-r--r--module/system/il/ghil.scm45
-rw-r--r--module/system/il/macros.scm4
-rw-r--r--module/system/repl/command.scm2
-rw-r--r--module/system/vm/assemble.scm12
-rw-r--r--module/system/vm/disasm.scm2
-rw-r--r--module/system/vm/load.scm2
-rw-r--r--module/system/vm/trace.scm4
-rw-r--r--src/vm.c117
-rw-r--r--src/vm.h58
-rw-r--r--src/vm_engine.c3
-rw-r--r--src/vm_engine.h59
-rw-r--r--src/vm_expand.h6
-rw-r--r--src/vm_loader.c28
-rw-r--r--src/vm_scheme.c3
-rw-r--r--src/vm_system.c68
17 files changed, 248 insertions, 205 deletions
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 835e7a522..e5588b314 100644
--- a/module/system/base/language.scm
+++ b/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)))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index a04ee00cb..a107f8216 100644
--- a/module/system/il/compile.scm
+++ b/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)
- (optimize (make-<ghil-bind> vars args body)))
+ (($ <ghil-lambda> lambda-env vars #f 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)
- ;; ARGS...
+ (($ <ghil-call> env proc 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*)))))
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 91c4ad505..470960a8b 100644
--- a/module/system/il/ghil.scm
+++ b/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-call> proc args))
+(define-structure (<ghil-lambda> env vars rest body))
+(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)
- (let ((var (make-ghil-var env sym kind)))
- (set! env.table (acons sym var env.table))
- (set! env.variables (cons var env.variables))
- var))
+(export ghil-env-add!)
+(define-method (ghil-env-add! (env <ghil-env>) (var <ghil-var>))
+ (set! env.table (acons var.name var env.table))
+ (set! env.variables (cons var env.variables)))
-(define-method (ghil-env-remove! (env <ghil-env>) (sym <symbol>))
- (set! env.table (assq-remove! env.table sym)))
+(define-method (ghil-env-remove! (env <ghil-env>) (var <ghil-var>))
+ (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)))
- (make-<ghil-lambda> e args rest (parse-body body e)))))))
+ (vars (map (lambda (s)
+ (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))))
diff --git a/module/system/il/macros.scm b/module/system/il/macros.scm
index 3f2acf888..b5ee342bb 100644
--- a/module/system/il/macros.scm
+++ b/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))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 9991b571d..9a0e4329e 100644
--- a/module/system/repl/command.scm
+++ b/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))
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index bda7490a1..b7e9e19b2 100644
--- a/module/system/vm/assemble.scm
+++ b/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 '())
- (nvars (+ nargs nlocs -1)))
+ (object-alist '()))
(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)
- ,(- nvars (+ nargs index)))))
+ (push-code! `(,(symbol-append 'local- op) ,(+ 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)))
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index bad1166a4..09fcfef29 100644
--- a/module/system/vm/disasm.scm
+++ b/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)
diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm
index c4b99980d..8609d4b96 100644
--- a/module/system/vm/load.scm
+++ b/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)))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index a98e5478a..b703791a7 100644
--- a/module/system/vm/trace.scm
+++ b/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))))
diff --git a/src/vm.c b/src/vm.c
index 4aae67880..5896ed5c3 100644
--- a/src/vm.c
+++ b/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_debug_frame *p;
-
- if (!fp)
- return SCM_BOOL_F;
-
- p = scm_must_malloc (sizeof (struct scm_vm_debug_frame), "make_vm_debug_frame");
- 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);
+ struct scm_vm_heap_frame *p =
+ scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame");
+ p->fp = fp;
+ p->program = SCM_UNDEFINED;
+ p->variables = SCM_UNDEFINED;
+ p->dynamic_link = SCM_UNDEFINED;
+ SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_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));
- scm_gc_mark (SCM_VM_DEBUG_FRAME_VARIABLES (obj));
- return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (obj);
+ struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj);
+ scm_gc_mark (p->program);
+ 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);
- return SCM_VM_DEBUG_FRAME_PROGRAM (frame);
+ SCM_VALIDATE_VM_HEAP_FRAME (1, 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);
- return SCM_VM_DEBUG_FRAME_VARIABLES (frame);
+ struct scm_vm_heap_frame *p;
+
+ 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);
- return SCM_VM_DEBUG_FRAME_DYNAMIC_LINK (frame);
+ struct scm_vm_heap_frame *p;
+
+ 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,10 +276,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;
- vp->ip = NULL;
- vp->sp = vp->stack_limit;
- vp->fp = NULL;
+ vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+ vp->ip = NULL;
+ vp->sp = vp->stack_base - 1;
+ vp->fp = NULL;
vp->time = 0;
vp->clock = 0;
vp->options = SCM_EOL;
@@ -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 */
- scm_gc_mark (SCM_VM_FRAME_PROGRAM (fp));
- /* Mark frame variables */
- for (sp = fp; sp < upper; sp++)
+ fp = SCM_VM_STACK_ADDRESS (*sp); /* dynamic link */
+ /* Mark frame variables + program */
+ for (sp -= 2; sp >= lower; 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 list = SCM_EOL;
+ SCM *sp;
+ SCM ls = SCM_EOL;
+ struct scm_vm *vp;
SCM_VALIDATE_VM (1, vm);
VM_CHECK_RUNNING (vm);
- if (SCM_VM_DATA (vm)->fp)
- for (p = SCM_VM_FRAME_LOWER_ADDRESS (SCM_VM_DATA (vm)->fp) - 1;
- p >= SCM_VM_DATA (vm)->sp;
- p--)
- list = scm_cons (*p, list);
- return list;
+ vp = SCM_VM_DATA (vm);
+ for (sp = SCM_VM_FRAME_UPPER_ADDRESS (vp->fp); sp <= vp->sp; sp++)
+ ls = scm_cons (*sp, ls);
+ return ls;
}
#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_set_smob_mark (scm_tc16_vm_debug_frame, vm_debug_frame_mark);
+ scm_tc16_vm_heap_frame = scm_make_smob_type ("vm_frame", 0);
+ 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);
diff --git a/src/vm.h b/src/vm.h
index 3e5e65518..23d13ecc6 100644
--- a/src/vm.h
+++ b/src/vm.h
@@ -50,62 +50,62 @@
* VM Address
*/
-#define SCM_VM_MAKE_FRAME_ADDRESS(ptr) SCM_PACK (ptr)
-#define SCM_VM_FRAME_ADDRESS(addr) ((SCM *) SCM_UNPACK (addr))
+#define SCM_VM_MAKE_STACK_ADDRESS(ptr) SCM_PACK (ptr)
+#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_DATA_SIZE 3
-#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) \
+#define SCM_VM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
+#define SCM_VM_FRAME_DATA_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) \
- (fp - SCM_VM_FRAME_DATA_SIZE)
+#define SCM_VM_FRAME_UPPER_ADDRESS(fp) \
+ (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_DEBUG_FRAME_DATA(f) ((struct scm_vm_debug_frame *) SCM_SMOB_DATA (f))
-#define SCM_VALIDATE_VM_DEBUG_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_DEBUG_FRAME_P)
+#define SCM_VM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_heap_frame, x)
+#define SCM_VM_HEAP_FRAME_DATA(f) ((struct scm_vm_heap_frame *) SCM_SMOB_DATA (f))
+#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_DEBUG_FRAME_VARIABLES(f) SCM_VM_DEBUG_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_PROGRAM(f) SCM_VM_HEAP_FRAME_DATA (f)->program
+#define SCM_VM_HEAP_FRAME_VARIABLES(f) SCM_VM_HEAP_FRAME_DATA (f)->variables
+#define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link
/*
* VM
diff --git a/src/vm_engine.c b/src/vm_engine.c
index dc56af7a0..bd256ca70 100644
--- a/src/vm_engine.c
+++ b/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! */
diff --git a/src/vm_engine.h b/src/vm_engine.h
index feff9ba22..6bcf68655 100644
--- a/src/vm_engine.h
+++ b/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 DROP() do { CHECK_UNDERFLOW (); sp++; } while (0)
+#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } 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; \
- *sp = l; \
+ PUSH (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 ARGS3(a1,a2,a3) SCM a1 = sp[2], a2 = sp[1], a3 = sp[0]; sp += 2;
+#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 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"
diff --git a/src/vm_expand.h b/src/vm_expand.h
index e788d244d..cdbc8cd1d 100644
--- a/src/vm_expand.h
+++ b/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 */
diff --git a/src/vm_loader.c b/src/vm_loader.c
index 558997232..6548d5a10 100644
--- a/src/vm_loader.c
+++ b/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]);
- 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 -= 4;
+ SCM_PROGRAM_NARGS (prog) = SCM_INUM (sp[1]);
+ SCM_PROGRAM_NREST (prog) = SCM_INUM (sp[2]);
+ SCM_PROGRAM_NLOCS (prog) = SCM_INUM (sp[3]);
+ 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);
- DROP ();
+ sp--;
+ *sp = scm_c_env_vcell (sp[0], sp[1], 1);
NEXT;
}
diff --git a/src/vm_scheme.c b/src/vm_scheme.c
index 019f65936..d4a5570de 100644
--- a/src/vm_scheme.c
+++ b/src/vm_scheme.c
@@ -169,8 +169,7 @@ VM_DEFINE_FUNCTION (vector, "vector", -1)
{
ARGSN (n);
POP_LIST (n);
- *sp = scm_vector (*sp);
- NEXT;
+ RETURN (scm_vector (*sp));
}
diff --git a/src/vm_system.c b/src/vm_system.c
index 6398f4e02..36e84feb5 100644
--- a/src/vm_system.c
+++ b/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]);
- scm_set_object_property_x (sp[1], scm_sym_name, SCM_CAR (sp[0]));
- sp += 2;
+ VARIABLE_SET (sp[0], sp[-1]);
+ scm_set_object_property_x (sp[-1], scm_sym_name, SCM_CAR (sp[0]));
+ 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);
- program = SCM_VM_FRAME_PROGRAM (fp);
+ sp[-1] = scm_apply (x, *sp, SCM_EOL);
+ 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
- because it is already on the top of the stack. */
+ program = SCM_VM_FRAME_PROGRAM (fp);
+ 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 *base = sp;
+ SCM *limit = sp;
+ SCM *base = sp - nargs - 1;
/* Exit the current frame */
EXIT_HOOK ();
FREE_FRAME ();
/* Move arguments */
- sp -= nargs;
- for (i = 0; i < nargs; i++)
- sp[i] = base[i];
+ while (base < limit)
+ *++sp = *++base;
/* 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);
- program = SCM_VM_FRAME_PROGRAM (fp);
+ sp[-1] = scm_apply (x, *sp, SCM_EOL);
+ 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 ();