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
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
; Copyright (c) 1993-2008 by Richard Kelsey. See file COPYING.
; Call JOIN-SUBSTITUTE on all variable/value pairs.
(define (substitute-join-arguments lambda-proc call)
(let ((vec (call-args call))
(vars (lambda-variables lambda-proc)))
(do ((vars vars (cdr vars))
(i 1 (+ i 1))
(c? #f (or (join-substitute (car vars) (vector-ref vec i))
c?)))
((null? vars) c?))))
; Does VAL take only one argument and is that argument passed to $TEST?
; Is VAR applied to constants?
; Then two possiblities are checked for:
; Does the tree rooted at the least-common-ancestor of VAR's references
; contain no side-effects and necessarily passed control to VAR?
; or
; Does the join point contain no side-effects above the test?
;
; If so, make the transformation described below.
(define (join-substitute var val)
(let ((ref (and (lambda-node? val)
(simple-test-procedure val))))
(and ref
(applied-to-useful-value? var ref)
(let ((lca (least-common-ancestor (variable-refs var))))
(cond ((or (suitable-join-conditional? lca var)
(suitable-join-point? val (node-parent ref)))
(really-join-substitute var val lca (node-parent ref))
#t)
(else #f))))))
; Check that VAL (a lambda-node) takes one argument, is jumped to, tests its
; argument, and that all references to the argument are at or below the test.
(define (simple-test-procedure val)
(let ((vars (lambda-variables val)))
(if (or (null? vars)
(not (null? (cdr vars)))
(not (car vars))
(not (calls-known? val))
(neq? 'jump (lambda-type val)))
#f
(let* ((var (car vars))
(ref (any simple-cond-ref (variable-refs var))))
(if (and ref (all-refs-below? var (node-parent ref)))
ref
#f)))))
(define (simple-cond-ref ref)
(if (primop-conditional? (call-primop (node-parent ref)))
ref
#f))
(define (all-refs-below? var node)
(set-node-flag! node #t)
(set-node-flag! (variable-binder var) #t)
(let ((res (every? (lambda (r)
(eq? node (marked-ancestor r)))
(variable-refs var))))
(set-node-flag! node #f)
(set-node-flag! (variable-binder var) #f)
res))
; Is VAR applied to something that can be used to simplify the conditional?
(define (applied-to-useful-value? var ref)
(let ((call (node-parent ref))
(index (node-index ref)))
(any? (lambda (r)
(simplify-conditional? call index (call-arg (node-parent r) 1)))
(variable-refs var))))
; CALL is the least-common-ancestor of the references to VAR. Check that
; the tree rooted at CALL contains no side-effects and that the control flow
; necessarily passes to VAR. (Could check for undefined-effect here...)
; could do check that jumped-to proc if not VAR jumped to VAR eventually
(define (suitable-join-conditional? call var)
(let label ((call call))
(cond ((call-side-effects? call)
#f)
((= 0 (call-exits call))
(and (eq? 'jump (primop-id (call-primop call)))
(eq? var (reference-variable (called-node call)))))
(else
(let loop ((i 0))
(cond ((>= i (call-exits call))
#t)
((not (label (lambda-body (call-arg call i))))
#f)
(else
(loop (+ i 1)))))))))
; #t if CALL performs side-effects. The continuations to CALL are ignored.
(define (call-side-effects? call)
(or (primop-side-effects (call-primop call))
(let loop ((i (call-exits call)))
(cond ((>= i (call-arg-count call))
#f)
((side-effects? (call-arg call i))
#t)
(else
(loop (+ i 1)))))))
; The alternative to the above test: does the join point contain no side-effects
; above the test?
(define (suitable-join-point? join test)
(let label ((call (lambda-body join)))
(cond ((eq? call test)
#t)
((call-side-effects? call)
#f)
(else
(let loop ((i 0))
(cond ((>= i (call-exits call))
#t)
((not (label (lambda-body (call-arg call i))))
#f)
(else
(loop (+ i 1)))))))))
; (let ((j (lambda (v) ; VAR VAL
; .a.
; ($test c1 c2 ... v ...) ; TEST
; .b.)))
; .c.
; (... (j x) ...) ; CALL
; .d.)
; ==>
; .c.
; (.a.
; (let ((v1 (lambda (x) c1[x/v]))
; (v2 (lambda (x) c2[x/v])))
; (... ((lambda (v)
; ($test (lambda () (v1 v)) (lambda () (v2 v)) ... v ...))
; x)
; ...))
; .b.)
; .d.
;
; CALL is the least common ancestor of the references to VAR, which is bound to
; VAL, a procedure. TEST is a conditional that tests the argument passed to
; VAL.
;
; (lambda-body VAL) is moved to where CALL is.
; In the body of VAL, TEST is replaced by a LET that binds TEST's continuations
; and then executes CALL. TEST's continuations are replaced by calls to
; the variables bound by the LET.
; Finally, references to VAR are replaced by a procedure whose body is TEST,
; which is the point of the whole exercise.
(define (really-join-substitute var val call test)
(let ((value-var (car (lambda-variables val))))
(receive (cont-call conts)
(move-continuations test call value-var)
(let ((test-parent (node-parent test))
(val-parent (node-parent val))
(val-index (node-index val)))
(parameterize-continuations conts value-var)
(detach-body test)
(move-body cont-call
(lambda (cont-call)
(attach-body test-parent cont-call)
(detach-body (lambda-body val))))
(attach-body val test)
(mark-changed (call-arg test 1)) ; marks test as changed.
(mark-changed cont-call)
(substitute var val #t)
(attach val-parent val-index (make-literal-node #f #f))
(values)))))
; Move the continuations of CALL to a LET call just above TO. Returns a list
; of the variables now bound to the continuations and the continuations
; themselves.
(define (move-continuations call to arg-var)
(let ((count (call-exits call)))
(let loop ((i (- count 1)) (vs '()) (es '()))
(cond ((< i 0)
(let ((new-call (make-call-node (get-primop (enum primop let))
(+ count 1)
1))
(new-proc (make-lambda-node 'j 'cont vs)))
(attach-call-args new-call (cons new-proc es))
(insert-body new-call new-proc (node-parent to))
(values new-call es)))
(else
(let ((var (make-variable 'e (node-type (call-arg call i))))
(cont (detach (call-arg call i))))
(let-nodes ((new-cont () c1)
(c1 (jump 0 (* var) (* arg-var))))
(attach call i new-cont))
(change-lambda-type cont 'jump)
(loop (- i 1) (cons var vs) (cons cont es))))))))
; Add a new variable to each of CONTS and substitute a reference to the correct
; variable for each reference to VAR within CONTS.
(define (parameterize-continuations conts var)
(for-each (lambda (n)
(let ((var (copy-variable var)))
(set-lambda-variables! n (cons var (lambda-variables n)))
(set-variable-binder! var n)
(set-node-flag! n #t)))
conts)
(let ((backstop (variable-binder var)))
(set-node-flag! backstop #t)
(walk-refs-safely
(lambda (n)
(let ((cont (marked-ancestor n)))
(if (not (eq? cont backstop))
(replace n (make-reference-node (car (lambda-variables cont)))))))
var)
(set-node-flag! backstop #f)
(for-each (lambda (n) (set-node-flag! n #f)) conts)
(values)))
|
