diff --git a/am/bootstrap.am b/am/bootstrap.am index 1ba52dd37..3d4729010 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -67,6 +67,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 \ \ language/scheme/spec.scm \ 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 +;;; . + + + +(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 + (($ _ _ 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 + (($ _ ($ _ '(guile) 'define-module* #f) + (($ _ mod) . args)) + (add-module-definition! mod args) + (add-module-lexical! var mod)) + (($ _ '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 ($ ) ($ ) ($ ) ($ ) + ($ ) ($ )) + mod) + + (($ _ ($ _ '(guile) 'set-current-module #f) + (($ _ _ var))) + (assq-ref module-lexicals var)) + + (($ _ proc args) + (visit proc) + (visit* args) + #f) + + (($ _ _ args) + ;; There is no primcall that sets the current module. + (visit+ args mod)) + + (($ src test consequent alternate) + (visit+ (list consequent alternate) (visit/mod test mod))) + + (($ src name gensym exp) + (visit/mod exp mod)) + + (($ src mod name exp) + (visit/mod exp mod)) + + (($ src mod name public? exp) + (visit/mod exp mod)) + + (($ src mod name exp) + (add-binding! mod name) + (visit/mod exp mod)) + + (($ src meta body) + (when body (visit body)) + mod) + + (($ 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))) + + (($ src head tail) + (visit/mod tail (visit/mod head mod))) + + (($ src names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ src in-order? names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ src names gensyms vals body) + (record-bindings! mod gensyms vals) + (visit/mod body (visit+ vals mod))) + + (($ src exp body) + (visit/mod body (visit/mod exp mod))) + + (($ src escape-only? tag body handler) + (visit+ (list body handler) (visit/mod tag mod))) + + (($ 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)) + ((($ _ (? 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 + (($ _ 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 + (($ src mod name) + (match (resolve mod name) + ((or 'unknown 'duplicate 'local) exp) + ((mod . name) + (make-module-ref src mod name #t)))) + (($ 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)