diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm index 31c13e30d..81efce068 100644 --- a/module/language/scheme/translate.scm +++ b/module/language/scheme/translate.scm @@ -31,7 +31,7 @@ (define (translate x e) - (call-with-ghil-environment (make-ghil-mod e) '() + (call-with-ghil-environment (make-ghil-toplevel-env) '() (lambda (env vars) (make-ghil-lambda env #f vars #f '() (trans env (location x) x))))) @@ -47,8 +47,10 @@ ;; compicated than that. '(procedure->syntax procedure->macro procedure->memoizing-macro)) -(define (lookup-transformer e head retrans) - (let* ((mod (ghil-mod-module (ghil-env-mod e))) +;; Looks up transformers relative to the current module at +;; compilation-time. See also the discussion of ghil-lookup in ghil.scm. +(define (lookup-transformer head retrans) + (let* ((mod (current-module)) (val (and (symbol? head) (and=> (module-variable mod head) (lambda (var) @@ -85,7 +87,7 @@ (cond ((pair? x) (let ((head (car x)) (tail (cdr x))) (cond - ((lookup-transformer e head retrans) + ((lookup-transformer head retrans) => (lambda (t) (t e l x))) ;; FIXME: lexical/module overrides of forbidden primitives @@ -142,7 +144,8 @@ (define ;; (define NAME VAL) - ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e)) + ((,name ,val) (guard (symbol? name) + (ghil-toplevel-env? (ghil-env-parent e))) (make-ghil-define e l (ghil-define (ghil-env-parent e) name) (retrans val))) ;; (define (NAME FORMALS...) BODY...) @@ -259,16 +262,17 @@ ((,formals . ,body) (receive (syms rest) (parse-formals formals) (call-with-ghil-environment e syms - (lambda (env vars) - (receive (meta body) (parse-lambda-meta body) - (make-ghil-lambda env l vars rest meta - (trans-body env l body)))))))) + (lambda (env vars) + (receive (meta body) (parse-lambda-meta body) + (make-ghil-lambda env l vars rest meta + (trans-body env l body)))))))) (eval-case (,clauses (retrans `(begin - ,@(let ((toplevel? (ghil-env-toplevel? e))) + ;; Compilation of toplevel units is always wrapped in a lambda + ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e)))) (let loop ((seen '()) (in clauses) (runtime '())) (cond ((null? in) runtime) diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm index 374f7eec4..82c9c427f 100644 --- a/module/system/il/compile.scm +++ b/module/system/il/compile.scm @@ -99,9 +99,7 @@ ((eq? e (ghil-var-env var)) (make-glil-external op depth (ghil-var-index var))))) ((module) - (let ((env (ghil-var-env var))) - (make-glil-module op (ghil-mod-module (ghil-env-mod env)) - (ghil-var-name var)))) + (make-glil-module op (ghil-var-env var) (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 9fab56952..2f1423a3d 100644 --- a/module/system/il/ghil.scm +++ b/module/system/il/ghil.scm @@ -76,14 +76,13 @@ ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value ghil-var-index - make-ghil-mod ghil-mod? - ghil-mod-module ghil-mod-table ghil-mod-imports + make-ghil-toplevel-env ghil-toplevel-env? + ghil-toplevel-env-table make-ghil-env ghil-env? - ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables + ghil-env-parent ghil-env-table ghil-env-variables ghil-env-add! ghil-lookup ghil-define - ghil-env-toplevel? call-with-ghil-environment call-with-ghil-bindings)) @@ -125,23 +124,13 @@ ;;; Modules ;;; -(define-record ( module (table '()) (imports '()))) - ;;; ;;; Environments ;;; -(define-record ( mod parent (table '()) (variables '()))) - -(define %make-ghil-env make-ghil-env) -(define (make-ghil-env e) - (record-case e - (() (%make-ghil-env :mod e :parent e)) - (( mod) (%make-ghil-env :mod mod :parent e)))) - -(define (ghil-env-toplevel? e) - (eq? (ghil-env-mod e) (ghil-env-parent e))) +(define-record ( parent (table '()) (variables '()))) +(define-record ( (table '()))) (define (ghil-env-ref env sym) (assq-ref (ghil-env-table env) sym)) @@ -165,64 +154,59 @@ ;;; Public interface ;;; -(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 - ;;; warnings. - (if (not (eq? for-sym 'process-define-module)) - (warn "during lookup of" for-sym ":" - (ghil-mod-module mod) "!= current" (current-module))) - (if (not (null? (ghil-mod-table mod))) - (warn "throwing away old variable table" - (ghil-mod-module) (ghil-mod-table mod))) - (set! (ghil-mod-module mod) (current-module)) - (set! (ghil-mod-table mod) '()) - (set! (ghil-mod-imports mod) '())) - -;; looking up a var has side effects? +;; ghil-lookup: find out where a variable will be stored at runtime. +;; +;; First searches the lexical environments. If the variable is not in +;; the innermost environment, make sure the variable is marked as being +;; "external" so that it goes on the heap. +;; +;; If the variable is not found lexically, it is a toplevel variable, +;; which will be looked up at runtime with respect to the module that is +;; current at compile-time. The variable will be resolved when it is +;; first used. +;; +;; You might think that you want to look up all variables with respect +;; to the current runtime module, but you would have to associate the +;; current module with a closure, so that lazy lookup is done with +;; respect to the proper module. We could do that -- it would probably +;; cons less at runtime. +;; +;; This toplevel lookup strategy can exhibit weird effects in the case +;; of a call to set-current-module inside a closure -- specifically, +;; looking up any needed bindings for the rest of the closure in the +;; compilation module instead of the runtime module -- but such things +;; are both unspecified in the scheme standard. (define (ghil-lookup env sym) - (or (ghil-env-ref env sym) - (let loop ((e (ghil-env-parent env))) - (record-case e - (( module table imports) - (cond ((not (eq? module (current-module))) - ;; FIXME: the primitive-eval in eval-case and/or macro - ;; expansion can have side effects on the compilation - ;; environment, for example changing the current - ;; module. We probably need to add a special case in - ;; compilation to handle define-module. - (fix-ghil-mod! e sym) - (loop e)) - ((assq-ref table sym)) ;; when does this hit? - (else - ;; 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) - (let ((found (assq-ref table sym))) - (if found - (begin (set! (ghil-var-kind found) 'external) found) - (loop parent)))))))) + (let loop ((e env)) + (record-case e + (( table) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref table key) + (let ((var (make-ghil-var (car key) (cdr key) 'module))) + (apush! key var (ghil-toplevel-env-table e)) + var)))) + (( parent table variables) + (let ((found (assq-ref table sym))) + (if found + (begin + (if (not (eq? e env)) + (set! (ghil-var-kind found) 'external)) + found) + (loop parent))))))) -(define (ghil-define mod sym) - (if (not (eq? (ghil-mod-module mod) (current-module))) - (fix-ghil-mod! mod sym)) - (or (assq-ref (ghil-mod-table mod) sym) - (let ((var (make-ghil-var (make-ghil-env mod) sym 'module))) - (apush! sym var (ghil-mod-table mod)) - var))) +(define (ghil-define toplevel sym) + (let ((key (cons (module-name (current-module)) sym))) + (or (assoc-ref (ghil-toplevel-env-table toplevel) key) + (let ((var (make-ghil-var (car key) (cdr key) 'module))) + (apush! key var (ghil-toplevel-env-table toplevel)) + var)))) (define (call-with-ghil-environment e syms func) (let* ((e (make-ghil-env e)) - (vars (map (lambda (s) - (let ((v (make-ghil-var e s 'argument))) - (ghil-env-add! e v) v)) - syms))) + (vars (map (lambda (s) + (let ((v (make-ghil-var e s 'argument))) + (ghil-env-add! e v) v)) + syms))) (func e vars))) (define (call-with-ghil-bindings e syms func) diff --git a/module/system/il/inline.scm b/module/system/il/inline.scm index 365946942..76f035bb2 100644 --- a/module/system/il/inline.scm +++ b/module/system/il/inline.scm @@ -69,22 +69,19 @@ (and=> (assq-ref *inline-table* head-value) (lambda (proc) (apply proc args)))) -(define (ghil-env-ref env sym) - (assq-ref (ghil-env-table env) sym)) - (define (try-inline-with-env env loc exp) (let ((sym (car exp))) - (and (not (ghil-env-ref env sym)) - (let loop ((e (ghil-env-parent env))) - (record-case e - (( module table imports) - (and (not (assq-ref table sym)) - (module-bound? module sym) - (try-inline (module-ref module sym) (cdr exp)))) - (( mod parent table variables) - (and (not (assq-ref table sym)) - (loop parent)))))))) + (let loop ((e env)) + (record-case e + (( table) + (let ((mod (current-module))) + (and (not (assoc-ref table (cons (module-name mod) sym))) + (module-bound? mod sym) + (try-inline (module-ref mod sym) (cdr exp))))) + (( parent table variables) + (and (not (assq-ref table sym)) + (loop parent))))))) (define-inline eq? (x y) (eq? x y)) diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index b7f573eb1..83050bb13 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -269,7 +269,7 @@ ;; dump bytecode (push-code! `(load-program ,bytes))) (( module name) - (dump! (module-name module)) + (dump! module) (dump! name) (push-code! '(link-later))) (( name)