[Guile-commits] 01/02: Add eta-expansion pass after peval

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 2993c2d8731360f0dedd46a7da8a33bb711926a5
Author: Andy Wingo <address@hidden>
AuthorDate: Wed Jan 15 15:35:55 2020 +0100

    Add eta-expansion pass after peval
    
    * am/bootstrap.am (SOURCES):
    * module/Makefile.am (SOURCES): Add eta-expand.scm.
    * module/language/tree-il/eta-expand.scm: New file.
    * module/language/tree-il/optimize.scm (optimize)
      (tree-il-optimizations): Add eta-expansion at level 2.
---
 am/bootstrap.am                        |   3 +-
 module/Makefile.am                     |   1 +
 module/language/tree-il/eta-expand.scm | 171 +++++++++++++++++++++++++++++++++
 module/language/tree-il/optimize.scm   |   7 +-
 4 files changed, 179 insertions(+), 3 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 57370d3..f0476e2 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,4 +1,4 @@
-##     Copyright (C) 2009-2019 Free Software Foundation, Inc.
+##     Copyright (C) 2009-2020 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -66,6 +66,7 @@ SOURCES =                                     \
   language/tree-il/cps-primitives.scm          \
   language/tree-il/debug.scm                   \
   language/tree-il/effects.scm                 \
+  language/tree-il/eta-expand.scm              \
   language/tree-il/fix-letrec.scm              \
   language/tree-il/letrectify.scm              \
   language/tree-il/optimize.scm                        \
diff --git a/module/Makefile.am b/module/Makefile.am
index 3586ad5..1d9d524 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -190,6 +190,7 @@ SOURCES =                                   \
   language/tree-il/cps-primitives.scm          \
   language/tree-il/debug.scm                   \
   language/tree-il/effects.scm                 \
+  language/tree-il/eta-expand.scm              \
   language/tree-il/fix-letrec.scm              \
   language/tree-il/letrectify.scm              \
   language/tree-il/optimize.scm                        \
