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

Fix reduction for map with optimization level 3
original commit: c70ed396983f3081a7f105c19912ff7439937723

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

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

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]

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])