guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 04/05: Add support for recording inlinable module export


From: Andy Wingo
Subject: [Guile-commits] 04/05: Add support for recording inlinable module exports
Date: Sun, 4 Apr 2021 16:24:19 -0400 (EDT)

wingo pushed a commit to branch wip-inlinable-exports
in repository guile.

commit dfec1375ec0b99c7c40da35c26abce2ba0264080
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Mar 23 21:11:44 2021 +0100

    Add support for recording inlinable module exports
    
    * module/language/tree-il/inlinable-exports.scm: New module.
    * am/bootstrap.am:
    * module/Makefile.am:
    * module/language/tree-il/optimize.scm (make-optimizer):
    * module/system/base/optimize.scm (available-optimizations): Wire up new
    module.
---
 am/bootstrap.am                               |   1 +
 module/Makefile.am                            |   1 +
 module/language/tree-il/inlinable-exports.scm | 820 ++++++++++++++++++++++++++
 module/language/tree-il/optimize.scm          |   6 +-
 module/system/base/optimize.scm               |   6 +-
 5 files changed, 830 insertions(+), 4 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 19e7af8..db8ec32 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -63,6 +63,7 @@ SOURCES =                                     \
   language/tree-il/effects.scm                 \
   language/tree-il/eta-expand.scm              \
   language/tree-il/fix-letrec.scm              \
+  language/tree-il/inlinable-exports.scm       \
   language/tree-il/letrectify.scm              \
   language/tree-il/optimize.scm                        \
   language/tree-il/peval.scm                   \
diff --git a/module/Makefile.am b/module/Makefile.am
index 30deeb7..e4f8e5c 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -88,6 +88,7 @@ SOURCES =                                     \
   language/tree-il/effects.scm                 \
   language/tree-il/eta-expand.scm              \
   language/tree-il/fix-letrec.scm              \
+  language/tree-il/inlinable-exports.scm       \
   language/tree-il/letrectify.scm              \
   language/tree-il/optimize.scm                        \
   language/tree-il/peval.scm                   \
