From 6297d22907ef28d6dc059db3bbcd711d9b7c50a1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 19 May 2008 19:37:39 +0200 Subject: [PATCH] bind all module-level variables lazily comments in ghil-lookup are pertinent. * module/system/il/compile.scm (make-glil-var): Require that ghil vars have environments. Remove the 'unresolved case -- we'll treat all module-level variables as late bound. * module/system/il/ghil.scm (ghil-lookup): Treat all module level vars as late bound. * module/system/vm/assemble.scm: Instead of vlink and vlate-bound, have vlink-now and vlink-later. (codegen): Add a bunch of crap to get the various cases right. (object-assoc, dump-object!): Handle the new cases, remove the old cases. * src/vm_loader.c (link-now, link-later): Change from link and lazy-bind. Include the module in which the link is to be done, so that callers from other modules get the right behavior. * src/vm_system.c (late-variable-ref, late-variable-set): Instead of a sym, the unbound representation is a module name / symbol pair. * testsuite/run-vm-tests.scm (run-vm-tests): Remove some debugging. --- module/system/il/compile.scm | 4 +-- module/system/il/ghil.scm | 17 ++++------ module/system/vm/assemble.scm | 60 ++++++++++++++++++----------------- src/vm_loader.c | 30 +++++++----------- src/vm_system.c | 41 ++++++++++++------------ testsuite/run-vm-tests.scm | 6 ++-- 6 files changed, 72 insertions(+), 86 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)))) (( 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 ( venv glil body)) (define-record ( parent nexts closure?)) (define-record ( id)) -(define-record ( module name)) -(define-record ( name)) +(define-record ( module name)) +(define-record ( module name)) (define-record ( module name)) (define-record ( vars bytes meta objs closure?)) @@ -149,29 +149,28 @@ (( 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))))) - - (( 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)))) (( label) (set! label-alist (assq-set! label-alist label (current-address)))) @@ -208,7 +207,8 @@ (define (object-assoc x alist) (record-case x - (() (assoc x alist)) + (() (assoc x alist)) + (() (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))) - (( module name) - (dump! (and=> module module-name)) + (( module name) + (dump! (module-name module)) (dump! name) - (push-code! '(link))) + (push-code! '(link-later))) + (( module name) + (dump! (module-name module)) + (dump! name) + (push-code! '(link-now))) (( module name) ;; FIXME: dump module (push-code! `(define ,(symbol->string name)))) - (( name) - (push-code! `(late-bind ,(symbol->string name)))) (( 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); + PUSH (scm_module_lookup (scm_resolve_module (modname), sym)); /* might longjmp */ + NEXT; +} - 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)); - +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))