guile/module/language/tree-il/resolve-free-vars.scm

;;; Resolving free top-level references to modules
;;; Copyright (C) 2021-2022
;;;   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 ((by-var (make-hash-table)))
      ;; When resolving a free variable, Guile visits all used modules
      ;; to see if there is a binding.  If one of those imports is an
      ;; autoload, it's possible that the autoload interface fails to
      ;; load.  In that case Guile will issue a warning and consider the
      ;; binding not found in that module.  Here we try to produce the
      ;; same behavior at optimization time that we do at expand time
      ;; that we would do at run time.
      (false-if-exception
       (let ((public-iface (resolve-interface (module-name iface))))
         (module-for-each (lambda (name var)
                            (hashq-set! by-var var name))
                          public-iface))
       #:warning "Failed to determine exported bindings from module ~a:\n"
       (module-name 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))