summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKeisuke Nishida <kxn30@po.cwru.edu>2001-04-11 20:57:44 +0000
committerKeisuke Nishida <kxn30@po.cwru.edu>2001-04-11 20:57:44 +0000
commit41f248a84ad6c6aa6331733a4d4cbd71c21db1be (patch)
tree33424f63966ec308ef7f6cb8e25a5eb2adbf38bd
parent8710eba09b61ae3ea6db34c4a9f863afb8fd678c (diff)
downloadguile-41f248a84ad6c6aa6331733a4d4cbd71c21db1be.tar.gz
*** empty log message ***
-rw-r--r--module/language/gscheme/spec.scm38
-rw-r--r--module/system/il/compile.scm4
-rw-r--r--module/system/il/glil.scm21
-rw-r--r--module/system/vm/assemble.scm115
-rw-r--r--module/system/vm/conv.scm8
-rw-r--r--module/system/vm/disasm.scm19
-rw-r--r--module/system/vm/load.scm2
-rw-r--r--module/system/vm/trace.scm3
-rw-r--r--src/vm.c35
-rw-r--r--src/vm.h14
-rw-r--r--src/vm_engine.c6
-rw-r--r--src/vm_engine.h22
-rw-r--r--src/vm_loader.c32
-rw-r--r--src/vm_system.c33
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
@@ -28,23 +28,6 @@
;;;
-;;; 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-<glil-branch> 'br-if-not L1))
(comp-tail then)
- (if (not tail) (push-code! (make-<glil-branch> 'jump L2)))
+ (if (not tail) (push-code! (make-<glil-branch> 'br L2)))
(push-code! (make-<glil-label> L1))
(comp-tail else)
(if (not tail) (push-code! (make-<glil-label> 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 @@
(($ <glil-module> op module name)
`(,(symbol-append 'module- op) ,module ,name))
;; controls
- (($ <glil-label> label) `(label ,label))
+ (($ <glil-label> label) label)
(($ <glil-branch> inst label) `(,inst ,label))
(($ <glil-call> 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
(($ <vm-asm> venv)
@@ -108,7 +92,7 @@
(if (venv-closure? venv) (push-code! `(make-closure))))
(($ <glil-void>)
- (push-code! `(void)))
+ (push-code! '(void)))
(($ <glil-const> x)
(push-object! x))
@@ -139,11 +123,14 @@
(push-code! '(variable-set))))
(($ <glil-label> 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))))
(($ <glil-branch> inst label)
- (let ((setter (lambda (addr) (- (label-ref label) addr))))
- (push-code! (list inst setter))))
+ (set! stack (cons (list inst label) stack)))
(($ <glil-call> 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;
}