diff options
| -rw-r--r-- | am/bootstrap.am | 3 | ||||
| -rw-r--r-- | module/Makefile.am | 1 | ||||
| -rw-r--r-- | module/language/tree-il/eta-expand.scm | 171 | ||||
| -rw-r--r-- | 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 57370d30f..f0476e20a 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 3586ad505..1d9d524cf 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 000000000..d3af839b4 --- /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 96ccc7504..4123781bc 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))) |