[Guile-commits] 05/10: Add letrectify tree-il pass

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit d7bbf6d5db2f0eb2ee44557c5d3f65977f432ed3
Author: Andy Wingo <address@hidden>
Date:   Fri Aug 16 16:22:43 2019 +0200

    Add letrectify tree-il pass
    
    * module/language/tree-il/letrectify.scm: New pass, not wired up yet.
      Adds lexical definitions for declarative top-level definitions, for
      better inlining and contification within a compilation unit.
    * am/bootstrap.am:
    * module/Makefile.am: Add to build.
---
 am/bootstrap.am                        |   4 +-
 module/Makefile.am                     |   1 +
 module/language/tree-il/letrectify.scm | 252 +++++++++++++++++++++++++++++++++
 3 files changed, 255 insertions(+), 2 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 69a5911..57370d3 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,5 +1,4 @@
-##     Copyright (C) 2009, 2010, 2011, 2012, 2013,
-##        2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+##     Copyright (C) 2009-2019 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -68,6 +67,7 @@ SOURCES =                                     \
   language/tree-il/debug.scm                   \
   language/tree-il/effects.scm                 \
   language/tree-il/fix-letrec.scm              \
+  language/tree-il/letrectify.scm              \
   language/tree-il/optimize.scm                        \
   language/tree-il/peval.scm                   \
   language/tree-il/primitives.scm              \
diff --git a/module/Makefile.am b/module/Makefile.am
index 252ae12..fe31675 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -191,6 +191,7 @@ SOURCES =                                   \
   language/tree-il/debug.scm                   \
   language/tree-il/effects.scm                 \
   language/tree-il/fix-letrec.scm              \
+  language/tree-il/letrectify.scm              \
   language/tree-il/optimize.scm                        \
   language/tree-il/peval.scm                   \
   language/tree-il/primitives.scm              \
