diff options
-rw-r--r-- | libguile/vm-engine.c | 4 | ||||
-rw-r--r-- | libguile/vm-i-loader.c | 28 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 76 | ||||
-rw-r--r-- | module/language/scheme/translate.scm | 24 | ||||
-rw-r--r-- | module/system/il/compile.scm | 3 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 14 | ||||
-rw-r--r-- | module/system/il/glil.scm | 6 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 40 |
8 files changed, 164 insertions, 31 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 7a6e30e99..86b19de54 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -182,6 +182,10 @@ vm_run (SCM vm, SCM program, SCM args) err_args = SCM_EOL; goto vm_error; + vm_error_no_such_module: + err_msg = scm_from_locale_string ("VM: No such module: ~A"); + goto vm_error; + #if VM_CHECK_IP vm_error_invalid_address: err_msg = scm_from_locale_string ("VM: Invalid program address"); diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c index 34d1cec92..72436f0d5 100644 --- a/libguile/vm-i-loader.c +++ b/libguile/vm-i-loader.c @@ -165,10 +165,32 @@ VM_DEFINE_LOADER (load_program, "load-program") VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1) { - SCM sym; - POP (sym); + SCM what; + POP (what); SYNC_REGISTER (); - PUSH (scm_lookup (sym)); /* might longjmp */ + if (SCM_LIKELY (SCM_SYMBOLP (what))) + { + PUSH (scm_lookup (what)); /* might longjmp */ + } + else + { + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + { + err_args = SCM_LIST1 (SCM_CAR (what)); + goto vm_error_no_such_module; + } + /* might longjmp */ + PUSH (scm_module_lookup (mod, SCM_CADR (what))); + } + NEXT; } diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 16899cc59..87d3a533a 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -285,33 +285,51 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1) VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1) { unsigned objnum = FETCH (); - SCM sym_or_var; + SCM what; CHECK_OBJECT (objnum); - sym_or_var = OBJECT_REF (objnum); + what = OBJECT_REF (objnum); - if (!SCM_VARIABLEP (sym_or_var)) + if (!SCM_VARIABLEP (what)) { SYNC_REGISTER (); - if (SCM_LIKELY (scm_module_system_booted_p && SCM_NFALSEP (bp->module))) + if (SCM_LIKELY (SCM_SYMBOLP (what))) { - /* might longjmp */ - sym_or_var = scm_module_lookup (bp->module, sym_or_var); + if (SCM_LIKELY (scm_module_system_booted_p + && scm_is_true (bp->module))) + /* might longjmp */ + what = scm_module_lookup (bp->module, what); + else + what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); } else { - sym_or_var = scm_sym2var (sym_or_var, SCM_BOOL_F, SCM_BOOL_F); + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + { + err_args = SCM_LIST1 (mod); + goto vm_error_no_such_module; + } + /* might longjmp */ + what = scm_module_lookup (mod, SCM_CADR (what)); } - if (!VARIABLE_BOUNDP (sym_or_var)) + if (!VARIABLE_BOUNDP (what)) { - err_args = SCM_LIST1 (sym_or_var); + err_args = SCM_LIST1 (what); goto vm_error_unbound; } - OBJECT_SET (objnum, sym_or_var); + OBJECT_SET (objnum, what); } - PUSH (VARIABLE_REF (sym_or_var)); + PUSH (VARIABLE_REF (what)); NEXT; } @@ -349,27 +367,45 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0) VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0) { unsigned objnum = FETCH (); - SCM sym_or_var; + SCM what; CHECK_OBJECT (objnum); - sym_or_var = OBJECT_REF (objnum); + what = OBJECT_REF (objnum); - if (!SCM_VARIABLEP (sym_or_var)) + if (!SCM_VARIABLEP (what)) { SYNC_BEFORE_GC (); - if (SCM_LIKELY (scm_module_system_booted_p && SCM_NFALSEP (bp->module))) + if (SCM_LIKELY (SCM_SYMBOLP (what))) { - /* might longjmp */ - sym_or_var = scm_module_lookup (bp->module, sym_or_var); + if (SCM_LIKELY (scm_module_system_booted_p + && scm_is_true (bp->module))) + /* might longjmp */ + what = scm_module_lookup (bp->module, what); + else + what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F); } else { - sym_or_var = scm_sym2var (sym_or_var, SCM_BOOL_F, SCM_BOOL_F); + SCM mod; + /* compilation of @ or @@ + `what' is a three-element list: (MODNAME SYM INTERFACE?) + INTERFACE? is #t if we compiled @ or #f if we compiled @@ + */ + mod = scm_resolve_module (SCM_CAR (what)); + if (scm_is_true (SCM_CADDR (what))) + mod = scm_module_public_interface (mod); + if (SCM_FALSEP (mod)) + { + err_args = SCM_LIST1 (what); + goto vm_error_no_such_module; + } + /* might longjmp */ + what = scm_module_lookup (mod, SCM_CADR (what)); } - OBJECT_SET (objnum, sym_or_var); + OBJECT_SET (objnum, what); } - VARIABLE_SET (sym_or_var, *sp); + VARIABLE_SET (what, *sp); DROP (); NEXT; } diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 87057d89e..0d313e9fd 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -158,6 +158,22 @@ ((,name ,val) (guard (symbol? name)) (make-ghil-set e l (ghil-var-for-set! e name) (retrans val))) + ;; FIXME: Would be nice to verify the values of @ and @@ relative + ;; to imported modules... + (((@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@))) + (make-ghil-set e l (ghil-var-at-module! e modname name #t) + (retrans val))) + + (((@@ ,modname ,name) ,val) (guard (symbol? name) + (list? modname) + (and-map symbol? modname) + (not (ghil-var-is-bound? e '@@))) + (make-ghil-set e l (ghil-var-at-module! e modname name #f) + (retrans val))) + ;; (set! (NAME ARGS...) VAL) (((,name . ,args) ,val) (guard (symbol? name)) ;; -> ((setter NAME) ARGS... VAL) @@ -272,6 +288,14 @@ ((,expr) (retrans `(make-promise (lambda () ,expr))))) + (@ + ((,modname ,sym) + (make-ghil-ref e l (ghil-var-at-module! e modname sym #t)))) + + (@@ + ((,modname ,sym) + (make-ghil-ref e l (ghil-var-at-module! e modname sym #f)))) + (eval-case (,clauses (retrans diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 261b936fc..838926f7a 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -124,6 +124,9 @@ (make-glil-external op depth (ghil-var-index var))))) ((toplevel) (make-glil-toplevel op (ghil-var-name var))) + ((public private) + (make-glil-module op (ghil-var-env var) (ghil-var-name var) + (eq? (ghil-var-kind var) 'public))) (else (error "Unknown kind of variable:" var)))) (define (constant? x) diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm index b0bac0f9a..92f4df3c1 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -95,6 +95,7 @@ ghil-env-add! ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define! + ghil-var-at-module! call-with-ghil-environment call-with-ghil-bindings)) @@ -236,6 +237,19 @@ (else (loop parent))))))) +(define (ghil-var-at-module! env modname sym interface?) + (let loop ((e env)) + (record-case e + ((<ghil-toplevel-env> table) + (let ((key (list modname sym interface?))) + (or (assoc-ref table key) + (let ((var (make-ghil-var modname sym + (if interface? 'public 'private)))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + ((<ghil-env> parent table variables) + (loop parent))))) + (define (ghil-var-define! toplevel sym) (let ((key (cons (module-name (current-module)) sym))) (or (assoc-ref (ghil-toplevel-env-table toplevel) key) diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm index 48470a28f..75fca0621 100644 --- a/module/system/il/glil.scm +++ b/module/system/il/glil.scm @@ -57,6 +57,9 @@ <glil-toplevel> make-glil-toplevel glil-toplevel? glil-toplevel-op glil-toplevel-name + <glil-module> make-glil-module glil-module? + glil-module-op glil-module-mod glil-module-name glil-module-public? + <glil-label> make-glil-label glil-label? glil-label-label @@ -87,6 +90,7 @@ (<glil-local> op index) (<glil-external> op depth index) (<glil-toplevel> op name) + (<glil-module> op mod name public?) ;; Controls (<glil-label> label) (<glil-branch> inst label) @@ -190,6 +194,8 @@ `(,(symbol-append 'external- op) ,depth ,index)) ((<glil-toplevel> op name) `(,(symbol-append 'toplevel- op) ,name)) + ((<glil-module> op mod name public?) + `(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name)) ;; controls ((<glil-label> label) label) ((<glil-branch> inst label) `(,inst ,label)) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index c5ca46f39..bbbee35cb 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -42,8 +42,9 @@ (define-record (<vm-asm> venv glil body)) (define-record (<venv> parent nexts closure?)) -(define-record (<vlink-now> name)) -(define-record (<vlink-later> name)) +;; key is either a symbol or the list (MODNAME SYM PUBLIC?) +(define-record (<vlink-now> key)) +(define-record (<vlink-later> key)) (define-record (<vdefine> name)) (define-record (<bytespec> vars bytes meta objs closure?)) @@ -188,12 +189,12 @@ ((ref set) (cond (toplevel - (push-object! (make-vlink-now #:name name)) + (push-object! (make-vlink-now #:key name)) (push-code! (case op ((ref) '(variable-ref)) ((set) '(variable-set))))) (else - (let* ((var (make-vlink-later #:name name)) + (let* ((var (make-vlink-later #:key name)) (i (cond ((object-assoc var object-alist) => cdr) (else (let ((i (length object-alist))) @@ -208,6 +209,29 @@ (else (error "unknown toplevel var kind" op name)))) + ((<glil-module> op mod name public?) + (let ((key (list mod name public?))) + (case op + ((ref set) + (cond + (toplevel + (push-object! (make-vlink-now #:key key)) + (push-code! (case op + ((ref) '(variable-ref)) + ((set) '(variable-set))))) + (else + (let* ((var (make-vlink-later #:key key)) + (i (cond ((object-assoc var object-alist) => cdr) + (else + (let ((i (length object-alist))) + (set! object-alist (acons var i object-alist)) + i))))) + (push-code! (case op + ((ref) `(late-variable-ref ,i)) + ((set) `(late-variable-set ,i)))))))) + (else + (error "unknown module var kind" op key))))) + ((<glil-label> label) (set! label-alist (assq-set! label-alist label (current-address)))) @@ -319,10 +343,10 @@ (if meta (dump! meta)) ;; dump bytecode (push-code! `(load-program ,bytes))) - ((<vlink-later> name) - (dump! name)) - ((<vlink-now> name) - (dump! name) + ((<vlink-later> key) + (dump! key)) + ((<vlink-now> key) + (dump! key) (push-code! '(link-now))) ((<vdefine> name) (push-code! `(define ,(symbol->string name)))) |