summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/system/il/compile.scm4
-rw-r--r--module/system/il/ghil.scm17
-rw-r--r--module/system/vm/assemble.scm60
-rw-r--r--src/vm_loader.c32
-rw-r--r--src/vm_system.c41
-rw-r--r--testsuite/run-vm-tests.scm6
6 files changed, 73 insertions, 87 deletions
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index e9636503b..65ef261b9 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -101,10 +101,8 @@
(make-glil-external op depth (ghil-var-index var)))))
((module)
(let ((env (ghil-var-env var)))
- (make-glil-module op (and env (ghil-mod-module (ghil-env-mod env)))
+ (make-glil-module op (ghil-mod-module (ghil-env-mod env))
(ghil-var-name var))))
- ((unresolved)
- (make-glil-late-bound op (ghil-var-name var)))
(else (error "Unknown kind of variable:" var))))
(define (codegen ghil)
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index e5029e102..fa6d303df 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -185,11 +185,6 @@
;;; Public interface
;;;
-(define (module-lookup module sym)
- (let ((iface (module-import-interface module sym)))
- (and iface
- (make-ghil-env (make-ghil-mod iface)))))
-
(define (fix-ghil-mod! mod for-sym)
;;; So, these warnings happen for all instances of define-module.
;;; Rather than fixing the problem, I'm going to suppress the common
@@ -219,13 +214,13 @@
(fix-ghil-mod! e sym)
(loop e))
((assq-ref table sym)) ;; when does this hit?
- ((module-lookup module sym)
- => (lambda (found-env)
- (make-ghil-var found-env sym 'module)))
(else
- ;; a free variable that we have not resolved
- (warn "unresolved variable during compilation:" sym)
- (let ((var (make-ghil-var #f sym 'unresolved)))
+ ;; although we could bind the variable here, in
+ ;; practice further toplevel definitions in this
+ ;; compilation unit could change how we would resolve
+ ;; this binding, so punt and memoize the lookup at
+ ;; runtime always.
+ (let ((var (make-ghil-var (make-ghil-env e) sym 'module)))
(apush! sym var table)
var))))
((<ghil-env> mod parent table variables)
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 3197f7122..bb70bb7e7 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -43,8 +43,8 @@
(define-record (<vm-asm> venv glil body))
(define-record (<venv> parent nexts closure?))
(define-record (<vmod> id))
-(define-record (<vlink> module name))
-(define-record (<vlate-bound> name))
+(define-record (<vlink-now> module name))
+(define-record (<vlink-later> module name))
(define-record (<vdefine> module name))
(define-record (<bytespec> vars bytes meta objs closure?))
@@ -149,29 +149,28 @@
((<glil-module> op module name)
(case op
- ((ref)
- (push-object! (make-vlink :module module :name name))
- (push-code! '(variable-ref)))
- ((set)
- (push-object! (make-vlink :module module :name name))
- (push-code! '(variable-set)))
+ ((ref set)
+ (cond
+ (toplevel
+ (push-object! (make-vlink-now :module module :name name))
+ (push-code! (case op
+ ((ref) '(variable-ref))
+ ((set) '(variable-set)))))
+ (else
+ (let* ((var (make-vlink-later :module module :name name))
+ (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))))))))
((define)
(push-object! (make-vdefine :module module :name name))
- (push-code! '(variable-set)))))
-
- ((<glil-late-bound> op name)
- (let* ((var (make-vlate-bound :name name))
- (i (cond ((object-assoc var object-alist) => cdr)
- (else
- (let ((i (length object-alist)))
- (set! object-alist (acons var i object-alist))
- i)))))
- (case op
- ((ref)
- (push-code! `(late-variable-ref ,i)))
- ((set)
- (push-code! `(late-variable-set ,i)))
- (else (error "unknown late bound" op name)))))
+ (push-code! '(variable-set)))
+ (else
+ (error "unknown toplevel var kind" op name))))
((<glil-label> label)
(set! label-alist (assq-set! label-alist label (current-address))))
@@ -208,7 +207,8 @@
(define (object-assoc x alist)
(record-case x
- ((<vlink>) (assoc x alist))
+ ((<vlink-now>) (assoc x alist))
+ ((<vlink-later>) (assoc x alist))
(else (assq x alist))))
(define (stack->bytes stack label-alist)
@@ -271,15 +271,17 @@
(if meta (dump! meta))
;; dump bytecode
(push-code! `(load-program ,bytes)))
- ((<vlink> module name)
- (dump! (and=> module module-name))
+ ((<vlink-later> module name)
+ (dump! (module-name module))
+ (dump! name)
+ (push-code! '(link-later)))
+ ((<vlink-now> module name)
+ (dump! (module-name module))
(dump! name)
- (push-code! '(link)))
+ (push-code! '(link-now)))
((<vdefine> module name)
;; FIXME: dump module
(push-code! `(define ,(symbol->string name))))
- ((<vlate-bound> name)
- (push-code! `(late-bind ,(symbol->string name))))
((<vmod> id)
(push-code! `(load-module ,id)))
(else
diff --git a/src/vm_loader.c b/src/vm_loader.c
index d8bf554a8..aa9cd356c 100644
--- a/src/vm_loader.c
+++ b/src/vm_loader.c
@@ -176,29 +176,21 @@ VM_DEFINE_LOADER (load_program, "load-program")
NEXT;
}
-/* this seems to be a bit too much processing for one instruction.. */
-VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 2, 1)
{
- SCM modname, mod, sym;
+ SCM modname, sym;
POP (sym);
POP (modname);
- if (SCM_NFALSEP (modname))
- {
- mod = scm_resolve_module (modname);
-
- if (mod != scm_current_module ())
- {
- mod = scm_c_module_lookup (mod, "%module-public-interface");
- if (SCM_FALSEP (mod))
- SCM_MISC_ERROR ("Could not load module", SCM_LIST1 (modname));
- mod = SCM_VARIABLE_REF (mod);
- }
-
- PUSH (scm_module_lookup (mod, sym));
- }
- else
- PUSH (scm_lookup (sym));
-
+ PUSH (scm_module_lookup (scm_resolve_module (modname), sym)); /* might longjmp */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1)
+{
+ SCM modname, sym;
+ POP (sym);
+ POP (modname);
+ PUSH (scm_cons (modname, sym));
NEXT;
}
diff --git a/src/vm_system.c b/src/vm_system.c
index 6daa818a7..f227e79fa 100644
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -259,23 +259,25 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
{
- register unsigned objnum = FETCH ();
- SCM x;
+ unsigned objnum = FETCH ();
+ SCM pair_or_var;
CHECK_OBJECT (objnum);
- x = OBJECT_REF (objnum);
+ pair_or_var = OBJECT_REF (objnum);
- if (!SCM_VARIABLEP (x))
+ if (!SCM_VARIABLEP (pair_or_var))
{
- x = scm_lookup (x); /* might longjmp */
- OBJECT_SET (objnum, x);
- if (!VARIABLE_BOUNDP (x))
+ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+ /* module_lookup might longjmp */
+ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+ OBJECT_SET (objnum, pair_or_var);
+ if (!VARIABLE_BOUNDP (pair_or_var))
{
- err_args = SCM_LIST1 (x);
+ err_args = SCM_LIST1 (pair_or_var);
goto vm_error_unbound;
}
}
- PUSH (VARIABLE_REF (x));
+ PUSH (VARIABLE_REF (pair_or_var));
NEXT;
}
@@ -313,23 +315,20 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
{
- register unsigned objnum = FETCH ();
- SCM x;
+ unsigned objnum = FETCH ();
+ SCM pair_or_var;
CHECK_OBJECT (objnum);
- x = OBJECT_REF (objnum);
+ pair_or_var = OBJECT_REF (objnum);
- if (!SCM_VARIABLEP (x))
+ if (!SCM_VARIABLEP (pair_or_var))
{
- x = scm_lookup (x); /* might longjmp */
- OBJECT_SET (objnum, x);
- if (!VARIABLE_BOUNDP (x))
- {
- err_args = SCM_LIST1 (x);
- goto vm_error_unbound;
- }
+ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+ /* module_lookup might longjmp */
+ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+ OBJECT_SET (objnum, pair_or_var);
}
- VARIABLE_SET (x, *sp);
+ VARIABLE_SET (pair_or_var, *sp);
DROP ();
NEXT;
}
diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm
index 19cb9e1cf..64568b171 100644
--- a/testsuite/run-vm-tests.scm
+++ b/testsuite/run-vm-tests.scm
@@ -74,9 +74,9 @@ equal in the sense of @var{equal?}."
(format #t "running `~a'... " file)
(if (catch #t
(lambda ()
- (equal? (pk (compile/run-test-from-file file))
- (pk (eval (fetch-sexp-from-file file)
- (interaction-environment)))))
+ (equal? (compile/run-test-from-file file)
+ (eval (fetch-sexp-from-file file)
+ (interaction-environment))))
(lambda (key . args)
(format #t "[~a/~a] " key args)
#f))