suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #160 from gus-massa/17-4-Map-Ivory

Browse Source 
Fix reduction for map with optimization level 3
original commit: c70ed396983f3081a7f105c19912ff7439937723
This commit is contained in:
R. Kent Dybvig 2017-04-16 10:27:16 -04:00 committed by GitHub
commit 67e86b0c1d
4 changed files with 81 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
LOG
View File

@ -444,3 +444,9 @@
$close-resurrected-mutexes&conditions, $keep-live primitive added
externs.h, prim5.c, thread.c, 4.ms, thread.ms, release_notes.stex,
7.ss, cpnanopass.ss, np-languages.ss, primdata.ss, prims.ss
- fix reduction for map and for-each with optimization level 3
to drop the expression, check that procedure has the correct
arity and is discardable or unsafe.
Also add a simplification for for-each with empty lists
with optimization level 2.
cp0.ss, 4.ms, primdata.ss

54
mats/4.ms
View File

@ -1080,6 +1080,28 @@
(test-cp0-expansion equal? '(map (lambda (x) x) '()) ''()))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(map add1 '() '() '() '()) ''()))
;; if map is called only for effects, remove the expression only if the procedure
;; has the correct arity and can't raise an error
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map list '(5 4 3 2 1 0)) 7)))
7)
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map box? '(5 4 3 2 1 0)) 7)))
7)
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map unbox '(5 4 3 2 1 0)) 7)))
7))
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(begin (#3%map cons '(5 4 3 2 1 0)) 7)))
7))
;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en)
;; avoid creating each list and doing the actual map
(equivalent-expansion?
@ -1821,6 +1843,38 @@
(u a p k f 1) (v b q l g 2) (w c r m h 3) (x d s n i 4)
(y e t o j 5) (a u p k f 1) (b v q l g 2) (c w r m h 3)
(d x s n i 4) (e y t o j 5)))
;; cp0 optimizations for for-each
;; for-each with an empty list(s) always (void)
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each (lambda (x) x) '()) '(#2%void)))
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each add1 '() '() '() '()) '(#2%void)))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each (lambda (x) x) '()) '(#2%void)))
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(test-cp0-expansion equal? '(for-each add1 '() '() '() '()) '(#2%void)))
;; remove for-each the expression only if the procedure
;; has the correct arity and can't raise an error
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each list '(5 4 3 2 1 0))))
'(#2%void))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each box? '(5 4 3 2 1 0))))
'(#2%void))
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each unbox '(5 4 3 2 1 0))))
'(#2%void)))
(not (equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2])
(expand/optimize
'(#3%for-each cons '(5 4 3 2 1 0))))
'(#2%void)))
)
(mat ormap

24
s/cp0.ss
View File

@ -3576,7 +3576,7 @@
; (list (p a11 t21 ... tn1)
; (p a12 t22 ... tn2)
; ...
; (p a1m t2m ... tnm))))))
; (p a1m t2m ... tnm)))))
(let loop ([ls* (cons ?ls ?ls*)] [e** '()])
(if (null? ls*)
(and (apply = (map length e**))
@ -3624,7 +3624,11 @@
; input list is mutated, while for-each is not.
[(and (eq? (app-ctxt ctxt) 'effect)
(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p))
[,pr (all-set? (prim-mask discard) (primref-flags pr))]
[,pr (let ([flags (primref-flags pr)])
(and (if (all-set? (prim-mask unsafe) flags)
(all-set? (prim-mask discard) flags)
(all-set? (prim-mask (or discard unrestricted)) flags))
(arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))]
[else #f]))
; discard effect-free calls to map in effect context
(residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
@ -3677,13 +3681,25 @@
ls*) ...)
ropnd*))))))))
ctxt empty-env sc wd name moi))]
[else (inline-lists ?p ?ls ?ls* 3 ctxt sc wd name moi)])]))
[else (inline-lists ?p ?ls ?ls* 3 ctxt sc wd name moi)])])
(define-inline 2 for-each
[(?p ?ls . ?ls*)
(cond
[(andmap null-rec? (cons ?ls ?ls*))
(residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
void-rec]
[else #f])])
)
(define-inline 3 for-each
[(?p ?ls . ?ls*)
(cond
[(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p))
[,pr (all-set? (prim-mask discard) (primref-flags pr))]
[,pr (let ([flags (primref-flags pr)])
(and (if (all-set? (prim-mask unsafe) flags)
(all-set? (prim-mask discard) flags)
(all-set? (prim-mask (or discard unrestricted)) flags))
(arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))]
[else #f])
(residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
void-rec]

2
s/primdata.ss
View File

@ -295,7 +295,7 @@
(list-tail [sig [(ptr sub-index) -> (ptr)]] [flags mifoldable discard ieee r5rs])
(list-ref [sig [(pair sub-index) -> (ptr)]] [flags mifoldable discard ieee r5rs cp02])
(map [sig [(procedure list list ...) -> (list)]] [flags cp02 cp03 ieee r5rs true])
(for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp03 ieee r5rs])
(for-each [sig [(procedure list list ...) -> (ptr ...)]] [flags cp02 cp03 ieee r5rs])
(symbol? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard ieee r5rs])
(symbol->string [sig [(symbol) -> (string)]] [flags true mifoldable discard ieee r5rs])
(symbol=? [sig [(symbol symbol symbol ...) -> (boolean)]] [flags pure mifoldable discard cp03])