Add pass to resolve free toplevel references in declarative modules

* am/bootstrap.am (SOURCES):
* module/Makefile.am (SOURCES):
* module/language/tree-il/optimize.scm (make-optimizer): Wire up the new
pass.
* module/language/tree-il/resolve-free-vars.scm: New pass.
* module/system/base/optimize.scm (available-optimizations): Enable new
pass at -O1.

4 files changed, 286 insertions, 0 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index 41b77095b..8a87f4ec6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -93,6 +93,7 @@ SOURCES =					\
   language/tree-il/optimize.scm			\
   language/tree-il/peval.scm			\
   language/tree-il/primitives.scm		\
+  language/tree-il/resolve-free-vars.scm	\
   language/tree-il/spec.scm			\
 						\
   ice-9/and-let-star.scm			\
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index c080bbbc2..ba55f974b 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -39,6 +39,7 @@
                         'proc)))))
   (let ((verify     (or (lookup #:verify-tree-il? debug verify-tree-il)
                         (lambda (exp) exp)))
+        (modulify   (lookup #:resolve-free-vars? resolve-free-vars))
         (resolve    (lookup #:resolve-primitives? primitives resolve-primitives))
         (expand     (lookup #:expand-primitives? primitives expand-primitives))
         (letrectify (lookup #:letrectify? letrectify))
@@ -49,6 +50,7 @@
       (when proc (set! exp (verify (proc exp arg ...)))))
     (lambda (exp env)
       (verify exp)
+      (run-pass! (modulify exp))
       (run-pass! (resolve exp env))
       (run-pass! (expand exp))
       (run-pass! (letrectify exp #:seal-private-bindings? seal?))
diff --git a/module/language/tree-il/resolve-free-vars.scm b/module/language/tree-il/resolve-free-vars.scm
new file mode 100644
index 000000000..3d4eb2bb0
--- /dev/null
+++ b/module/language/tree-il/resolve-free-vars.scm
@@ -0,0 +1,282 @@
+;;; Resolving free top-level references to modules
+;;; Copyright (C) 2021
+;;;   Free Software Foundation, Inc.
+;;;
+;;; This library is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+
+(define-module (language tree-il resolve-free-vars)
+  #:use-module (ice-9 match)
+  #:use-module (language tree-il)
+  #:use-module ((srfi srfi-1) #:select (filter-map))
+  #:export (resolve-free-vars))
+
+(define (compute-assigned-lexicals exp)
+  (define assigned-lexicals '())
+  (define (add-assigned-lexical! var)
+    (set! assigned-lexicals (cons var assigned-lexicals)))
+  ((make-tree-il-folder)
+   exp
+   (lambda (exp)
+     (match exp
+       (($ <lexical-set> _ _ var _)
+        (add-assigned-lexical! var)
+        (values))
+       (_ (values))))
+   (lambda (exp)
+     (values)))
+  assigned-lexicals)
+
+(define (make-resolver mod local-definitions)
+  ;; Given that module A imports B and C, and X is free in A,
+  ;; unfortunately there are a few things preventing us from knowing
+  ;; whether the binding proceeds from B or C, just based on the text:
+  ;;
+  ;;  - Renamers are evaluated at run-time.
+  ;;  - Just using B doesn't let us know what definitions are in B.
+  ;;
+  ;; So instead of using the source program to determine where a binding
+  ;; comes from, we use the first-class module interface.
+  (define (imported-resolver iface)
+    (let ((public-iface (resolve-interface (module-name iface))))
+      (if (eq? iface public-iface)
+          (lambda (name)
+            (and (module-variable iface name)
+                 (cons (module-name iface) name)))
+          (let ((by-var (make-hash-table)))
+            (module-for-each (lambda (name var)
+                               (hashq-set! by-var var name))
+                             public-iface)
+            (lambda (name)
+              (let ((var (module-variable iface name)))
+                (and var
+                     (cons (module-name iface)
+                           (hashq-ref by-var var)))))))))
+
+  (define the-module (resolve-module mod))
+  (define resolvers
+    (map imported-resolver (module-uses the-module)))
+
+  (lambda (name)
+    (cond
+     ((or (module-local-variable the-module name)
+          (memq name local-definitions))
+      'local)
+     (else
+      (match (filter-map (lambda (resolve) (resolve name)) resolvers)
+        (() 'unknown)
+        (((mod . #f)) 'unknown)
+        (((mod . public-name)) (cons mod public-name))
+        ((_ _ . _) 'duplicate))))))
+
+;;; Record all bindings in a module, to know whether a toplevel-ref is
+;;; an import or not.  If toplevel-ref to imported variable, transform
+;;; to module-ref or primitive-ref.  New pass before peval.
+
+(define (compute-free-var-resolver exp)
+  (define assigned-lexicals (compute-assigned-lexicals exp))
+  (define module-definitions '())
+  (define module-lexicals '())
+  (define bindings '())
+  (define (add-module-definition! mod args)
+    (set! module-definitions (acons mod args module-definitions)))
+  (define (add-module-lexical! var mod)
+    (unless (memq var assigned-lexicals)
+      (set! module-lexicals (acons var mod module-lexicals))))
+  (define (add-binding! mod name)
+    (set! bindings (acons mod name bindings)))
+
+  (define (record-bindings! mod vars vals)
+    (for-each
+     (lambda (var val)
+       (match val
+         (($ <call> _ ($ <module-ref> _ '(guile) 'define-module* #f)
+             (($ <const> _ mod) . args))
+          (add-module-definition! mod args)
+          (add-module-lexical! var mod))
+         (($ <primcall> _ 'current-module ())
+          (when mod
+            (add-module-lexical! var mod)))
+         (_ #f)))
+     vars vals))
+
+  ;; Thread a conservative idea of what the current module is through
+  ;; the visit.  Visiting an expression returns the name of the current
+  ;; module when the expression completes, or #f if unknown.  Record the
+  ;; define-module* forms, if any, and note any toplevel definitions.
+  (define (visit exp) (visit/mod exp #f))
+  (define (visit* exps)
+    (unless (null? exps)
+      (visit (car exps))
+      (visit* (cdr exps))))
+  (define (visit+ exps mod)
+    (match exps
+      (() mod)
+      ((exp . exps)
+       (let lp ((mod' (visit/mod exp mod)) (exps exps))
+         (match exps
+           (() mod')
+           ((exp . exps)
+            (lp (and (equal? mod' (visit/mod exp mod)) mod')
+                exps)))))))
+  (define (visit/mod exp mod)
+    (match exp
+      ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <lexical-ref>)
+           ($ <module-ref>) ($ <toplevel-ref>))
+       mod)
+
+      (($ <call> _ ($ <module-ref> _ '(guile) 'set-current-module #f)
+          (($ <lexical-ref> _ _ var)))
+       (assq-ref module-lexicals var))
+
+      (($ <call> _ proc args)
+       (visit proc)
+       (visit* args)
+       #f)
+
+      (($ <primcall> _ _ args)
+       ;; There is no primcall that sets the current module.
+       (visit+ args mod))
+
+      (($ <conditional> src test consequent alternate)
+       (visit+ (list consequent alternate) (visit/mod test mod)))
+
+      (($ <lexical-set> src name gensym exp)
+       (visit/mod exp mod))
+
+      (($ <toplevel-set> src mod name exp)
+       (visit/mod exp mod))
+
+      (($ <module-set> src mod name public? exp)
+       (visit/mod exp mod))
+
+      (($ <toplevel-define> src mod name exp)
+       (add-binding! mod name)
+       (visit/mod exp mod))
+
+      (($ <lambda> src meta body)
+       (when body (visit body))
+       mod)
+
+      (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+       (visit* inits)
+       (let* ((bodies (cons body inits))
+              (bodies (if alternate (cons alternate bodies) bodies)))
+         (visit+ bodies mod)))
+
+      (($ <seq> src head tail)
+       (visit/mod tail (visit/mod head mod)))
+
+      (($ <let> src names gensyms vals body)
+       (record-bindings! mod gensyms vals)
+       (visit/mod body (visit+ vals mod)))
+
+      (($ <letrec> src in-order? names gensyms vals body)
+       (record-bindings! mod gensyms vals)
+       (visit/mod body (visit+ vals mod)))
+
+      (($ <fix> src names gensyms vals body)
+       (record-bindings! mod gensyms vals)
+       (visit/mod body (visit+ vals mod)))
+
+      (($ <let-values> src exp body)
+       (visit/mod body (visit/mod exp mod)))
+
+      (($ <prompt> src escape-only? tag body handler)
+       (visit+ (list body handler) (visit/mod tag mod)))
+
+      (($ <abort> src tag args tail)
+       (visit tag)
+       (visit* args)
+       (visit tail)
+       #f)))
+
+  (visit exp)
+
+  (define (kwarg-ref args kw kt kf)
+    (let lp ((args args))
+      (match args
+        (() (kf))
+        ((($ <const> _ (? keyword? kw')) val . args)
+         (if (eq? kw' kw)
+             (kt val)
+             (lp args)))
+        ((_ _ . args)
+         (lp args)))))
+  (define (kwarg-ref/const args kw kt kf)
+    (kwarg-ref args kw
+               (lambda (exp)
+                 (match exp
+                   (($ <const> _ val') (kt val'))
+                   (_ (kf))))
+               kf))
+  (define (has-constant-initarg? args kw val)
+    (kwarg-ref/const args kw
+                     (lambda (val')
+                       (equal? val val'))
+                     (lambda () #f)))
+
+  ;; Collect declarative modules defined once in this compilation unit.
+  (define declarative-modules
+    (let lp ((defs module-definitions) (not-declarative '()) (declarative '()))
+      (match defs
+        (() declarative)
+        (((mod . args) . defs)
+         (cond ((member mod not-declarative)
+                (lp defs not-declarative declarative))
+               ((or (assoc mod defs) ;; doubly defined?
+                    (not (has-constant-initarg? args #:declarative? #t)))
+                (lp defs (cons mod not-declarative) declarative))
+               (else
+                (lp defs not-declarative (cons mod declarative))))))))
+
+  (define resolvers
+    (map (lambda (mod)
+           (define resolve
+             (make-resolver mod
+                            (filter-map (match-lambda
+                                          ((mod' . name)
+                                           (and (equal? mod mod') name)))
+                                        bindings)))
+           (cons mod resolve))
+         declarative-modules))
+
+  (lambda (mod name)
+    (cond
+     ((assoc-ref resolvers mod)
+      => (lambda (resolve) (resolve name)))
+     (else 'unknown))))
+
+(define (resolve-free-vars exp)
+  "Traverse @var{exp}, extracting module-level definitions."
+  (define resolve
+    (compute-free-var-resolver exp))
+
+  (post-order
+   (lambda (exp)
+     (match exp
+       (($ <toplevel-ref> src mod name)
+        (match (resolve mod name)
+          ((or 'unknown 'duplicate 'local) exp)
+          ((mod . name)
+           (make-module-ref src mod name #t))))
+       (($ <toplevel-set> src mod name val)
+        (match (resolve mod name)
+          ((or 'unknown 'duplicate 'local) exp)
+          ((mod . name)
+           (make-module-set src mod name #t val))))
+       (exp exp)))
+   exp))
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
index 03c57bf1b..1fd666376 100644
--- a/module/system/base/optimize.scm
+++ b/module/system/base/optimize.scm
@@ -28,6 +28,7 @@
   (match lang-name
     ('tree-il
      '((#:cps? 2)
+       (#:resolve-free-vars? 1)
        (#:resolve-primitives? 1)
        (#:expand-primitives? 1)
        (#:letrectify? 2)