1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
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)))
|
