From 41f248a84ad6c6aa6331733a4d4cbd71c21db1be Mon Sep 17 00:00:00 2001 From: Keisuke Nishida Date: Wed, 11 Apr 2001 20:57:44 +0000 Subject: [PATCH] *** empty log message *** --- module/language/gscheme/spec.scm | 38 +++++----- module/system/il/compile.scm | 4 +- module/system/il/glil.scm | 21 +++--- module/system/vm/assemble.scm | 115 ++++++++----------------------- module/system/vm/conv.scm | 8 +-- module/system/vm/disasm.scm | 19 ++++- module/system/vm/load.scm | 2 +- module/system/vm/trace.scm | 3 +- src/vm.c | 35 +++++++--- src/vm.h | 14 ++-- src/vm_engine.c | 6 +- src/vm_engine.h | 22 ++++-- src/vm_loader.c | 32 ++++----- src/vm_system.c | 33 +++++---- 14 files changed, 168 insertions(+), 184 deletions(-) diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm index 5e9facd88..17c36664b 100644 --- a/module/language/gscheme/spec.scm +++ b/module/language/gscheme/spec.scm @@ -26,23 +26,6 @@ :use-module (ice-9 and-let-star) :export (gscheme)) - -;;; -;;; Macro expander -;;; - -(define (expand x) - (expand-macro x (current-module))) - -(define (expand-macro x m) - (if (pair? x) - (let* ((s (car x)) - (v (and (symbol? s) (module-defined? m s) (module-ref m s)))) - (if (defmacro? v) - (expand-macro (apply (defmacro-transformer v) (cdr x)) m) - (cons (expand-macro (car x) m) (expand-macro (cdr x) m)))) - x)) - ;;; ;;; Translator @@ -111,10 +94,22 @@ (_loop ,@(map translate update))))))) (_loop ,@(map translate init)))))) (else - (let ((prim (and (symbol? head) (symbol-append '@ head)))) - (if (and prim (ghil-primitive? prim)) - (cons prim (map translate rest)) - (cons (translate head) (map translate rest)))))))) + (let ((e (expand x))) + (if (eq? e x) + (let ((prim (and (symbol? head) (symbol-append '@ head)))) + (if (and prim (ghil-primitive? prim)) + (cons prim (map translate rest)) + (cons (translate head) (map translate rest)))) + (translate e))))))) + +(define (expand x) + (if (and (symbol? (car x)) + (module-defined? (current-module) (car x))) + (let ((v (module-ref (current-module) (car x)))) + (if (defmacro? v) + (apply (defmacro-transformer v) (cdr x)) + x)) + x)) ;;; @@ -125,7 +120,6 @@ :title "Guile Scheme" :version "0.4" :reader read - :expander expand :translator translate :printer write ) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 341b90659..0f95b7a69 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -136,14 +136,14 @@ ;; TEST ;; (br-if-not L1) ;; THEN - ;; (jump L2) + ;; (br L2) ;; L1: ELSE ;; L2: (let ((L1 (make-label)) (L2 (make-label))) (comp-push test) (push-code! (make- 'br-if-not L1)) (comp-tail then) - (if (not tail) (push-code! (make- 'jump L2))) + (if (not tail) (push-code! (make- 'br L2))) (push-code! (make- L1)) (comp-tail else) (if (not tail) (push-code! (make- L2))))) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index c54509d12..cd2865fff 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -156,7 +156,7 @@ (($ op module name) `(,(symbol-append 'module- op) ,module ,name)) ;; controls - (($ label) `(label ,label)) + (($ label) label) (($ inst label) `(,inst ,label)) (($ inst nargs) `(,inst ,nargs)))) @@ -168,14 +168,13 @@ (define (pprint-glil glil) (let print ((code (unparse glil)) (column 0)) (display (make-string column #\space)) - (case (car code) - ((@asm) - (format #t "(@asm ~A\n" (cadr code)) - (let ((col (+ column 2))) - (let loop ((l (cddr code))) - (print (car l) col) - (if (null? (cdr l)) - (display ")") - (begin (newline) (loop (cdr l))))))) - (else (write code)))) + (cond ((and (pair? code) (eq? (car code) '@asm)) + (format #t "(@asm ~A\n" (cadr code)) + (let ((col (+ column 2))) + (let loop ((l (cddr code))) + (print (car l) col) + (if (null? (cdr l)) + (display ")") + (begin (newline) (loop (cdr l))))))) + (else (write code)))) (newline)) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index c36175872..4178f9407 100644 --- a/module/system/vm/assemble.scm +++ b/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 nexts bytes objs)) +(define-structure (bytespec nargs nrest nlocs nexts bytes objs closure?)) ;;; @@ -74,33 +74,17 @@ (label-alist '()) (object-alist '())) (define (push-code! code) - (set! stack (optimizing-push code stack))) + (set! stack (cons (code->bytes code) stack))) (define (push-object! x) (cond ((object->code x) => push-code!) - (toplevel - ;; top-level object-dump - (cond ((object-assoc x object-alist) => - (lambda (obj+index) - (cond ((not (cdr obj+index)) - (set-cdr! obj+index nlocs) - (set! nlocs (+ nlocs 1)))) - (push-code! `(local-ref ,(cdr obj+index))))) - (else - (set! object-alist (acons x #f object-alist)) - (push-code! `(object-dump ,x))))) + (toplevel (dump-object! push-code! x)) (else - ;; local object-ref (let ((i (cond ((object-assoc x object-alist) => cdr) (else (let ((i (length object-alist))) (set! object-alist (acons x i object-alist)) i))))) (push-code! `(object-ref ,i)))))) - (define (label-ref key) - (assq-ref label-alist key)) - (define (label-set key) - (let ((addr (apply + (map length stack)))) - (set! label-alist (assq-set! label-alist key addr)))) (define (generate-code x) (match x (($ venv) @@ -108,7 +92,7 @@ (if (venv-closure? venv) (push-code! `(make-closure)))) (($ ) - (push-code! `(void))) + (push-code! '(void))) (($ x) (push-object! x)) @@ -139,11 +123,14 @@ (push-code! '(variable-set)))) (($ label) - (label-set label)) + (define (byte-length x) + (cond ((string? x) (string-length x)) + (else 3))) + (let ((addr (apply + (map byte-length stack)))) + (set! label-alist (assq-set! label-alist label addr)))) (($ inst label) - (let ((setter (lambda (addr) (- (label-ref label) addr)))) - (push-code! (list inst setter)))) + (set! stack (cons (list inst label) stack))) (($ inst nargs) (if (instruction? inst) @@ -158,73 +145,31 @@ ;; ;; main (for-each generate-code body) - (if toplevel - ;; top-level - (let ((new '())) - (define (push-code! x) - (set! new (cons x new))) - (do ((stack (reverse! stack) (cdr stack))) - ((null? stack) - (make-dumpcode nlocs nexts (stack->bytes (reverse! new)))) - (if (eq? (caar stack) 'object-dump) - (let ((x (cadar stack))) - (dump-object! push-code! x) - (cond ((object-assoc x object-alist) => - (lambda (obj+index) - (cond ((cdr obj+index) => - (lambda (n) - (push-code! '(dup)) - (push-code! `(local-set ,n))))))))) - (push-code! (car stack))))) - ;; closures - (let ((bytes (stack->bytes (reverse! stack))) - (objs (map car (reverse! object-alist)))) - (make-bytespec nargs nrest nlocs nexts bytes objs))))))) + (let ((bytes (stack->bytes (reverse! stack) label-alist))) + (if toplevel + (make-dumpcode nlocs nexts bytes) + (let ((objs (map car (reverse! object-alist)))) + (make-bytespec nargs nrest nlocs nexts bytes objs + (venv-closure? venv))))))))) (define (object-assoc x alist) (if (vlink? x) (assoc x alist) (assq x alist))) -(define (stack->bytes stack) +(define (stack->bytes stack label-alist) (let loop ((result '()) (stack stack) (addr 0)) (if (null? stack) (apply string-append (reverse! result)) - (let* ((orig (car stack)) - (addr (+ addr (length orig))) - (code (if (and (pair? (cdr orig)) (procedure? (cadr orig))) - `(,(car orig) ,((cadr orig) addr)) - orig))) - (loop (cons (code->bytes code) result) (cdr stack) addr))))) - - -;;; -;;; Bytecode optimization -;;; - -(define *optimization-table* - '((not (not . not-not) - (eq? . not-eq?) - (null? . not-null?) - (not-not . not) - (not-eq? . eq?) - (not-null? . null?)) - (br-if (not . br-if-not) - (eq? . br-if-eq) - (null? . br-if-null) - (not-not . br-if) - (not-eq? . br-if-not-eq) - (not-null? . br-if-not-null)) - (br-if-not (not . br-if) - (eq? . br-if-not-eq) - (null? . br-if-not-null) - (not-not . br-if-not) - (not-eq? . br-if-eq) - (not-null? . br-if-null)))) - -(define (optimizing-push code stack) - (let ((alist (assq-ref *optimization-table* (car code)))) - (cond ((and alist (pair? stack) (assq-ref alist (caar stack))) => - (lambda (inst) (cons (cons inst (cdr code)) (cdr stack)))) - (else (cons (code-pack code) stack))))) + (let ((bytes (car stack))) + (if (pair? bytes) + (let* ((offset (- (assq-ref label-alist (cadr bytes)) + (+ addr 3))) + (n (if (< offset 0) (+ offset 65536) offset))) + (set! bytes (code->bytes (list (car bytes) + (quotient n 256) + (modulo n 256)))))) + (loop (cons bytes result) + (cdr stack) + (+ addr (string-length bytes))))))) ;;; @@ -239,7 +184,7 @@ ((object->code x) => push-code!) ((bytespec? x) (match x - (($ bytespec nargs nrest nlocs nexts bytes objs) + (($ bytespec nargs nrest nlocs nexts bytes objs closure?) ;; dump parameters (cond ((and (< nargs 4) (< nlocs 8) (< nexts 4)) @@ -264,7 +209,7 @@ ;; dump bytecode (push-code! `(load-program ,bytes))))) ((vlink? x) - (dump! (vlink-module x)) + ;;; (dump! (vlink-module x)) ;; FIXME: no module support now (dump! (vlink-name x)) (push-code! `(link))) ((vmod? x) diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm index 1151dc2b9..bcb6a339d 100644 --- a/module/system/vm/conv.scm +++ b/module/system/vm/conv.scm @@ -36,11 +36,6 @@ (cond ((< n 10) (let ((abbrev (string->symbol (format #f "~A:~A" inst n)))) (if (instruction? abbrev) (list abbrev) code))) - ((> n 255) - (let ((double (string->symbol (format #f "~A*2" inst)))) - (if (instruction? double) - (list double (quotient n 256) (modulo n 256)) - (apply error "Index out of range:" code)))) (else code))) (else code))) @@ -91,7 +86,8 @@ (else #f))) (define (code->bytes code) - (let* ((inst (car code)) + (let* ((code (code-pack code)) + (inst (car code)) (rest (cdr code)) (head (make-string 1 (integer->char (instruction->opcode inst)))) (len (instruction-length inst))) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 7c6df92ff..0ab0a83d7 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -44,7 +44,8 @@ (nlocs (caddr arity)) (nexts (cadddr arity)) (bytes (program-bytecode prog)) - (objs (program-objects prog))) + (objs (program-objects prog)) + (exts (program-external prog))) ;; Disassemble this bytecode (format #t "Disassembly of ~A:\n\n" prog) (format #t "nargs = ~A nrest = ~A nlocs = ~A nexts = ~A\n\n" @@ -53,6 +54,8 @@ (disassemble-bytecode bytes objs) (if (> (vector-length objs) 0) (disassemble-objects objs)) + (if (pair? exts) + (disassemble-externals exts)) ;; Disassemble other bytecode in it (for-each (lambda (x) @@ -89,6 +92,15 @@ (let ((info (object->string (vector-ref objs n)))) (print-info n info #f))))) +(define (disassemble-externals exts) + (display "Externals:\n\n") + (let ((len (length exts))) + (do ((n 0 (1+ n)) + (l exts (cdr l))) + ((null? l) (newline)) + (let ((info (object->string (car l)))) + (print-info n info #f))))) + (define (disassemble-meta meta) (display "Meta info:\n\n") (for-each (lambda (data) @@ -98,11 +110,12 @@ (define (original-value addr code objs) (define (branch-code? code) - (string-match "^(br|jump)" (symbol->string (car code)))) + (string-match "^br" (symbol->string (car code)))) (let ((code (code-unpack code))) (cond ((code->object code) => object->string) ((branch-code? code) - (format #f "-> ~A" (+ addr (cadr code) 2))) + (let ((offset (+ (* (cadr code) 256) (caddr code)))) + (format #f "-> ~A" (+ addr offset 3)))) (else (let ((inst (car code)) (args (cdr code))) (case inst diff --git a/module/system/vm/load.scm b/module/system/vm/load.scm index 6214cc95a..d10a5dd7f 100644 --- a/module/system/vm/load.scm +++ b/module/system/vm/load.scm @@ -20,8 +20,8 @@ ;;; Code: (define-module (system vm load) - :use-module (system vm core) :autoload (system base language) (compile-file-in lookup-language) + :use-module (system vm core) :use-module (ice-9 regex) :export (load/compile)) diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm index 588671222..e3e524c2d 100644 --- a/module/system/vm/trace.scm +++ b/module/system/vm/trace.scm @@ -20,6 +20,7 @@ ;;; Code: (define-module (system vm trace) + :use-syntax (system base syntax) :use-module (system vm core) :use-module (system vm frame) :use-module (ice-9 format) @@ -49,7 +50,7 @@ (case (car opts) ((:s) (format #t "~20S" (vm-fetch-stack vm))) ((:v) (format #t "~20S" (frame-variables frame))) - ((:e) (format #t "~20S" (program-external (frame-program frame)))))))) + ((:e) (format #t "~20A" (object->string (frame-external-link frame)))))))) (define (trace-apply vm) (if (vm-option vm 'trace-first) diff --git a/src/vm.c b/src/vm.c index c336744c3..ff2ea09df 100644 --- a/src/vm.c +++ b/src/vm.c @@ -64,10 +64,11 @@ make_vm_heap_frame (SCM *fp) { 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; + p->fp = fp; + p->program = SCM_UNDEFINED; + p->variables = SCM_UNDEFINED; + p->dynamic_link = SCM_UNDEFINED; + p->external_link = SCM_UNDEFINED; SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p); } @@ -77,7 +78,8 @@ vm_heap_frame_mark (SCM 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; + scm_gc_mark (p->dynamic_link); + return p->external_link; } /* Scheme interface */ @@ -146,6 +148,23 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_external_link +{ + struct scm_vm_heap_frame *p; + + SCM_VALIDATE_VM_HEAP_FRAME (1, frame); + p = SCM_VM_HEAP_FRAME_DATA (frame); + + if (SCM_UNBNDP (p->external_link)) + p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (p->fp); + + return p->external_link; +} +#undef FUNC_NAME + /* * VM Continuation @@ -213,7 +232,7 @@ vm_cont_free (SCM obj) * VM Internal functions */ -SCM_SYMBOL (sym_vm_engine, "vm-engine"); +SCM_SYMBOL (sym_vm_run, "vm-run"); SCM_SYMBOL (sym_vm_error, "vm-error"); static scm_byte_t * @@ -307,7 +326,7 @@ vm_mark (SCM obj) for (; sp >= upper; sp--) if (SCM_NIMP (*sp)) scm_gc_mark (*sp); - fp = SCM_VM_STACK_ADDRESS (*sp); /* dynamic link */ + fp = SCM_VM_STACK_ADDRESS (sp[-1]); /* dynamic link */ /* Mark frame variables + program */ for (sp -= 2; sp >= lower; sp--) if (SCM_NIMP (*sp)) @@ -337,7 +356,7 @@ scm_vm_apply (SCM vm, SCM program, SCM args) #define FUNC_NAME "scm_vm_apply" { SCM_VALIDATE_PROGRAM (1, program); - return vm_engine (vm, program, args); + return vm_run (vm, program, args); } #undef FUNC_NAME diff --git a/src/vm.h b/src/vm.h index f98cc772d..ffc289db3 100644 --- a/src/vm.h +++ b/src/vm.h @@ -61,10 +61,11 @@ */ /* - | | <- fp + bp->nargs + bp->nlocs + 2 + | | <- fp + bp->nargs + bp->nlocs + 3 +------------------+ = SCM_VM_FRAME_UPPER_ADDRESS (fp) + | Return address | | Dynamic link | - | Return address | <- fp + bp->nargs + bp->nlocs + | External link | <- fp + bp->nargs + bp->nlocs | Local varialbe 1 | = SCM_VM_FRAME_DATA_ADDRESS (fp) | Local variable 0 | <- fp + bp->nargs | Argument 1 | @@ -74,15 +75,16 @@ | | */ -#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_UPPER_ADDRESS(fp) \ - (SCM_VM_FRAME_DATA_ADDRESS (fp) + 2) + (SCM_VM_FRAME_DATA_ADDRESS (fp) + 3) +#define SCM_VM_FRAME_LOWER_ADDRESS(fp) (fp - 1) +#define SCM_VM_FRAME_RETURN_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)[0] +#define SCM_VM_FRAME_EXTERNAL_LINK(fp) SCM_VM_FRAME_DATA_ADDRESS (fp)[0] #define SCM_VM_FRAME_VARIABLE(fp,i) fp[i] #define SCM_VM_FRAME_PROGRAM(fp) fp[-1] @@ -95,6 +97,7 @@ struct scm_vm_heap_frame { SCM program; SCM variables; SCM dynamic_link; + SCM external_link; }; extern scm_bits_t scm_tc16_vm_heap_frame; @@ -106,6 +109,7 @@ extern scm_bits_t scm_tc16_vm_heap_frame; #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 +#define SCM_VM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->external_link /* * VM diff --git a/src/vm_engine.c b/src/vm_engine.c index 6629f2af7..1d6b53037 100644 --- a/src/vm_engine.c +++ b/src/vm_engine.c @@ -44,7 +44,7 @@ #include "vm_engine.h" static SCM -vm_engine (SCM vm, SCM program, SCM args) +vm_run (SCM vm, SCM program, SCM args) #define FUNC_NAME "vm-engine" { /* VM registers */ @@ -55,7 +55,7 @@ vm_engine (SCM vm, SCM program, SCM args) /* Cache variables */ struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */ struct scm_program *bp = NULL; /* program base pointer */ - SCM external; /* external environment */ + SCM external = SCM_EOL; /* external environment */ SCM *objects = NULL; /* constant objects */ SCM *stack_base = vp->stack_base; /* stack base address */ SCM *stack_limit = vp->stack_limit; /* stack limit address */ @@ -161,7 +161,7 @@ vm_engine (SCM vm, SCM program, SCM args) vm_error: SYNC_ALL (); scm_ithrow (sym_vm_error, - SCM_LIST4 (sym_vm_engine, err_msg, err_args, + SCM_LIST4 (sym_vm_run, err_msg, err_args, scm_vm_current_frame (vm)), 1); } diff --git a/src/vm_engine.h b/src/vm_engine.h index 0d31dab26..40f7d204a 100644 --- a/src/vm_engine.h +++ b/src/vm_engine.h @@ -132,8 +132,17 @@ #define CACHE_PROGRAM() \ { \ bp = SCM_PROGRAM_DATA (program); \ - objects = SCM_VELTS (bp->objs); \ - external = bp->external; \ + objects = SCM_VELTS (bp->objs); \ +} + +#define CACHE_EXTERNAL() \ +{ \ + external = fp[bp->nargs + bp->nlocs]; \ +} + +#define SYNC_EXTERNAL() \ +{ \ + fp[bp->nargs + bp->nlocs] = external; \ } #define SYNC_BEFORE_GC() \ @@ -280,17 +289,18 @@ do { \ SCM dl = SCM_VM_MAKE_STACK_ADDRESS (fp); \ ip = bp->base; \ fp = sp - bp->nargs + 1; \ - sp = sp + bp->nlocs + 2; \ + sp = sp + bp->nlocs + 3; \ CHECK_OVERFLOW (); \ - sp[0] = dl; \ - sp[-1] = ra; \ + sp[0] = ra; \ + sp[-1] = dl; \ + sp[-2] = bp->external; \ } #define FREE_FRAME() \ { \ SCM *new_sp = fp - 2; \ sp = fp + bp->nargs + bp->nlocs; \ - ip = SCM_VM_BYTE_ADDRESS (sp[0]); \ + ip = SCM_VM_BYTE_ADDRESS (sp[2]); \ fp = SCM_VM_STACK_ADDRESS (sp[1]); \ sp = new_sp; \ } diff --git a/src/vm_loader.c b/src/vm_loader.c index f0a501f2d..0767cd457 100644 --- a/src/vm_loader.c +++ b/src/vm_loader.c @@ -159,25 +159,21 @@ VM_DEFINE_LOADER (load_program, "load-program") NEXT; } -VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1) +VM_DEFINE_INSTRUCTION (link, "link", 0, 1, 1) { - if (!SCM_FALSEP (sp[-1])) - { - sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1); - sp--; - } - else - { - /* Temporary hack that supports the current module system */ - SCM mod = scm_current_module (); - SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), - *sp, SCM_BOOL_F); - if (SCM_FALSEP (var)) - /* Create a new variable if not defined yet */ - var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), - *sp, SCM_BOOL_T); - *--sp = SCM_VARVCELL (var); - } +#if 0 + sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1); + sp--; +#endif + /* Temporary hack that supports the current module system */ + SCM mod = scm_current_module (); + SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), + *sp, SCM_BOOL_F); + if (SCM_FALSEP (var)) + /* Create a new variable if not defined yet */ + var = scm_eval_closure_lookup (scm_standard_eval_closure (mod), + *sp, SCM_BOOL_T); + *sp = SCM_VARVCELL (var); NEXT; } diff --git a/src/vm_system.c b/src/vm_system.c index ba31f74ae..4e15485e4 100644 --- a/src/vm_system.c +++ b/src/vm_system.c @@ -223,49 +223,53 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0) #define BR(p) \ { \ - signed char offset = FETCH (); \ + int h = FETCH (); \ + int l = FETCH (); \ + signed short offset = (h << 8) + l; \ if (p) \ ip += offset; \ DROP (); \ NEXT; \ } -VM_DEFINE_INSTRUCTION (br_if, "br-if", 1, 0, 0) +VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0) +{ + int h = FETCH (); + int l = FETCH (); + ip += (signed short) (h << 8) + l; + NEXT; +} + +VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0) { BR (!SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1, 0, 0) +VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0) { BR (SCM_FALSEP (*sp)); } -VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1, 0, 0) +VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0) { BR (SCM_EQ_P (sp[0], sp--[1])); } -VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1, 0, 0) +VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0) { BR (!SCM_EQ_P (sp[0], sp--[1])); } -VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1, 0, 0) +VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0) { BR (SCM_NULLP (*sp)); } -VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1, 0, 0) +VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0) { BR (!SCM_NULLP (*sp)); } -VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0) -{ - ip += (signed char) FETCH (); - NEXT; -} - /* * Subprogram call @@ -305,8 +309,10 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1) LOCAL_SET (i, SCM_UNDEFINED); /* Create external variables */ + CACHE_EXTERNAL (); for (i = 0; i < bp->nexts; i++) CONS (external, SCM_UNDEFINED, external); + SYNC_EXTERNAL (); ENTER_HOOK (); APPLY_HOOK (); @@ -454,6 +460,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1) /* Restore the last program */ program = SCM_VM_FRAME_PROGRAM (fp); CACHE_PROGRAM (); + CACHE_EXTERNAL (); PUSH (ret); NEXT; }