Implement cross-module inlining

* 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.

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)))

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,6 +432,46 @@ 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?))
@@ -1027,8 +1068,45 @@ top-level bindings from ENV and return the resulting expression."
                    (make-primitive-ref src name)
                    exp))
              exp)))
-      (($ <module-ref>)
+      (($ <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)