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 - (($ proc args) + (($ env var val) + (make- env var (optimize val))) + + (($ test then else) + (make- (optimize test) (optimize then) (optimize else))) + + (($ exps) + (make- (map optimize exps))) + + (($ env vars vals body) + (make- env vars (map optimize vals) (optimize body))) + + (($ env vars rest body) + (make- env vars rest (optimize body))) + + (($ inst args) + (make- inst (map optimize args))) + + (($ env proc args) (match proc ;; ((@lambda (VAR...) BODY...) ARG...) => ;; (@let ((VAR ARG) ...) BODY...) - (($ env vars #f body) - (optimize (make- vars args body))) + (($ 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- env vars args body))) (else - (make- (optimize proc) (for-each optimize args))))) + (make- env (optimize proc) (map optimize args))))) (else x))) @@ -144,7 +166,7 @@ (reverse vars)) (comp-tail body)) - (($ vars rest body) + (($ env vars rest body) (return-code! (codegen tree))) (($ inst args) @@ -155,12 +177,12 @@ (if drop (push-code! *ia-drop*)) (if tail (push-code! *ia-return*))) - (($ proc args) - ;; ARGS... + (($ 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- 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 @@ -1 -2 -3 -4 make- ? -1 -2 -3 -4 - make- ? -1 -2 + make- ? -1 -2 -3 make- ? -1 -2 )) @@ -53,8 +53,8 @@ (define-structure ( test then else)) (define-structure ( exps)) (define-structure ( env vars vals body)) -(define-structure ( env args rest body)) -(define-structure ( proc args)) +(define-structure ( env vars rest body)) +(define-structure ( env proc args)) (define-structure ( inst args)) @@ -128,14 +128,13 @@ (define-method (ghil-env-ref (env ) (sym )) (assq-ref env.table sym)) -(define-method (ghil-env-add! (env ) (sym ) 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 ) (var )) + (set! env.table (acons var.name var env.table)) + (set! env.variables (cons var env.variables))) -(define-method (ghil-env-remove! (env ) (sym )) - (set! env.table (assq-remove! env.table sym))) +(define-method (ghil-env-remove! (env ) (var )) + (set! env.table (assq-remove! env.table var.name))) (define-method (ghil-lookup (env ) (sym )) (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- (parse head e) (map-parse tail e))))) + (make- 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- 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- 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- 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- 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 @@ (($ venv ($ 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))))) (($ op index) - (push-code! `(,(symbol-append 'local- op) ,(- nvars index)))) + (push-code! `(,(symbol-append 'local- op) ,index))) (($ op index) - (push-code! `(,(symbol-append 'local- op) - ,(- nvars (+ nargs index))))) + (push-code! `(,(symbol-append 'local- op) ,(+ nargs index)))) (($ 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)))))) (($ 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 ();