diff --git a/module/language/tree-il/inlinable-exports.scm 
b/module/language/tree-il/inlinable-exports.scm
new file mode 100644
index 0000000..079599c
--- /dev/null
+++ b/module/language/tree-il/inlinable-exports.scm
@@ -0,0 +1,820 @@
+;;; Attaching inlinable definitions of exported bindings 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 inlinable-exports)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (language tree-il)
+  #:use-module ((srfi srfi-1) #:select (filter-map))
+  #:use-module (srfi srfi-9)
+  #:use-module (system syntax)
+  #:export (inlinable-exports))
+
+;;;
+;;; Inlining, as implemented by peval, is the mother of all
+;;; optimizations.  It opens up space for other optimizations to work,
+;;; such as constant folding, conditional branch folding, and so on.
+;;;
+;;; Inlining works naturally for lexical bindings.  Inlining of
+;;; top-level binding is facilitated by letrectification, which turns
+;;; top-level definition sequences to letrec*.  Here we facilitate
+;;; inlining across module boundaries, so that module boundaries aren't
+;;; necessarily optimization boundaries.
+;;;
+;;; The high-level idea is to attach a procedure to the module being
+;;; compiled, which when called with a name of an export of that module
+;;; will return a Tree-IL expression that can be copied into the use
+;;; site.  There are two parts: first we determine the set of inlinable
+;;; bindings, and then we compile that mapping to a procedure and attach
+;;; it to the program being compiled.
+;;;
+;;; Because we don't want inter-module inlining to inhibit intra-module
+;;; inlining, this pass is designed to run late in the Tree-IL
+;;; optimization pipeline -- after letrectification, after peval, and so
+;;; on.  Unfortunately this does mean that we have to sometimes
+;;; pattern-match to determine higher-level constructs from lower-level
+;;; residual code, for example to map back from
+;;; module-ensure-local-variable! + %variable-set! to toplevel-define,
+;;; as reduced by letrectification.  Ah well.
+;;;
+;;; Ultimately we want to leave the decision to peval as to what to
+;;; inline or not to inline, based on its size and effort counters.  But
+;;; still we do need to impose some limits -- there's no sense in
+;;; copying a large constant from one module to another, for example.
+;;; Similarly there's no sense in copying a very large procedure.
+;;; Generally speaking we use an effort counter, as peval does, to bound
+;;; size.  .
+;;;
+;;; There are some semantic limitations -- you wouldn't want to copy a
+;;; mutable value, nor would you want to copy a closure with free
+;;; variables.
+;;;
+;;; Once the set of inlinables is determined, we copy them and rename
+;;; their lexicals.  Any reference to an exported binding by lexical
+;;; variable is rewritten in terms of a reference to the exported
+;;; binding.
+;;;
+;;; The result is then compiled to a procedure, which internally has a
+;;; small interpreter for a bytecode, along with a set of constants.
+;;; The assumption is that most of the constants will be written to the
+;;; object file anyway, so we aren't taking up more space there.  Any
+;;; non-immediate is built on demand, so we limit the impact of
+;;; including inlinable definitions on load-time relocations,
+;;; allocations, and heap space.
+;;;
+
+(define (put-uleb port val)
+  (let lp ((val val))
+    (let ((next (ash val -7)))
+      (if (zero? next)
+          (put-u8 port val)
+          (begin
+            (put-u8 port (logior #x80 (logand val #x7f)))
+            (lp next))))))
+
+(define (known-vtable vtable)
+  (define-syntax-rule (tree-il-case vt ...)
+    (cond
+     ((eq? vtable vt) (values '(language tree-il) 'vt))
+     ...
+     (else (values #f #f))))
+  (tree-il-case <void>
+                <const>
+                <primitive-ref>
+                <lexical-ref>
+                <lexical-set>
+                <module-ref>
+                <module-set>
+                <toplevel-ref>
+                <toplevel-set>
+                <toplevel-define>
+                <conditional>
+                <call>
+                <primcall>
+                <seq>
+                <lambda>
+                <lambda-case>
+                <let>
+                <letrec>
+                <fix>
+                <let-values>
+                <prompt>
+                <abort>))
+
+;;
+;; Design -- assembler can already encode constants
+
+(define-record-type <encoding>
+  (%make-encoding constants vtables pair-code next-code)
+  encoding?
+  (constants constants)
+  (vtables vtables)
+  (pair-code pair-code set-pair-code!)
+  (next-code next-code set-next-code!))
+
+(define (make-encoding)
+  (%make-encoding (make-hash-table) (make-hash-table) #f 0))
+
+(define (vtable-nfields vtable)
+  (define vtable-index-size 5) ; FIXME: pull from struct.h
+  (struct-ref/unboxed vtable vtable-index-size))
+
+(define (build-encoding! term encoding)
+  (define (next-code!)
+    (let ((code (next-code encoding)))
+      (set-next-code! encoding (1+ code))
+      code))
+
+  (define (intern-constant! x)
+    (unless (hash-ref (constants encoding) x)
+      (hash-set! (constants encoding) x (next-code!))))
+  (define (intern-vtable! x)
+    (unless (hashq-ref (vtables encoding) x)
+      (hashq-set! (vtables encoding) x (next-code!))))
+  (define (ensure-pair-code!)
+    (unless (pair-code encoding)
+      (set-pair-code! encoding (next-code!))))
+
+  (let visit ((term term))
+    (cond
+     ((pair? term)
+      (ensure-pair-code!)
+      (visit (car term))
+      (visit (cdr term)))
+     ((struct? term)
+      (let ((vtable (struct-vtable term)))
+        (unless (known-vtable vtable)
+          (error "struct of unknown type" term))
+        (intern-vtable! vtable)
+        (let ((nfields (vtable-nfields vtable)))
+          (let lp ((i 0))
+            (when (< i nfields)
+              (visit (struct-ref term i))
+              (lp (1+ i)))))))
+     (else
+      (intern-constant! term)))))
+
+(define (compute-decoder encoding)
+  (define (pair-clause code)
+    `((eq? code ,code)
+      (let* ((car (lp))
+             (cdr (lp)))
+        (cons car cdr))))
+  (define (vtable-clause vtable code)
+    (call-with-values (lambda () (known-vtable vtable))
+      (lambda (mod name)
+        (let ((fields (map (lambda (i) (string->symbol (format #f "f~a" i)))
+                           (iota (vtable-nfields vtable)))))
+          `((eq? code ,code)
+            (let* (,@(map (lambda (field) `(,field (lp))) fields))
+              (make-struct/no-tail (@ ,mod ,name) ,@fields)))))))
+  (define (constant-clause constant code)
+    `((eq? code ,code) ',constant))
+
+  `(lambda (bv)
+     (define pos 0)
+     (define (next-u8!)
+       (let ((u8 (bytevector-u8-ref bv pos)))
+         (set! pos (1+ pos))
+         u8))
+     (define (next-uleb!)
+       ,(if (< (next-code encoding) #x80)
+            ;; No need for uleb decoding in this case.
+            '(next-u8!)
+            '(let lp ((n 0) (shift 0))
+               (let ((b (next-u8!)))
+                 (if (zero? (logand b #x80))
+                     (logior (ash b shift) n)
+                     (lp (logior (ash (logxor #x80 b) shift) n)
+                         (+ shift 7)))))))
+     (let lp ()
+       (let ((code (next-uleb!)))
+         (cond
+          ,@(if (pair-code encoding)
+                (list (pair-clause (pair-code encoding)))
+                '())
+          ,@(hash-map->list vtable-clause (vtables encoding))
+          ,@(hash-map->list constant-clause (constants encoding))
+          (else (error "bad code" code)))))))
+
+(define (encode term encoding)
+  (call-with-output-bytevector
+   (lambda (port)
+     (define (put x) (put-uleb port x))
+     (let visit ((term term))
+       (cond
+        ((pair? term)
+         (put (pair-code encoding))
+         (visit (car term))
+         (visit (cdr term)))
+        ((struct? term)
+         (let* ((vtable (struct-vtable term))
+                (nfields (vtable-nfields vtable)))
+           (put (hashq-ref (vtables encoding) vtable))
+           (let lp ((i 0))
+             (when (< i nfields)
+               (visit (struct-ref term i))
+               (lp (1+ i))))))
+        (else
+         (put (hash-ref (constants encoding) term))))))))
+
+(define (compute-encoding bindings)
+  (let ((encoding (make-encoding)))
+    (for-each (match-lambda
+                ((name . expr) (build-encoding! expr encoding)))
+              bindings)
+    (let ((encoded (map (match-lambda
+                          ((name . expr) (cons name (encode expr encoding))))
+                        bindings)))
+      `(lambda (name)
+         (define decode ,(compute-decoder encoding))
+         (cond
+          ,@(map (match-lambda
+                   ((name . bv)
+                    `((eq? name ',name) (decode ,bv))))
+                 encoded)
+          (else #f))))))
+
+;; pending:
+;;
+;; - add module field.
+;;
+;; - define inlinable? predicate:
+;;     exported && declarative && only references public vars && not too big
+;;
+;; - public := exported from a module, at -O2 and less.
+;;   at -O3 and higher public just means defined in any module.
+;;
+;; - yeet the generated encoding into the define-module invocation.
+;;
+;; - make peval reach into these inlinable procs.
+
+;; Two forms of top-level definitions:
+;;   toplevel-define
+;;   module-ensure-local-variable! + %variable-set!
+
+(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 (compute-assigned-toplevels exp)
+  (define assigned-toplevels '())
+  (define (add-assigned-toplevel! mod name)
+    (set! assigned-toplevels (acons mod name assigned-toplevels)))
+  ((make-tree-il-folder)
+   exp
+   (lambda (exp)
+     (match exp
+       (($ <toplevel-set> _ mod name _)
+        (add-assigned-toplevel! mod name)
+        (values))
+       (($ <module-set> src mod name public? exp)
+        (unless public?
+          (add-assigned-toplevel! mod name))
+        (values))
+       (_ (values))))
+   (lambda (exp)
+     (values)))
+  assigned-toplevels)
+
+;;; FIXME: 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-module-bindings exp)
+  (define assigned-lexicals (compute-assigned-lexicals exp))
+  (define assigned-toplevels (compute-assigned-toplevels exp))
+  (define module-definitions '())
+  (define lexicals (make-hash-table))
+  (define module-lexicals '())
+  (define variable-lexicals '())
+  (define binding-lexicals '())
+  (define binding-values '())
+  (define (add-module-definition! mod args)
+    (set! module-definitions (acons mod args module-definitions)))
+  (define (add-lexical! var val)
+    (unless (memq var assigned-lexicals)
+      (hashq-set! lexicals var val)))
+  (define (add-module-lexical! var mod)
+    (unless (memq var assigned-lexicals)
+      (set! module-lexicals (acons var mod module-lexicals))))
+  (define (add-variable-lexical! var mod name)
+    (unless (memq var assigned-lexicals)
+      (set! variable-lexicals (acons var (cons mod name) variable-lexicals))))
+  (define (add-binding-lexical! var mod name)
+    (unless (memq var assigned-lexicals)
+      (set! binding-lexicals (acons var (cons mod name) binding-lexicals))))
+  (define (add-binding-value! mod name val)
+    (set! binding-values (acons (cons mod name) val binding-values)))
+
+  (define (record-bindings! mod gensyms vals)
+    (for-each
+     (lambda (var val)
+       (add-lexical! 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)))
+         (($ <primcall> _ 'module-ensure-local-variable!
+             (($ <lexical-ref> _ _ mod-var) ($ <const> _ name)))
+          (let ((mod (assq-ref module-lexicals mod-var)))
+            (when mod
+              (add-variable-lexical! var mod name))))
+         (_ #f)))
+     gensyms 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 assigned or
+  ;; multiply-defined variables.  Record definitions by matching
+  ;; toplevel-define forms, but also by matching separate
+  ;; module-ensure-local-variable! + %variable-set, as residualized by
+  ;; letrectification.
+  (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))
+
+      (($ <primcall> src '%variable-set! (($ <lexical-ref> _ _ var)
+                                          val))
+       (match (assq-ref variable-lexicals var)
+         ((mod . name)
+          (add-binding-value! mod name val)
+          ;; Also record lexical for eta-expanded bindings.
+          (match val
+            (($ <lambda> _ _
+                ($ <lambda-case> _ req #f #f #f () (arg ...)
+                   ($ <call> _
+                      (and eta ($ <lexical-ref> _ _ var))
+                      (($ <lexical-ref> _ _ arg) ...))
+                   #f))
+             (add-binding-lexical! var mod name))
+            (($ <lambda> _ _
+                ($ <lambda-case> _ req #f (not #f) #f () (arg ...)
+                   ($ <primcall> _ 'apply
+                      ((and eta ($ <lexical-ref> _ _ var))
+                       ($ <lexical-ref> _ _ arg) ...))
+                   #f))
+             (add-binding-lexical! var mod name))
+            (($ <lexical-ref> _ _ var)
+             (add-binding-lexical! var mod name))
+            (_ #f)))
+         (_ #f))
+       (visit/mod val mod))
+
+      (($ <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-value! mod name exp)
+       (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)
+       (visit body)
+       (when alternate (visit alternate))
+       (values))
+
+      (($ <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))
+       #f)
+
+      (($ <prompt> src escape-only? tag body handler)
+       (visit tag)
+       (visit body)
+       (visit handler)
+       #f)
+
+      (($ <abort> src tag args tail)
+       (visit tag)
+       (visit* args)
+       (visit tail)
+       #f)))
+
+  (visit exp)
+  (values module-definitions lexicals binding-lexicals binding-values))
+
+;; - define inlinable? predicate:
+;;     exported && declarative && only references public vars && not too big
+;;
+;; - public := exported from a module, at -O2 and less.
+;;   at -O3 and higher public just means defined in any module.
+(define (inlinable-exp mod exports lexicals binding-lexicals exp)
+  (define fresh-var!
+    (let ((counter 0))
+      (lambda ()
+        (let ((name (string-append "t" (number->string counter))))
+          (set! counter (1+ counter))
+          (string->symbol name)))))
+  (define (fresh-vars vars)
+    (match vars
+      (() '())
+      ((_ . vars) (cons (fresh-var!) (fresh-vars vars)))))
+  (define (add-bound-vars old new bound)
+    (match (vector old new)
+      (#(() ()) bound)
+      (#((old . old*) (new . new*))
+       (add-bound-vars old* new* (acons old new bound)))))
+  (let/ec return
+    (define (abort!) (return #f))
+    (define count!
+      ;; Same as default operator size limit for peval.
+      (let ((counter 40))
+        (lambda ()
+          (set! counter (1- counter))
+          (when (zero? counter) (abort!)))))
+    (define (residualize-module-private-ref src mod' name)
+      ;; TODO: At -O3, we could residualize a private
+      ;; reference.  But that could break peoples'
+      ;; expectations.
+      (abort!))
+    (define (eta-reduce exp)
+      ;; Undo the result of eta-expansion pass.
+      (match exp
+        (($ <lambda> _ _
+            ($ <lambda-case> _ req #f #f #f () (sym ...)
+               ($ <call> _
+                  (and eta ($ <lexical-ref>)) (($ <lexical-ref> _ _ sym) ...))
+               #f))
+         eta)
+        (($ <lambda> _ _
+            ($ <lambda-case> _ req #f (not #f) #f () (sym ...)
+               ($ <primcall> _ 'apply 
+                  ((and eta ($ <lexical-ref>)) ($ <lexical-ref> _ _ sym) ...))
+               #f))
+         eta)
+        (_ exp)))
+
+    (let copy ((exp (eta-reduce exp)) (bound '()) (in-lambda? #f))
+      (define (recur exp) (copy exp bound in-lambda?))
+      (count!)
+      (match exp
+        ((or ($ <void>) ($ <primitive-ref>) ($ <module-ref>))
+         exp)
+
+        (($ <const> src val)
+         (match val
+           ;; Don't copy values that could be "too big".
+           ((? string?) exp) ; Oddly, (array? "") => #t.
+           ((or (? pair?) (? syntax?) (? array?))
+            (abort!))
+           (_ exp)))
+
+        (($ <lexical-ref> src name var)
+         (cond
+          ;; Rename existing lexicals.
+          ((assq-ref bound var)
+           => (lambda (var)
+                (make-lexical-ref src name var)))
+          ;; A free variable reference to a lambda, outside a lambda.
+          ;; Could be the lexical-ref residualized by letrectification.
+          ;; Copy and rely on size limiter to catch runaways.
+          ((and (not in-lambda?) (lambda? (hashq-ref lexicals var)))
+           (recur (hashq-ref lexicals var)))
+          ((not in-lambda?)
+           ;; No advantage to "inline" a toplevel to another toplevel.
+           (abort!))
+          ;; Some letrectified toplevels will be bound to lexical
+          ;; variables, but unless the module has sealed private
+          ;; bindings, there may be an associated top-level variable
+          ;; as well.
+          ((assq-ref binding-lexicals var)
+           => (match-lambda
+                ((mod' . name)
+                 (cond
+                  ((and (equal? mod' mod) (assq-ref exports name))
+                   => (lambda (public-name)
+                        (make-module-ref src mod public-name #t)))
+                  (else
+                   (residualize-module-private-ref src mod' name))))))
+          ;; A free variable reference.  If it's in the program at this
+          ;; point, that means that peval didn't see fit to copy it, so
+          ;; there's no point in trying to do so here.
+          (else (abort!))))
+
+        (($ <toplevel-ref> src mod' name)
+         (cond
+          ;; Rewrite private references to exported bindings into public
+          ;; references.  Peval can decide whether to continue inlining
+          ;; or not.
+          ((and (equal? mod mod') (assq-ref exports name))
+           => (lambda (public-name)
+                (make-module-ref src mod public-name #t)))
+          (else
+           (residualize-module-private-ref src mod' name))))
+
+        (($ <call> src proc args)
+         (unless in-lambda? (abort!))
+         (make-call src (recur proc) (map recur args)))
+
+        (($ <primcall> src name args)
+         (unless in-lambda? (abort!))
+         (make-primcall src name (map recur args)))
+
+        (($ <conditional> src test consequent alternate)
+         (unless in-lambda? (abort!))
+         (make-conditional src (recur test)
+                           (recur consequent) (recur alternate)))
+
+        (($ <lexical-set> src name var exp)
+         (unless in-lambda? (abort!))
+         (cond
+          ((assq-ref bound var)
+           => (lambda (var)
+                (make-lexical-set src name var (recur exp))))
+          (else
+           (abort!))))
+
+        ((or ($ <toplevel-set>)
+             ($ <module-set>)
+             ($ <toplevel-define>))
+         (abort!))
+
+        (($ <lambda> src meta body)
+         ;; Remove any lengthy docstring.
+         (let ((meta (filter-map (match-lambda
+                                   (('documentation . _) #f)
+                                   (pair pair))
+                                 meta)))
+           (make-lambda src meta (and body (copy body bound #t)))))
+
+        (($ <lambda-case> src req opt rest kw inits vars body alternate)
+         (unless in-lambda? (abort!))
+         (let* ((vars* (fresh-vars vars))
+                (bound (add-bound-vars vars vars* bound)))
+           (define (recur* exp) (copy exp bound #t))
+           (make-lambda-case src req opt rest
+                             (match kw
+                               (#f #f)
+                               ((aok? . kws)
+                                (cons aok?
+                                      (map
+                                       (match-lambda
+                                         ((kw name var)
+                                          (list kw name (assq-ref var bound))))
+                                       kws))))
+                             (map recur* inits)
+                             vars*
+                             (recur* body)
+                             (and alternate (recur alternate)))))
+
+        (($ <seq> src head tail)
+         (unless in-lambda? (abort!))
+         (make-seq src (recur head) (recur tail)))
+        
+        (($ <let> src names vars vals body)
+         (unless in-lambda? (abort!))
+         (let* ((vars* (fresh-vars vars))
+                (bound (add-bound-vars vars vars* bound)))
+           (define (recur* exp) (copy exp bound #t))
+           (make-let src names vars* (map recur vals) (recur* body))))
+
+        (($ <letrec> src in-order? names vars vals body)
+         (unless in-lambda? (abort!))
+         (let* ((vars* (fresh-vars vars))
+                (bound (add-bound-vars vars vars* bound)))
+           (define (recur* exp) (copy exp bound #t))
+           (make-letrec src in-order? names vars* (map recur* vals)
+                        (recur* body))))
+
+        (($ <fix> src names vars vals body)
+         (unless in-lambda? (abort!))
+         (let* ((vars* (fresh-vars vars))
+                (bound (add-bound-vars vars vars* bound)))
+           (define (recur* exp) (copy exp bound #t))
+           (make-fix src names vars* (map recur* vals)
+                     (recur* body))))
+
+        (($ <let-values> src exp body)
+         (unless in-lambda? (abort!))
+         (make-let-values src (recur exp) (recur body)))
+
+        (($ <prompt> src escape-only? tag body handler)
+         (unless in-lambda? (abort!))
+         (make-prompt src escape-only?
+                      (recur tag) (recur body) (recur handler)))
+
+        (($ <abort> src tag args tail)
+         (unless in-lambda? (abort!))
+         (make-abort src (recur tag) (map recur args) (recur tail)))))))
+
+(define (compute-inlinable-bindings exp)
+  "Traverse @var{exp}, extracting module-level definitions."
+
+  (define-values (modules lexicals binding-lexicals bindings)
+    (compute-module-bindings 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 modules-with-inlinable-exports
+    (let lp ((defs modules) (not-inlinable '()) (inlinable '()))
+      (match defs
+        (() inlinable)
+        (((mod . args) . defs)
+         (cond ((member mod not-inlinable)
+                (lp defs not-inlinable inlinable))
+               ((or (assoc mod defs) ;; doubly defined?
+                    (not (has-constant-initarg? args #:declarative? #t)))
+                (lp defs (cons mod not-inlinable) inlinable))
+               (else
+                (lp defs not-inlinable (cons mod inlinable))))))))
+
+  ;; Omit multiply-defined bindings, and definitions not in declarative
+  ;; modules.
+  (define non-declarative-definitions
+    (let lp ((bindings bindings) (non-declarative '()))
+      (match bindings
+        (() non-declarative)
+        ((((and mod+name (mod . name)) . val) . bindings)
+         (cond
+          ((member mod+name non-declarative)
+           (lp bindings non-declarative))
+          ((or (assoc mod+name bindings)
+               (not (member mod modules-with-inlinable-exports)))
+           (lp bindings (cons mod+name non-declarative)))
+          (else
+           (lp bindings non-declarative)))))))
+
+  (define exports
+    (map (lambda (module)
+           (define args (assoc-ref modules module))
+           ;; Return list of (PRIVATE-NAME . PUBLIC-NAME) pairs.
+           (define (extract-exports kw)
+             (kwarg-ref/const args kw
+                              (lambda (val)
+                                (map (match-lambda
+                                       ((and pair (private . public)) pair)
+                                       (name (cons name name)))
+                                     val))
+                              (lambda () '())))
+           (cons module
+                 (append (extract-exports #:exports)
+                         (extract-exports #:replacements))))
+         modules-with-inlinable-exports))
+
+  ;; Compute ((PRIVATE-NAME . PUBLIC-NAME) . VALUE) pairs for each
+  ;; module with inlinable bindings, for exported bindings only.
+  (define inlinable-candidates
+    (map
+     (lambda (module)
+       (define name-pairs (assoc-ref exports module))
+       (define (name-pair private-name)
+         (assq private-name name-pairs))
+       (cons module
+             (filter-map
+              (match-lambda
+                (((and mod+name (mod . name)) . val)
+                 (and (equal? module mod)
+                      (not (member mod+name non-declarative-definitions))
+                      (and=> (name-pair name)
+                             (lambda (pair) (cons pair val))))))
+              bindings)))
+     modules-with-inlinable-exports))
+
+  (define inlinables
+    (filter-map
+     (match-lambda
+       ((mod . exports)
+        (let ((name-pairs (map car exports)))
+          (match (filter-map
+                  (match-lambda
+                    ((name-pair . val)
+                     (match (inlinable-exp mod name-pairs lexicals
+                                           binding-lexicals val)
+                       (#f #f)
+                       (val (cons name-pair val)))))
+                  exports)
+            (() #f)
+            (exports (cons mod exports))))))
+     inlinable-candidates))
+
+  inlinables)
+
+(use-modules (system base compile) (language tree-il optimize))
+(define* (test-inlinables file #:key (optimization-level 2))
+  (define env (current-module))
+  (define term (call-with-input-file file
+                 (lambda (p) (read-and-compile p #:to 'tree-il #:env env))))
+  (define opt ((make-lowerer optimization-level '()) term env))
+  (compute-inlinable-bindings opt))
+
+(define (attach-inlinables exp inlinables)
+  exp)
+
+(define (inlinable-exports exp)
+  (attach-inlinables exp (compute-inlinable-bindings exp)))
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index ba55f97..264cd64 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009, 2010-2015, 2018-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010-2015, 2018-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
@@ -45,7 +45,8 @@
         (letrectify (lookup #:letrectify? letrectify))
         (seal?      (assq-ref opts #:seal-private-bindings?))
         (peval      (lookup #:partial-eval? peval))
-        (eta-expand (lookup #:eta-expand? eta-expand)))
+        (eta-expand (lookup #:eta-expand? eta-expand))
+        (inlinables (lookup #:inlinable-exports? inlinable-exports)))
     (define-syntax-rule (run-pass! (proc exp arg ...))
       (when proc (set! exp (verify (proc exp arg ...)))))
     (lambda (exp env)
@@ -57,6 +58,7 @@
       (run-pass! (fix-letrec exp))
       (run-pass! (peval exp env))
       (run-pass! (eta-expand exp))
+      (run-pass! (inlinables exp))
       exp)))
 
 (define (optimize x env opts)
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
index 93f692f..94a79e3 100644
--- a/module/system/base/optimize.scm
+++ b/module/system/base/optimize.scm
@@ -1,6 +1,6 @@
 ;;; Optimization flags
 
-;; Copyright (C) 2018, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2018, 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
@@ -34,7 +34,9 @@
        (#:letrectify? 2)
        (#:seal-private-bindings? 3)
        (#:partial-eval? 1)
-       (#:eta-expand? 2)))
+       (#:eta-expand? 2)
+       (#:inlinable-exports? 1)
+       (#:cross-module-inlining? 2)))
     ('cps
      '( ;; (#:split-rec? #t)
        (#:simplify? 2)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]