Implement cross-module inliningwip-inlinable-exports

* module/language/tree-il/optimize.scm (make-optimizer): Pass
cross-module-inlining? to peval.
* module/language/tree-il/peval.scm (peval): Add cross-module-inlining?
kwarg.  Try to inline public module-ref.

2 files changed, 138 insertions, 59 deletions

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 264cd64d6..b1d8b8294 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -44,6 +44,7 @@
         (expand     (lookup #:expand-primitives? primitives expand-primitives))
         (letrectify (lookup #:letrectify? letrectify))
         (seal?      (assq-ref opts #:seal-private-bindings?))
+        (xinline?   (assq-ref opts #:cross-module-inlining?))
         (peval      (lookup #:partial-eval? peval))
         (eta-expand (lookup #:eta-expand? eta-expand))
         (inlinables (lookup #:inlinable-exports? inlinable-exports)))
@@ -56,7 +57,7 @@
       (run-pass! (expand exp))
       (run-pass! (letrectify exp #:seal-private-bindings? seal?))
       (run-pass! (fix-letrec exp))
-      (run-pass! (peval exp env))
+      (run-pass! (peval exp env #:cross-module-inlining? xinline?))
       (run-pass! (eta-expand exp))
       (run-pass! (inlinables exp))
       exp)))
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index def423518..2d9a16d33 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011-2014, 2017, 2019, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014, 2017, 2019, 2020, 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
@@ -368,7 +368,8 @@
                 (operand-size-limit 20)
                 (value-size-limit 10)
                 (effort-limit 500)
-                (recursive-effort-limit 100))
+                (recursive-effort-limit 100)
+                (cross-module-inlining? #f))
   "Partially evaluate EXP in compilation environment CENV, with
 top-level bindings from ENV and return the resulting expression."
 
@@ -431,14 +432,54 @@ top-level bindings from ENV and return the resulting expression."
   (define (lexical-refcount sym)
     (var-refcount (lookup-var sym)))
 
+  (define (splice-expression exp)
+    (define vars (make-hash-table))
+    (define (rename! old*)
+      (match old*
+        (() '())
+        ((old . old*)
+         (cons (let ((new (gensym "t")))
+                 (hashq-set! vars old new)
+                 new)
+               (rename! old*)))))
+    (define (new-name old) (hashq-ref vars old))
+    (define renamed
+      (pre-order
+       (match-lambda
+         (($ <lexical-ref> src name gensym)
+          (make-lexical-ref src name (new-name gensym)))
+         (($ <lexical-set> src name gensym exp)
+          (make-lexical-set src name (new-name gensym) exp))
+         (($ <lambda-case> src req opt rest kw init gensyms body alt)
+          (let ((gensyms (rename! gensyms)))
+            (make-lambda-case src req opt rest
+                              (match kw
+                                ((aok? (kw name sym) ...)
+                                 (cons aok?
+                                       (map (lambda (kw name sym)
+                                              (list kw name (new-name sym)))
+                                            kw name sym)))
+                                (#f #f))
+                              init gensyms body alt)))
+         (($ <let> src names gensyms vals body)
+          (make-let src names (rename! gensyms) vals body))
+         (($ <letrec>)
+          (error "unexpected letrec"))
+         (($ <fix> src names gensyms vals body)
+          (make-fix src names (rename! gensyms) vals body))
+         (exp exp))
+       exp))
+    (set! store (build-var-table renamed store))
+    renamed)
+
   (define (with-temporaries src exps refcount can-copy? k)
     (let* ((pairs (map (match-lambda
-                        ((and exp (? can-copy?))
-                         (cons #f exp))
-                        (exp
-                         (let ((sym (gensym "tmp ")))
-                           (record-new-temporary! 'tmp sym refcount)
-                           (cons sym exp))))
+                         ((and exp (? can-copy?))
+                          (cons #f exp))
+                         (exp
+                          (let ((sym (gensym "tmp ")))
+                            (record-new-temporary! 'tmp sym refcount)
+                            (cons sym exp))))
                        exps))
            (tmps (filter car pairs)))
       (match tmps
@@ -449,9 +490,9 @@ top-level bindings from ENV and return the resulting expression."
                    (map car tmps)
                    (map cdr tmps)
                    (k (map (match-lambda
-                            ((#f . val) val)
-                            ((sym . _)
-                             (make-lexical-ref #f 'tmp sym)))
+                             ((#f . val) val)
+                             ((sym . _)
+                              (make-lexical-ref #f 'tmp sym)))
                            pairs)))))))
 
   (define (make-begin0 src first second)
@@ -506,14 +547,14 @@ top-level bindings from ENV and return the resulting expression."
     (define (apply-primitive name args)
       ;; todo: further optimize commutative primitives
       (catch #t
-             (lambda ()
-               (call-with-values
-                   (lambda ()
-                     (apply (module-ref the-scm-module name) args))
-                 (lambda results
-                   (values #t results))))
-             (lambda _
-               (values #f '()))))
+        (lambda ()
+          (call-with-values
+              (lambda ()
+                (apply (module-ref the-scm-module name) args))
+            (lambda results
+              (values #t results))))
+        (lambda _
+          (values #f '()))))
     (define (make-values src values)
       (match values
         ((single) single)               ; 1 value
@@ -1027,8 +1068,45 @@ top-level bindings from ENV and return the resulting expression."
                    (make-primitive-ref src name)
                    exp))
              exp)))
-      (($ <module-ref>)
-       exp)
+      (($ <module-ref> src module name public?)
+       (cond
+        ((and cross-module-inlining?
+              public?
+              (and=> (resolve-interface module)
+                     (lambda (module)
+                       (and=> (module-inlinable-exports module)
+                              (lambda (proc) (proc name))))))
+         => (lambda (inlined)
+              ;; Similar logic to lexical-ref, but we can't enumerate
+              ;; uses, and don't know about aliases.
+              (log 'begin-xm-copy exp inlined)
+              (cond
+               ((eq? ctx 'effect)
+                (log 'xm-effect)
+                (make-void #f))
+               ((eq? ctx 'call)
+                ;; Don't propagate copies if we are residualizing a call.
+                (log 'residualize-xm-call exp)
+                exp)
+               ((or (const? inlined) (void? inlined) (primitive-ref? inlined))
+                ;; Always propagate simple values that cannot lead to
+                ;; code bloat.
+                (log 'copy-xm-const)
+                (for-tail inlined))
+               ;; Inline in operator position if it's a lambda that's
+               ;; small enough.  Normally the inlinable-exports pass
+               ;; will only make small lambdas available for inlining,
+               ;; but you never know.
+               ((and (eq? ctx 'operator) (lambda? inlined)
+                     (small-expression? inlined operator-size-limit))
+                (log 'copy-xm-operator exp inlined)
+                (splice-expression inlined))
+               (else
+                (log 'xm-copy-failed)
+                ;; Could copy small lambdas in value context.  Something
+                ;; to revisit.
+                exp))))
+        (else exp)))
       (($ <module-set> src mod name public? exp)
        (make-module-set src mod name public? (for-value exp)))
       (($ <toplevel-define> src mod name exp)
@@ -1146,55 +1224,55 @@ top-level bindings from ENV and return the resulting expression."
         (with-temporaries
          src (list w u) 2 constant-expression?
          (match-lambda
-          ((w u)
-           (make-seq
-            src
+           ((w u)
             (make-seq
              src
-             (make-conditional
+             (make-seq
               src
-              ;; fixme: introduce logic to fold thunk?
-              (make-primcall src 'thunk? (list u))
-              (make-call src w '())
-              (make-primcall
-               src 'throw
-               (list
-                (make-const #f 'wrong-type-arg)
-                (make-const #f "dynamic-wind")
-                (make-const #f "Wrong type (expecting thunk): ~S")
-                (make-primcall #f 'list (list u))
-                (make-primcall #f 'list (list u)))))
-             (make-primcall src 'wind (list w u)))
-            (make-begin0 src
-                         (make-call src thunk '())
-                         (make-seq src
-                                   (make-primcall src 'unwind '())
-                                   (make-call src u '())))))))))
+              (make-conditional
+               src
+               ;; fixme: introduce logic to fold thunk?
+               (make-primcall src 'thunk? (list u))
+               (make-call src w '())
+               (make-primcall
+                src 'throw
+                (list
+                 (make-const #f 'wrong-type-arg)
+                 (make-const #f "dynamic-wind")
+                 (make-const #f "Wrong type (expecting thunk): ~S")
+                 (make-primcall #f 'list (list u))
+                 (make-primcall #f 'list (list u)))))
+              (make-primcall src 'wind (list w u)))
+             (make-begin0 src
+                          (make-call src thunk '())
+                          (make-seq src
+                                    (make-primcall src 'unwind '())
+                                    (make-call src u '())))))))))
 
       (($ <primcall> src 'with-fluid* (f v thunk))
        (for-tail
         (with-temporaries
          src (list f v thunk) 1 constant-expression?
          (match-lambda
-          ((f v thunk)
-           (make-seq src
-                     (make-primcall src 'push-fluid (list f v))
-                     (make-begin0 src
-                                  (make-call src thunk '())
-                                  (make-primcall src 'pop-fluid '()))))))))
+           ((f v thunk)
+            (make-seq src
+                      (make-primcall src 'push-fluid (list f v))
+                      (make-begin0 src
+                                   (make-call src thunk '())
+                                   (make-primcall src 'pop-fluid '()))))))))
 
       (($ <primcall> src 'with-dynamic-state (state thunk))
        (for-tail
         (with-temporaries
          src (list state thunk) 1 constant-expression?
          (match-lambda
-          ((state thunk)
-           (make-seq src
-                     (make-primcall src 'push-dynamic-state (list state))
-                     (make-begin0 src
-                                  (make-call src thunk '())
-                                  (make-primcall src 'pop-dynamic-state
-                                                 '()))))))))
+           ((state thunk)
+            (make-seq src
+                      (make-primcall src 'push-dynamic-state (list state))
+                      (make-begin0 src
+                                   (make-call src thunk '())
+                                   (make-primcall src 'pop-dynamic-state
+                                                  '()))))))))
 
       (($ <primcall> src 'values exps)
        (cond
@@ -1379,7 +1457,7 @@ top-level bindings from ENV and return the resulting expression."
          (((? equality-primitive?) (and a ($ <const>)) b)
           (for-tail (make-primcall src name (list b a))))
          (((? equality-primitive?) ($ <lexical-ref> _ _ sym)
-                                   ($ <lexical-ref> _ _ sym))
+           ($ <lexical-ref> _ _ sym))
           (for-tail (make-const src #t)))
 
          (('logbit? ($ <const> src2
@@ -1660,8 +1738,8 @@ top-level bindings from ENV and return the resulting expression."
                      ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
                   (not (tree-il-any
                         (match-lambda
-                         (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
-                         (_ #f))
+                          (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
+                          (_ #f))
                         body)))
                  (else #f)))
              (if (and (not escape-only?) (escape-only-handler? handler))