From f58644991fc5663dcfcdb144f9d8c404d1823c43 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 11 Apr 2017 18:03:36 -0300 Subject: [PATCH] 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 original commit: 7ad035a3bd63675a1b40106c841669e04e3299f2 --- LOG | 6 ++++++ mats/4.ms | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++ s/cp0.ss | 24 +++++++++++++++++++---- s/primdata.ss | 2 +- 4 files changed, 81 insertions(+), 5 deletions(-) diff --git a/LOG b/LOG index 5d01de7e7e..756badf8f3 100644 --- a/LOG +++ b/LOG @@ -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 diff --git a/mats/4.ms b/mats/4.ms index 5607c64d87..777fd76884 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -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 diff --git a/s/cp0.ss b/s/cp0.ss index 489b28b3bc..4b9fe4738e 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -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] diff --git a/s/primdata.ss b/s/primdata.ss index 041be16a8e..b4eba151ec 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -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])