diff --git a/module/language/tree-il/eta-expand.scm 
b/module/language/tree-il/eta-expand.scm
new file mode 100644
index 0000000..d3af839
--- /dev/null
+++ b/module/language/tree-il/eta-expand.scm
@@ -0,0 +1,171 @@
+;;; Making lexically-bound procedures well-known
+
+;; Copyright (C) 2020 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 eta-expand)
+  #:use-module (ice-9 match)
+  #:use-module (language tree-il)
+  #:export (eta-expand))
+
+;; A lexically-bound procedure that is used only in operator position --
+;; i.e. the F in (F ARG ...) -- is said to be "well-known" if all of
+;; its use sites are calls and they can all be enumerated.  Well-known
+;; procedures can be optimized in a number of important ways:
+;; contification, call-by-label, shared closures, optimized closure
+;; representation, and closure elision.
+;;
+;; All procedures in a source program can be converted to become
+;; well-known by eta-expansion: wrapping them in a `lambda' that
+;; dispatches to the target procedure.  However, reckless eta-expansion
+;; has two downsides.  One drawback is that in some use cases,
+;; eta-expansion just adds wrappers for no purpose: if there aren't
+;; other uses of the procedure in operator position that could have
+;; gotten the call-by-label treatment and closure optimization, there's
+;; no point in making the closure well-known.
+;;
+;; The other drawback is that eta-expansion can confuse users who expect
+;; a `lambda' term in a source program to have a unique object identity.
+;; One might expect to associate a procedure with a value in an alist
+;; and then look up that value later on, but if the looked-up procedure
+;; is an eta-expanded wrapper, it won't be `eq?' to the previously-added
+;; procedure.  While this behavior is permitted by the R6RS, it breaks
+;; user expectations, often for no good reason due to the first problem.
+;;
+;; Therefore in Guile we have struck a balance: we will eta-expand
+;; procedures that are:
+;;   - lexically bound 
+;;   - not assigned
+;;   - referenced at least once in operator position
+;;   - referenced at most once in value position
+;;
+;; These procedures will be eta-expanded in value position only.  (We do
+;; this by eta-expanding all qualifying references, then reducing those
+;; expanded in call position.)
+;;
+;; In this way eta-expansion avoids introducing new procedure
+;; identities.
+;;
+;; Additionally, for implementation simplicity we restrict to procedures
+;; that only have required and possibly rest arguments.
+
+(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 (eta-expand expr)
+  (define (analyze-procs)
+    (define (proc-info proc)
+      (vector 0 0 proc))
+    (define (set-refcount! info count)
+      (vector-set! info 0 count))
+    (define (set-op-refcount! info count)
+      (vector-set! info 1 count))
+    (define proc-infos (make-hash-table))
+    (define (maybe-add-proc! gensym val)
+      (match val
+        (($ <lambda> src1 meta
+            ($ <lambda-case> src2 req #f rest #f () syms body #f))
+         (hashq-set! proc-infos gensym (proc-info val)))
+        (_ #f)))
+    (tree-il-for-each
+     (lambda (expr)
+       (match expr
+         (($ <lexical-ref> src name gensym)
+          (match (hashq-ref proc-infos gensym)
+            (#f #f)
+            ((and info #(total op proc))
+             (set-refcount! info (1+ total)))))
+
+         (($ <lexical-set> src name gensym)
+          (hashq-remove! proc-infos gensym))
+
+         (($ <call> src1 ($ <lexical-ref> src2 name gensym) args)
+          (match (hashq-ref proc-infos gensym)
+            (#f #f)
+            ((and info #(total op proc))
+             (set-op-refcount! info (1+ op)))))
+
+         (($ <let> src names gensyms vals body)
+          (for-each maybe-add-proc! gensyms vals))
+
+         (($ <letrec> src in-order? names gensyms vals body)
+          (for-each maybe-add-proc! gensyms vals))
+
+         (($ <fix> src names gensyms vals body)
+          (for-each maybe-add-proc! gensyms vals))
+
+         (_ #f)))
+     expr)
+    (define to-expand (make-hash-table))
+    (hash-for-each (lambda (sym info)
+                     (match info
+                       (#(total op proc)
+                        (when (and (not (zero? op))
+                                   (= (- total op) 1))
+                          (hashq-set! to-expand sym proc)))))
+                   proc-infos)
+    to-expand)
+
+  (let ((to-expand (analyze-procs)))
+    (define (eta-expand lexical)
+      (match lexical
+        (($ <lexical-ref> src name sym)
+         (match (hashq-ref to-expand sym)
+           (#f #f)
+           (($ <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))))))))
+    (define (eta-reduce proc)
+      (match proc
+        (($ <lambda> _ meta
+            ($ <lambda-case> _ req #f #f #f () syms
+               ($ <call> src ($ <lexical-ref> _ name sym)
+                  (($ <lexical-ref> _ _ arg) ...))
+               #f))
+         (and (equal? arg syms)
+              (make-lexical-ref src name sym)))
+        (($ <lambda> _ meta
+            ($ <lambda-case> _ req #f (not #f) #f () syms
+               ($ <primcall> src 'apply 
+                  (($ <lexical-ref> _ name sym) ($ <lexical-ref> _ _ arg) ...))
+               #f))
+         (and (equal? arg syms)
+              (make-lexical-ref src name sym)))
+        (_ #f)))
+    (post-order
+     (lambda (expr)
+       (match expr
+         (($ <lexical-ref>)
+          (or (eta-expand expr)
+              expr))
+
+         (($ <call> src proc args)
+          (match (eta-reduce proc)
+            (#f expr)
+            (proc (make-call src proc args))))
+
+         (_ expr)))
+     expr)))
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 96ccc75..4123781 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, 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010-2015, 2018-2020 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
@@ -21,6 +21,7 @@
 (define-module (language tree-il optimize)
   #:use-module (language tree-il)
   #:use-module (language tree-il debug)
+  #:use-module (language tree-il eta-expand)
   #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il letrectify)
   #:use-module (language tree-il peval)
@@ -56,6 +57,7 @@
   (run-pass letrectify*        #:letrectify?         #t)
   (set! x (fix-letrec x))
   (run-pass peval*             #:partial-eval?       #t)
+  (run-pass eta-expand         #:eta-expand?         #t)
   x)
 
 (define (tree-il-optimizations)
@@ -71,4 +73,5 @@
     (#:expand-primitives? 1)
     (#:letrectify? 2)
     (#:seal-private-bindings? 3)
-    (#:partial-eval? 1)))
+    (#:partial-eval? 1)
+    (#:eta-expand? 2)))