diff --git a/module/language/tree-il/letrectify.scm 
b/module/language/tree-il/letrectify.scm
new file mode 100644
index 0000000..2299f5b
--- /dev/null
+++ b/module/language/tree-il/letrectify.scm
@@ -0,0 +1,252 @@
+;;; transformation of top-level bindings into letrec*
+
+;; Copyright (C) 2019 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 library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+(define-module (language tree-il letrectify)
+  #:use-module ((srfi srfi-1) #:select (fold-right))
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:use-module (language tree-il)
+  #:use-module (language tree-il effects)
+  #:export (letrectify))
+
+;; Take a sequence of top-level definitions and turn the defintions into
+;; letrec*.  From this:
+;;
+;;    (begin
+;;      (define a 10)
+;;      (define b (lambda () a))
+;;      (foo a)
+;;      (define c (lambda () (set! c b) (c))))
+;;
+;; To this:
+;;
+;;    (letrec* ((a-var (module-make-local-var! (current-module) 'a))
+;;              (a 10)
+;;              (_ (begin (variable-set! a-var a)))
+;;              (b-var (module-make-local-var! (current-module) 'b))
+;;              (b (lambda () a))
+;;              ;; Note, declarative lambda definitions are eta-expanded when
+;;              ;; referenced by value to make the callee well-known in the
+;;              ;; compilation unit.
+;;              (_ (begin (variable-set! b-var (lambda () (b)))))
+;;              (_ (begin (foo a) #t))
+;;              (c-var (module-make-local-var! (current-module) 'c)))
+;;              (c (lambda () (variable-set! c-var b) ((variable-ref c-var))))
+;;              ;; Here `c' is not eta-expanded, as it's not a declarative
+;;              ;; binding.
+;;              (_ (begin (variable-set! c-var (lambda () (c))))))
+;;      (void))
+;;
+;; Inside the compilation unit, references to "declarative" top-level
+;; definitions are accessed directly as lexicals.  A declarative
+;; definition is a variable for which the expander knows the module,
+;; which is defined in the compilation unit exactly one time, and which
+;; is not assigned in the compilation unit.
+;;
+;; The assumption is that it's safe for the compiler to reason about the
+;; *values* of declarative bindings, because they are immutable in
+;; practice.  Of course someone can come later from another compilation
+;; unit or another module and use the private module API to mutate
+;; definitions from this compilation unit; in that case, updates from
+;; that third party may not be visible to users of declarative
+;; definitions.  That kind of use is not common, though.  The letrectify
+;; transformation is so important for performance that most users are
+;; willing to accept the restrictions of this transformation.
+;;
+;; Incidentally, the later fix-letrec and peval passes should optimize
+;; the above example to:
+;;
+;;    (begin
+;;      (variable-set! (module-make-local-var! (current-module) 'a) 10)
+;;      (variable-set! (module-make-local-var! (current-module) 'b)
+;;                     (lambda () 10))
+;;      (foo 10)
+;;      (let ((c-var (module-make-local-var! (current-module) 'c)))
+;;        (variable-set! c-var
+;;                       (lambda ()
+;;                         (variable-set! c-var (lambda () 10))
+;;                         ((variable-ref c-var))))
+;;        (void)))
+;;
+;; As you can see, letrectification allowed for inlining of the uses of
+;; both A and B.
+;;
+
+(define for-each-fold (make-tree-il-folder))
+(define (tree-il-for-each f x)
+  (for-each-fold x (lambda (x) (f x) (values)) (lambda (x) (values))))
+
+(define (module-conventional-bindings? mod) #t)
+
+(define (compute-declarative-toplevels x)
+  (define dynamic (make-hash-table))
+  (define defined (make-hash-table))
+  (define assigned (make-hash-table))
+  (tree-il-for-each
+   (lambda (x)
+     (match x
+       (($ <toplevel-set> src mod name)
+        (if mod
+            (hash-set! assigned (cons mod name) #t)
+            (hashq-set! dynamic name #t)))
+       (($ <toplevel-define> src mod name expr)
+        (if mod
+            (hash-set! (if (hash-ref defined (cons mod name))
+                           assigned
+                           defined)
+                       (cons mod name) expr)
+            (hashq-set! dynamic name #t)))
+       (_ (values))))
+   x)
+  (let ((declarative (make-hash-table)))
+    (define (conventional-module? mod)
+      (let ((m (resolve-module mod #f #:ensure #f)))
+        (and m (module-conventional-bindings? m))))
+    (hash-for-each (lambda (k expr)
+                     (match k
+                       ((mod . name)
+                        (unless (or (hash-ref assigned k)
+                                    (hashq-ref dynamic name)
+                                    (not (conventional-module? mod)))
+                          (hash-set! declarative k expr)))))
+                   defined)
+    declarative))
+
+(define (letrectify expr)
+  (define declarative (compute-declarative-toplevels expr))
+  (define declarative-box+value
+    (let ((tab (make-hash-table)))
+      (hash-for-each (lambda (key val)
+                       (hash-set! tab key (cons (gensym) (gensym))))
+                     declarative)
+      (lambda (mod name)
+        (hash-ref tab (cons mod name)))))
+
+  (define compute-effects
+    ;; Assume all lexicals are assigned, for the purposes of this
+    ;; transformation.  (It doesn't matter.)
+    (let ((assigned? (lambda (sym) #t)))
+      (make-effects-analyzer assigned?)))
+
+  (define (can-elide-statement? stmt)
+    (let ((effects (compute-effects stmt)))
+      (effect-free?
+       (exclude-effects effects (logior &allocation &zero-values)))))
+
+  (define (add-binding name var val tail)
+    (match tail
+      (($ <letrec> src #t names vars vals tail)
+       (make-letrec src #t
+                    (cons name names) (cons var vars) (cons val vals)
+                    tail))
+      (_
+       (make-letrec (tree-il-src tail) #t
+                    (list name) (list var) (list val)
+                    tail))))
+
+  (define (add-statement src stmt tail)
+    (if (can-elide-statement? stmt)
+        tail
+        (add-binding '_ (gensym "_") (make-seq src stmt (make-void src))
+                     tail)))
+
+  (define (residualize src mod name var expr)
+    (let ((lexical (make-lexical-ref src name var)))
+      (match expr
+        ;; Eta-expand so that we don't introduce functions-as-values.
+        (($ <lambda> src1 meta
+            ($ <lambda-case> src2 req #f rest #f () syms body #f))
+         (let* ((syms (map gensym (map symbol->string syms)))
+                (args (map (lambda (req sym) (make-lexical-ref src2 req sym))
+                           (if rest (append req (list rest)) req)
+                           syms))
+                (body (if rest
+                          (make-primcall src 'apply (cons lexical args))
+                          (make-call src lexical args))))
+           (make-lambda src1 meta
+                        (make-lambda-case src2 req #f rest #f '() syms
+                                          body #f))))
+        (_ lexical))))
+
+  (define (visit-expr expr)
+    (post-order
+     (lambda (expr)
+       (match expr
+         (($ <toplevel-ref> src mod name)
+          (match (declarative-box+value mod name)
+            (#f expr)
+            ((box . value)
+             (residualize src mod name value
+                          (hash-ref declarative (cons mod name))))))
+         (_ expr)))
+     expr))
+
+  (define (visit-top-level expr mod-vars)
+    (match expr
+      (($ <toplevel-define> src mod name exp)
+       (match (declarative-box+value mod name)
+         (#f (values (visit-expr expr) mod-vars))
+         ((box . value)
+          (match (assoc-ref mod-vars mod)
+            (#f
+             (let* ((mod-var (gensym "mod"))
+                    (mod-vars (acons mod mod-var mod-vars)))
+               (call-with-values (lambda () (visit-top-level expr mod-vars))
+                 (lambda (tail mod-vars)
+                   (values
+                    (add-binding 'mod
+                                 mod-var
+                                 (make-primcall src 'current-module '())
+                                 tail)
+                    mod-vars)))))
+            (mod-var
+             (let* ((loc
+                     (make-primcall src 'module-ensure-local-variable!
+                                    (list (make-lexical-ref src 'mod mod-var)
+                                          (make-const src name))))
+                    (exp (visit-expr exp))
+                    (ref (residualize src mod name value exp))
+                    (init
+                     (make-primcall src '%variable-set!
+                                    (list (make-lexical-ref src name box)
+                                          ref))))
+               (values
+                (add-binding
+                 name box loc
+                 (add-binding
+                  name value exp
+                  (add-statement src init (make-void src))))
+                mod-vars)))))))
+
+      (($ <seq> src head tail)
+       (let*-values (((head mod-vars) (visit-top-level head mod-vars))
+                     ((tail mod-vars) (visit-top-level tail mod-vars)))
+         
+         (values (match head
+                   (($ <letrec> src2 #t names vars vals head)
+                    (fold-right add-binding (add-statement src head tail)
+                                names vars vals))
+                   (else
+                    (add-statement src head tail)))
+                 mod-vars)))
+
+      ;; What would the advantages/disadvantages be if we flattened all
+      ;; bindings here, even those from nested let/letrec?
+      (_ (values (visit-expr expr) mod-vars))))
+
+  (values (visit-top-level expr '())))