Commit | Line | Data |
---|---|---|
8bc65d2d AW |
1 | ;;; Abstract constant folding on CPS |
2 | ;;; Copyright (C) 2014 Free Software Foundation, Inc. | |
3 | ;;; | |
4 | ;;; This library is free software: you can redistribute it and/or modify | |
5 | ;;; it under the terms of the GNU Lesser General Public License as | |
6 | ;;; published by the Free Software Foundation, either version 3 of the | |
7 | ;;; License, or (at your option) any later version. | |
8 | ;;; | |
9 | ;;; This library is distributed in the hope that it will be useful, but | |
10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;; Lesser General Public License for more details. | |
13 | ;;; | |
14 | ;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;; License along with this program. If not, see | |
16 | ;;; <http://www.gnu.org/licenses/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;;; | |
20 | ;;; This pass uses the abstract interpretation provided by type analysis | |
21 | ;;; to fold constant values and type predicates. It is most profitably | |
22 | ;;; run after CSE, to take advantage of scalar replacement. | |
23 | ;;; | |
24 | ;;; Code: | |
25 | ||
26 | (define-module (language cps type-fold) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (language cps) | |
29 | #:use-module (language cps dfg) | |
30 | #:use-module (language cps renumber) | |
31 | #:use-module (language cps types) | |
9243902a | 32 | #:use-module (system base target) |
8bc65d2d AW |
33 | #:export (type-fold)) |
34 | ||
384d1ec3 AW |
35 | |
36 | \f | |
37 | ||
38 | ;; Branch folders. | |
39 | ||
8bc65d2d AW |
40 | (define &scalar-types |
41 | (logior &exact-integer &flonum &char &unspecified &boolean &nil &null)) | |
42 | ||
43 | (define *branch-folders* (make-hash-table)) | |
44 | ||
45 | (define-syntax-rule (define-branch-folder name f) | |
46 | (hashq-set! *branch-folders* 'name f)) | |
47 | ||
48 | (define-syntax-rule (define-branch-folder-alias to from) | |
49 | (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from))) | |
50 | ||
51 | (define-syntax-rule (define-unary-branch-folder (name arg min max) body ...) | |
52 | (define-branch-folder name (lambda (arg min max) body ...))) | |
53 | ||
54 | (define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0 | |
55 | arg1 min1 max1) | |
56 | body ...) | |
57 | (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...))) | |
58 | ||
59 | (define-syntax-rule (define-unary-type-predicate-folder name &type) | |
60 | (define-unary-branch-folder (name type min max) | |
61 | (let ((type* (logand type &type))) | |
62 | (cond | |
63 | ((zero? type*) (values #t #f)) | |
64 | ((eqv? type type*) (values #t #t)) | |
65 | (else (values #f #f)))))) | |
66 | ||
67 | ;; All the cases that are in compile-bytecode. | |
68 | (define-unary-type-predicate-folder pair? &pair) | |
69 | (define-unary-type-predicate-folder null? &null) | |
8bc65d2d AW |
70 | (define-unary-type-predicate-folder symbol? &symbol) |
71 | (define-unary-type-predicate-folder variable? &box) | |
72 | (define-unary-type-predicate-folder vector? &vector) | |
73 | (define-unary-type-predicate-folder struct? &struct) | |
74 | (define-unary-type-predicate-folder string? &string) | |
75 | (define-unary-type-predicate-folder number? &number) | |
76 | (define-unary-type-predicate-folder char? &char) | |
77 | ||
78 | (define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1) | |
79 | (cond | |
80 | ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0)) | |
81 | (values #t #f)) | |
82 | ((and (eqv? type0 type1) | |
83 | (eqv? min0 min1 max0 max1) | |
84 | (zero? (logand type0 (1- type0))) | |
85 | (not (zero? (logand type0 &scalar-types)))) | |
86 | (values #t #t)) | |
87 | (else | |
88 | (values #f #f)))) | |
89 | (define-branch-folder-alias eqv? eq?) | |
90 | (define-branch-folder-alias equal? eq?) | |
91 | ||
92 | (define (compare-ranges type0 min0 max0 type1 min1 max1) | |
93 | (and (zero? (logand (logior type0 type1) (lognot &real))) | |
94 | (cond ((< max0 min1) '<) | |
95 | ((> min0 max1) '>) | |
96 | ((= min0 max0 min1 max1) '=) | |
97 | ((<= max0 min1) '<=) | |
98 | ((>= min0 max1) '>=) | |
99 | (else #f)))) | |
100 | ||
101 | (define-binary-branch-folder (< type0 min0 max0 type1 min1 max1) | |
102 | (case (compare-ranges type0 min0 max0 type1 min1 max1) | |
103 | ((<) (values #t #t)) | |
104 | ((= >= >) (values #t #f)) | |
105 | (else (values #f #f)))) | |
106 | ||
107 | (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) | |
108 | (case (compare-ranges type0 min0 max0 type1 min1 max1) | |
109 | ((< <= =) (values #t #t)) | |
110 | ((>) (values #t #f)) | |
111 | (else (values #f #f)))) | |
112 | ||
113 | (define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) | |
114 | (case (compare-ranges type0 min0 max0 type1 min1 max1) | |
115 | ((=) (values #t #t)) | |
116 | ((< >) (values #t #f)) | |
117 | (else (values #f #f)))) | |
118 | ||
119 | (define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) | |
120 | (case (compare-ranges type0 min0 max0 type1 min1 max1) | |
121 | ((> >= =) (values #t #t)) | |
122 | ((<) (values #t #f)) | |
123 | (else (values #f #f)))) | |
124 | ||
125 | (define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) | |
126 | (case (compare-ranges type0 min0 max0 type1 min1 max1) | |
127 | ((>) (values #t #t)) | |
128 | ((= <= <) (values #t #f)) | |
129 | (else (values #f #f)))) | |
130 | ||
d613ccaa AW |
131 | (define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) |
132 | (define (logand-min a b) | |
133 | (if (< a b 0) | |
134 | (min a b) | |
135 | 0)) | |
136 | (define (logand-max a b) | |
137 | (if (< a b 0) | |
138 | 0 | |
139 | (max a b))) | |
140 | (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer)) | |
141 | (values #t (logtest min0 min1)) | |
142 | (values #f #f))) | |
143 | ||
384d1ec3 AW |
144 | |
145 | \f | |
146 | ||
147 | ;; Strength reduction. | |
148 | ||
149 | (define *primcall-reducers* (make-hash-table)) | |
150 | ||
151 | (define-syntax-rule (define-primcall-reducer name f) | |
152 | (hashq-set! *primcall-reducers* 'name f)) | |
153 | ||
9243902a | 154 | (define-syntax-rule (define-unary-primcall-reducer (name dfg k src |
384d1ec3 AW |
155 | arg type min max) |
156 | body ...) | |
157 | (define-primcall-reducer name | |
9243902a | 158 | (lambda (dfg k src arg type min max) body ...))) |
384d1ec3 | 159 | |
9243902a | 160 | (define-syntax-rule (define-binary-primcall-reducer (name dfg k src |
384d1ec3 AW |
161 | arg0 type0 min0 max0 |
162 | arg1 type1 min1 max1) | |
163 | body ...) | |
164 | (define-primcall-reducer name | |
9243902a | 165 | (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...))) |
384d1ec3 | 166 | |
9243902a | 167 | (define-binary-primcall-reducer (mul dfg k src |
384d1ec3 AW |
168 | arg0 type0 min0 max0 |
169 | arg1 type1 min1 max1) | |
170 | (define (negate arg) | |
171 | (let-fresh (kzero) (zero) | |
172 | (build-cps-term | |
173 | ($letk ((kzero ($kargs (#f) (zero) | |
174 | ($continue k src ($primcall 'sub (zero arg)))))) | |
175 | ($continue kzero src ($const 0)))))) | |
176 | (define (zero) | |
177 | (build-cps-term ($continue k src ($const 0)))) | |
178 | (define (identity arg) | |
179 | (build-cps-term ($continue k src ($values (arg))))) | |
180 | (define (double arg) | |
181 | (build-cps-term ($continue k src ($primcall 'add (arg arg))))) | |
182 | (define (power-of-two constant arg) | |
183 | (let ((n (let lp ((bits 0) (constant constant)) | |
184 | (if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) | |
185 | (let-fresh (kbits) (bits) | |
186 | (build-cps-term | |
187 | ($letk ((kbits ($kargs (#f) (bits) | |
188 | ($continue k src ($primcall 'ash (arg bits)))))) | |
189 | ($continue kbits src ($const n))))))) | |
190 | (define (mul/constant constant constant-type arg arg-type) | |
191 | (and (or (= constant-type &exact-integer) (= constant-type arg-type)) | |
192 | (case constant | |
193 | ;; (* arg -1) -> (- 0 arg) | |
194 | ((-1) (negate arg)) | |
195 | ;; (* arg 0) -> 0 if arg is not a flonum or complex | |
196 | ((0) (and (= constant-type &exact-integer) | |
197 | (zero? (logand arg-type | |
198 | (lognot (logior &flonum &complex)))) | |
199 | (zero))) | |
200 | ;; (* arg 1) -> arg | |
201 | ((1) (identity arg)) | |
202 | ;; (* arg 2) -> (+ arg arg) | |
203 | ((2) (double arg)) | |
204 | (else (and (= constant-type arg-type &exact-integer) | |
205 | (positive? constant) | |
206 | (zero? (logand constant (1- constant))) | |
207 | (power-of-two constant arg)))))) | |
208 | (cond | |
9243902a | 209 | ((logtest (logior type0 type1) (lognot &number)) #f) |
384d1ec3 AW |
210 | ((= min0 max0) (mul/constant min0 type0 arg1 type1)) |
211 | ((= min1 max1) (mul/constant min1 type1 arg0 type0)) | |
212 | (else #f))) | |
213 | ||
9243902a AW |
214 | (define-binary-primcall-reducer (logbit? dfg k src |
215 | arg0 type0 min0 max0 | |
216 | arg1 type1 min1 max1) | |
217 | (define (convert-to-logtest bool-term) | |
218 | (let-fresh (kt kf kmask kbool) (mask bool) | |
219 | (build-cps-term | |
220 | ($letk ((kt ($kargs () () | |
221 | ($continue kbool src ($const #t)))) | |
222 | (kf ($kargs () () | |
223 | ($continue kbool src ($const #f)))) | |
224 | (kbool ($kargs (#f) (bool) | |
225 | ,(bool-term bool))) | |
226 | (kmask ($kargs (#f) (mask) | |
227 | ($continue kf src | |
228 | ($branch kt ($primcall 'logtest (mask arg1))))))) | |
229 | ,(if (eq? min0 max0) | |
230 | ($continue kmask src ($const (ash 1 min0))) | |
231 | (let-fresh (kone) (one) | |
232 | (build-cps-term | |
233 | ($letk ((kone ($kargs (#f) (one) | |
234 | ($continue kmask src | |
235 | ($primcall 'ash (one arg0)))))) | |
236 | ($continue kone src ($const 1)))))))))) | |
237 | ;; Hairiness because we are converting from a primcall with unknown | |
238 | ;; arity to a branching primcall. | |
239 | (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3))) | |
240 | (and (= type0 &exact-integer) | |
241 | (<= 0 min0 positive-fixnum-bits) | |
242 | (<= 0 max0 positive-fixnum-bits) | |
243 | (match (lookup-cont k dfg) | |
244 | (($ $kreceive arity kargs) | |
245 | (match arity | |
246 | (($ $arity (_) () (not #f) () #f) | |
247 | (convert-to-logtest | |
248 | (lambda (bool) | |
249 | (let-fresh (knil) (nil) | |
250 | (build-cps-term | |
251 | ($letk ((knil ($kargs (#f) (nil) | |
252 | ($continue kargs src | |
253 | ($values (bool nil)))))) | |
254 | ($continue knil src ($const '())))))))) | |
255 | (_ | |
256 | (convert-to-logtest | |
257 | (lambda (bool) | |
258 | (build-cps-term | |
259 | ($continue k src ($primcall 'values (bool))))))))) | |
260 | (($ $ktail) | |
261 | (convert-to-logtest | |
262 | (lambda (bool) | |
263 | (build-cps-term | |
264 | ($continue k src ($primcall 'return (bool))))))))))) | |
265 | ||
384d1ec3 AW |
266 | |
267 | \f | |
268 | ||
269 | ;; | |
270 | ||
271 | (define (fold-and-reduce fun dfg min-label min-var) | |
8bc65d2d AW |
272 | (define (scalar-value type val) |
273 | (cond | |
274 | ((eqv? type &exact-integer) val) | |
275 | ((eqv? type &flonum) (exact->inexact val)) | |
276 | ((eqv? type &char) (integer->char val)) | |
277 | ((eqv? type &unspecified) *unspecified*) | |
278 | ((eqv? type &boolean) (not (zero? val))) | |
279 | ((eqv? type &nil) #nil) | |
280 | ((eqv? type &null) '()) | |
281 | (else (error "unhandled type" type val)))) | |
ec412d75 AW |
282 | (let* ((typev (infer-types fun dfg)) |
283 | (label-count ((make-local-cont-folder label-count) | |
284 | (lambda (k cont label-count) (1+ label-count)) | |
285 | fun 0)) | |
286 | (folded? (make-bitvector label-count #f)) | |
384d1ec3 AW |
287 | (folded-values (make-vector label-count #f)) |
288 | (reduced-terms (make-vector label-count #f))) | |
8bc65d2d AW |
289 | (define (label->idx label) (- label min-label)) |
290 | (define (var->idx var) (- var min-var)) | |
384d1ec3 AW |
291 | (define (maybe-reduce-primcall! label k src name args) |
292 | (let* ((reducer (hashq-ref *primcall-reducers* name))) | |
9243902a | 293 | (when reducer |
384d1ec3 AW |
294 | (vector-set! |
295 | reduced-terms | |
296 | (label->idx label) | |
297 | (match args | |
298 | ((arg0) | |
299 | (call-with-values (lambda () (lookup-pre-type typev label arg0)) | |
300 | (lambda (type0 min0 max0) | |
9243902a | 301 | (reducer dfg k src arg0 type0 min0 max0)))) |
384d1ec3 AW |
302 | ((arg0 arg1) |
303 | (call-with-values (lambda () (lookup-pre-type typev label arg0)) | |
304 | (lambda (type0 min0 max0) | |
305 | (call-with-values (lambda () (lookup-pre-type typev label arg1)) | |
306 | (lambda (type1 min1 max1) | |
9243902a | 307 | (reducer dfg k src arg0 type0 min0 max0 |
384d1ec3 AW |
308 | arg1 type1 min1 max1)))))) |
309 | (_ #f)))))) | |
ec412d75 AW |
310 | (define (maybe-fold-value! label name def) |
311 | (call-with-values (lambda () (lookup-post-type typev label def 0)) | |
8bc65d2d | 312 | (lambda (type min max) |
384d1ec3 AW |
313 | (cond |
314 | ((and (not (zero? type)) | |
315 | (zero? (logand type (1- type))) | |
316 | (zero? (logand type (lognot &scalar-types))) | |
317 | (eqv? min max)) | |
ec412d75 AW |
318 | (bitvector-set! folded? (label->idx label) #t) |
319 | (vector-set! folded-values (label->idx label) | |
9243902a AW |
320 | (scalar-value type min)) |
321 | #t) | |
322 | (else #f))))) | |
8bc65d2d AW |
323 | (define (maybe-fold-unary-branch! label name arg) |
324 | (let* ((folder (hashq-ref *branch-folders* name))) | |
325 | (when folder | |
326 | (call-with-values (lambda () (lookup-pre-type typev label arg)) | |
327 | (lambda (type min max) | |
328 | (call-with-values (lambda () (folder type min max)) | |
329 | (lambda (f? v) | |
ec412d75 AW |
330 | (bitvector-set! folded? (label->idx label) f?) |
331 | (vector-set! folded-values (label->idx label) v)))))))) | |
8bc65d2d AW |
332 | (define (maybe-fold-binary-branch! label name arg0 arg1) |
333 | (let* ((folder (hashq-ref *branch-folders* name))) | |
334 | (when folder | |
335 | (call-with-values (lambda () (lookup-pre-type typev label arg0)) | |
336 | (lambda (type0 min0 max0) | |
337 | (call-with-values (lambda () (lookup-pre-type typev label arg1)) | |
338 | (lambda (type1 min1 max1) | |
339 | (call-with-values (lambda () | |
340 | (folder type0 min0 max0 type1 min1 max1)) | |
341 | (lambda (f? v) | |
ec412d75 AW |
342 | (bitvector-set! folded? (label->idx label) f?) |
343 | (vector-set! folded-values (label->idx label) v)))))))))) | |
8bc65d2d AW |
344 | (define (visit-cont cont) |
345 | (match cont | |
346 | (($ $cont label ($ $kargs _ _ body)) | |
347 | (visit-term body label)) | |
348 | (($ $cont label ($ $kclause arity body alternate)) | |
349 | (visit-cont body) | |
350 | (visit-cont alternate)) | |
351 | (_ #f))) | |
352 | (define (visit-term term label) | |
353 | (match term | |
354 | (($ $letk conts body) | |
355 | (for-each visit-cont conts) | |
356 | (visit-term body label)) | |
357 | (($ $letrec _ _ _ body) | |
358 | (visit-term body label)) | |
359 | (($ $continue k src ($ $primcall name args)) | |
59258f7c | 360 | ;; We might be able to fold primcalls that define a value. |
8bc65d2d AW |
361 | (match (lookup-cont k dfg) |
362 | (($ $kargs (_) (def)) | |
ec412d75 | 363 | ;(pk 'maybe-fold-value src name args) |
9243902a AW |
364 | (unless (maybe-fold-value! label name def) |
365 | (maybe-reduce-primcall! label k src name args))) | |
366 | (_ | |
367 | (maybe-reduce-primcall! label k src name args)))) | |
92805e21 AW |
368 | (($ $continue kf src ($ $branch kt ($ $primcall name args))) |
369 | ;; We might be able to fold primcalls that branch. | |
ec412d75 | 370 | ;(pk 'maybe-fold-branch label src name args) |
92805e21 AW |
371 | (match args |
372 | ((arg) | |
ec412d75 | 373 | (maybe-fold-unary-branch! label name arg)) |
92805e21 | 374 | ((arg0 arg1) |
ec412d75 | 375 | (maybe-fold-binary-branch! label name arg0 arg1)))) |
8bc65d2d | 376 | (_ #f))) |
a7ee377d AW |
377 | (when typev |
378 | (match fun | |
379 | (($ $cont kfun ($ $kfun src meta self tail clause)) | |
380 | (visit-cont clause)))) | |
384d1ec3 | 381 | (values folded? folded-values reduced-terms))) |
8bc65d2d AW |
382 | |
383 | (define (fold-constants* fun dfg) | |
384 | (match fun | |
385 | (($ $cont min-label ($ $kfun _ _ min-var)) | |
384d1ec3 AW |
386 | (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var)) |
387 | (lambda (folded? folded-values reduced-terms) | |
8bc65d2d AW |
388 | (define (label->idx label) (- label min-label)) |
389 | (define (var->idx var) (- var min-var)) | |
390 | (define (visit-cont cont) | |
391 | (rewrite-cps-cont cont | |
392 | (($ $cont label ($ $kargs names syms body)) | |
393 | (label ($kargs names syms ,(visit-term body label)))) | |
394 | (($ $cont label ($ $kclause arity body alternate)) | |
395 | (label ($kclause ,arity ,(visit-cont body) | |
396 | ,(and alternate (visit-cont alternate))))) | |
397 | (_ ,cont))) | |
398 | (define (visit-term term label) | |
399 | (rewrite-cps-term term | |
400 | (($ $letk conts body) | |
401 | ($letk ,(map visit-cont conts) | |
402 | ,(visit-term body label))) | |
403 | (($ $letrec names vars funs body) | |
404 | ($letrec names vars (map visit-fun funs) | |
405 | ,(visit-term body label))) | |
406 | (($ $continue k src (and fun ($ $fun))) | |
407 | ($continue k src ,(visit-fun fun))) | |
384d1ec3 AW |
408 | (($ $continue k src (and primcall ($ $primcall name args))) |
409 | ,(cond | |
410 | ((bitvector-ref folded? (label->idx label)) | |
411 | (let ((val (vector-ref folded-values (label->idx label)))) | |
412 | ;; Uncomment for debugging. | |
413 | ;; (pk 'folded src primcall val) | |
414 | (let-fresh (k*) (v*) | |
415 | ;; Rely on DCE to elide this expression, if | |
416 | ;; possible. | |
417 | (build-cps-term | |
418 | ($letk ((k* ($kargs (#f) (v*) | |
419 | ($continue k src ($const val))))) | |
420 | ($continue k* src ,primcall)))))) | |
421 | (else | |
422 | (or (vector-ref reduced-terms (label->idx label)) | |
423 | term)))) | |
92805e21 | 424 | (($ $continue kf src ($ $branch kt ($ $primcall))) |
c7b71b1f | 425 | ,(if (bitvector-ref folded? (label->idx label)) |
92805e21 AW |
426 | ;; Folded branch. |
427 | (let ((val (vector-ref folded-values (label->idx label)))) | |
428 | (build-cps-term | |
429 | ($continue (if val kt kf) src ($values ())))) | |
430 | term)) | |
8bc65d2d AW |
431 | (_ ,term))) |
432 | (define (visit-fun fun) | |
433 | (rewrite-cps-exp fun | |
434 | (($ $fun free body) | |
435 | ($fun free ,(fold-constants* body dfg))))) | |
436 | (rewrite-cps-cont fun | |
437 | (($ $cont kfun ($ $kfun src meta self tail clause)) | |
438 | (kfun ($kfun src meta self ,tail ,(visit-cont clause)))))))))) | |
439 | ||
440 | (define (type-fold fun) | |
441 | (let* ((fun (renumber fun)) | |
442 | (dfg (compute-dfg fun))) | |
443 | (with-fresh-name-state-from-dfg dfg | |
444 | (fold-constants* fun dfg)))) |