allow multiple modules in one compilation unit

* module/system/il/ghil.scm (<ghil-env>, <ghil-toplevel-env>): Refactor
  so that all environments point (eventually) at one toplevel
  environment. Instead of having potentially multiple toplevel
  environments, each noting the module against which its bindings are
  resolved, have each binding in the toplevel record what module it
  should be resolved in. Should fix compilation units that define
  multiple modules.
  (ghil-lookup, ghil-define): Reworked to not be destructive. Module
  variables now have the module name as their "env", and are keyed as
  `(MODNAME . SYM)' in the var table.
  (call-with-ghil-environment): Reindented.

* module/system/il/inline.scm (try-inline-with-env): Adapt to
  env/toplevel changes.

* module/system/vm/assemble.scm (dump-object!): A vlink-later now holds
  the module name, not the module itself.

* module/system/il/compile.scm (make-glil-var): The "env" of a "module"
  var is now the module name, not the module.

* module/language/scheme/translate.scm (primitive-syntax-table): Update
  the way we test for toplevel environments. Reindent the lambda
  translator.
  (lookup-transformer, trans): lookup-transformer now has 2 args, not 3.
  (translate): Update the way we make toplevel environments.

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)
+;; Looks up transformers relative to the current module at
-  (let* ((mod (ghil-mod-module (ghil-env-mod e)))
+;; 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)
+          (lambda (env vars)
-         (receive (meta body) (parse-lambda-meta body)
+            (receive (meta body) (parse-lambda-meta body)
-            (make-ghil-lambda env l vars rest meta
+              (make-ghil-lambda env l vars rest meta
-                              (trans-body env l body))))))))
+                                (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)

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-var-env var) (ghil-var-name var)))
-       (make-glil-module op (ghil-mod-module (ghil-env-mod env))
-                         (ghil-var-name var))))
     (else (error "Unknown kind of variable:" var))))
 
 (define (codegen ghil)

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
 
-   <ghil-mod> make-ghil-mod ghil-mod?
+   <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
-   ghil-mod-module ghil-mod-table ghil-mod-imports
+   ghil-toplevel-env-table
 
    <ghil-env> 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 (<ghil-mod> module (table '()) (imports '())))
-
 
 ;;;
 ;;; Environments
 ;;;
 
-(define-record (<ghil-env> mod parent (table '()) (variables '())))
+(define-record (<ghil-env> parent (table '()) (variables '())))
-
+(define-record (<ghil-toplevel-env> (table '())))
-(define %make-ghil-env make-ghil-env)
-(define (make-ghil-env e)
-  (record-case e
-    ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
-    ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
-
-(define (ghil-env-toplevel? e)
-  (eq? (ghil-env-mod e) (ghil-env-parent e)))
 
 (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)
+;; ghil-lookup: find out where a variable will be stored at runtime.
-  ;;; So, these warnings happen for all instances of define-module.
+;;
-  ;;; Rather than fixing the problem, I'm going to suppress the common
+;; First searches the lexical environments. If the variable is not in
-  ;;; warnings.
+;; the innermost environment, make sure the variable is marked as being
-  (if (not (eq? for-sym 'process-define-module))
+;; "external" so that it goes on the heap.
-      (warn "during lookup of" for-sym ":"
+;;
-            (ghil-mod-module mod) "!= current" (current-module)))
+;; If the variable is not found lexically, it is a toplevel variable,
-  (if (not (null? (ghil-mod-table mod)))
+;; which will be looked up at runtime with respect to the module that is
-      (warn "throwing away old variable table"
+;; current at compile-time. The variable will be resolved when it is
-            (ghil-mod-module) (ghil-mod-table mod)))
+;; first used.
-  (set! (ghil-mod-module mod) (current-module))
+;; 
-  (set! (ghil-mod-table mod) '())
+;; You might think that you want to look up all variables with respect
-  (set! (ghil-mod-imports mod) '()))
+;; to the current runtime module, but you would have to associate the
-
+;; current module with a closure, so that lazy lookup is done with
-;; looking up a var has side effects?
+;; 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 env))
-      (let loop ((e (ghil-env-parent env)))
+    (record-case e
-        (record-case e
+      ((<ghil-toplevel-env> table)
-          ((<ghil-mod> module table imports)
+       (let ((key (cons (module-name (current-module)) sym)))
-           (cond ((not (eq? module (current-module)))
+         (or (assoc-ref table key)
-                  ;; FIXME: the primitive-eval in eval-case and/or macro
+             (let ((var (make-ghil-var (car key) (cdr key) 'module)))
-                  ;; expansion can have side effects on the compilation
+               (apush! key var (ghil-toplevel-env-table e))
-                  ;; environment, for example changing the current
+               var))))
-                  ;; module. We probably need to add a special case in
+      ((<ghil-env> parent table variables)
-                  ;; compilation to handle define-module.
+       (let ((found (assq-ref table sym)))
-                  (fix-ghil-mod! e sym)
+         (if found
-                  (loop e))
+             (begin
-                 ((assq-ref table sym)) ;; when does this hit?
+               (if (not (eq? e env))
-                 (else
+                   (set! (ghil-var-kind found) 'external))
-                  ;; although we could bind the variable here, in
+               found)
-                  ;; practice further toplevel definitions in this
+             (loop parent)))))))
-                  ;; 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)
-           (let ((found (assq-ref table sym)))
-             (if found
-                 (begin (set! (ghil-var-kind found) 'external) found)
-                 (loop parent))))))))
 
-(define (ghil-define mod sym)
+(define (ghil-define toplevel sym)
-  (if (not (eq? (ghil-mod-module mod) (current-module)))
+  (let ((key (cons (module-name (current-module)) sym)))
-      (fix-ghil-mod! mod sym))
+    (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
-  (or (assq-ref (ghil-mod-table mod) sym)
+        (let ((var (make-ghil-var (car key) (cdr key) 'module)))
-      (let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
+          (apush! key var (ghil-toplevel-env-table toplevel))
-        (apush! sym var (ghil-mod-table mod))
+          var))))
-        var)))
           
 (define (call-with-ghil-environment e syms func)
   (let* ((e (make-ghil-env e))
-	 (vars (map (lambda (s)
+         (vars (map (lambda (s)
-		      (let ((v (make-ghil-var e s 'argument)))
+                      (let ((v (make-ghil-var e s 'argument)))
-			(ghil-env-add! e v) v))
+                        (ghil-env-add! e v) v))
-		    syms)))
+                    syms)))
     (func e vars)))
 
 (define (call-with-ghil-bindings e syms func)

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 env))
-         (let loop ((e (ghil-env-parent env)))
+      (record-case e
-           (record-case e
+        ((<ghil-toplevel-env> table)
-            ((<ghil-mod> module table imports)
+         (let ((mod (current-module)))
-             (and (not (assq-ref table sym))
+           (and (not (assoc-ref table (cons (module-name mod) sym)))
-                  (module-bound? module sym)
+                (module-bound? mod sym)
-                  (try-inline (module-ref module sym) (cdr exp))))
+                (try-inline (module-ref mod sym) (cdr exp)))))
-            ((<ghil-env> mod parent table variables)
+        ((<ghil-env> parent table variables)
-             (and (not (assq-ref table sym))
+         (and (not (assq-ref table sym))
-                  (loop parent))))))))
+              (loop parent)))))))
 
 (define-inline eq? (x y)
   (eq? x y))

module/system/vm/assemble.scm

@@ -269,7 +269,7 @@
 	 ;; dump bytecode
 	 (push-code! `(load-program ,bytes)))
 	((<vlink-later> module name)
-         (dump! (module-name module))
+         (dump! module)
          (dump! name)
 	 (push-code! '(link-later)))
 	((<vlink-now> name)