Merge pull request #169 from gus-massa/17-4-Map-List

more optimizations for map and for-each with explicit list
original commit: fbcffe71c4515d75e2c2ba94c2d24850b561b17c

LOG

@@ -479,3 +479,8 @@
     strip.ss, 7.ss, newhash.ss, misc.ms
 - fix signature of fxbit-set?
     primdata.ss
+- more optimizations for map and for-each with explicit list
+  extend the reductions for map and for-each when the arguments are
+  explicit lists like (list 1 2 3 ...) or '(1 2 3 ...). 
+    cp0.ss,
+    4.ms

mats/4.ms

@@ -1102,7 +1102,7 @@
            (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)
+  ;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
   ;; avoid creating each list and doing the actual map
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
@@ -1120,6 +1120,38 @@
            (list 4 5 6)
            (list '(7) '(8) '(9)))))
     '(#3%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(#2%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(#3%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(#2%list 12 15 18))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(map (lambda (x y z) (apply + x y z)) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(#3%list 12 15 18))
   (equivalent-expansion?
     (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -1185,6 +1217,45 @@
       "cdefab((g h . i) (j k . l))\n"
       "efabcd((g h . i) (j k . l))\n"
       "efcdab((g h . i) (j k . l))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'ab) '(g j))
+                        (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+                        (begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+                        (begin (write 'cd) '(h k))
+                        (begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (pretty-print (map (lambda (x y z) (cons* x y z))
+                        (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+                        (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+                        (begin (write 'ef) '(i l))))))
+    '("abcdef((g h . i) (j k . l))\n"
+      "abefcd((g h . i) (j k . l))\n"
+      "cdabef((g h . i) (j k . l))\n"
+      "cdefab((g h . i) (j k . l))\n"
+      "efabcd((g h . i) (j k . l))\n"
+      "efcdab((g h . i) (j k . l))\n"))
  )
 
 (mat fold-left
@@ -1875,6 +1946,130 @@
            (expand/optimize
              '(#3%for-each cons '(5 4 3 2 1 0))))
            '(#2%void)))
+  ;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en)
+  ;; avoid creating each list and doing the actual for-each
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           (list 1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           (list 1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           (list 4 5 6)
+           (list '(7) '(8) '(9)))))
+    '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(begin (#2%display 12) (#2%display 15) (#2%display 18)))
+  (equivalent-expansion?
+    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+      (expand/optimize 
+        '(for-each (lambda (x y z) (display (apply + x y z))) 
+           '(1 2 3)
+           '(4 5 6)
+           '((7) (8) (9)))))
+    '(begin (#3%display 12) (#3%display 15) (#3%display 18)))
+  (equal?
+    (with-output-to-string
+      (lambda ()
+        (for-each (begin (write 'ab) (lambda (x y) (write (cons x y))))
+          (begin (write 'a) (list (begin (write 'b) 'c)))
+          (begin (write 'a) (list (begin (write 'b) 'd))))))
+    "ababab(c . d)")
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y) (write (cons x y)))
+          (list (begin (write 'a) 'c) (begin (write 'b) 'd))
+          (list (begin (write 'x) 'e) (begin (write 'y) 'f)))))
+    ; lots of valid possibilities, but make sure we don't interleave and get, e.g., axby
+    '("abxy(c . e)(d . f)"
+      "abyx(c . e)(d . f)"
+      "baxy(c . e)(d . f)"
+      "bayx(c . e)(d . f)"
+      "xyab(c . e)(d . f)"
+      "yxab(c . e)(d . f)"
+      "xyba(c . e)(d . f)"
+      "yxba(c . e)(d . f)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+          (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+          (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'ab) '(g j))
+          (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+          (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+          (begin (write 'cd) '(h k))
+          (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
+  ((lambda (x ls) (and (member x ls) #t))
+    (with-output-to-string
+      (lambda ()
+        (for-each (lambda (x y z) (write (cons* x y z)))
+          (begin (write 'a) (list (begin (write 'b) 'g) 'j))
+          (begin (write 'c) (list (begin (write 'd) 'h) 'k))
+          (begin (write 'ef) '(i l)))))
+    '("abcdef(g h . i)(j k . l)"
+      "abefcd(g h . i)(j k . l)"
+      "cdabef(g h . i)(j k . l)"
+      "cdefab(g h . i)(j k . l)"
+      "efabcd(g h . i)(j k . l)"
+      "efcdab(g h . i)(j k . l)"))
  )
 
 (mat ormap

s/cp0.ss

@@ -3565,21 +3565,26 @@
           (lambda (?ls)
             (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls))
               [(quote ,d) (null? d)]
+              [(call ,preinfo ,e ,e* ...)
+               ; check also for `(list)`. It should have been reduced to `(quote ())` before,
+               ; but cp0 isn't guaranteed to reach a fixed point.
+               (and (primref? e) (eq? (primref-name e) 'list) (null? e*))]
               [else #f])))
         (define inline-lists
-          (lambda (?p ?ls ?ls* lvl ctxt sc wd name moi)
+          (lambda (?p ?ls ?ls* lvl map? ctxt sc wd name moi)
-            ; (map proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) =>
+            ; (map/for-each proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) =>
             ;   (let ([p proc])
             ;     (let ([t21 a21] [t22 a22] ... [t2m a2m])
             ;       ...
             ;         (let ([tn1 an1] [tn2 an2] ... [tnm anm])
-            ;           (list (p a11 t21 ... tn1)
+            ;           (list/begin (p a11 t21 ... tn1)
             ;                       (p a12 t22 ... tn2)
             ;                        ...
             ;                       (p a1m t2m ... tnm)))))
-            (let loop ([ls* (cons ?ls ?ls*)] [e** '()])
+            (let loop ([ls* (cons ?ls ?ls*)] [e** '()] [all-quoted? #t])
               (if (null? ls*)
                   (and (apply = (map length e**))
+                       (or (not all-quoted?) (fx<= (length (car e**)) 4))
                        (let* ([e** (reverse e**)] [e* (car e**)] [e** (cdr e**)])
                          (residualize-seq (list* ?p ?ls ?ls*) '() ctxt)
                          (let ([p (cp0-make-temp (fx> (length e*) 1))]
@@ -3590,20 +3595,25 @@
                              (let f ([t** temp**] [e** e**] [ls* ?ls*])
                                (if (null? t**)
                                    (non-result-exp (value-visit-operand! ?ls)
-                                     (build-primcall lvl 'list
+                                     (let ([results 
                                             (let ([preinfo (app-preinfo ctxt)])
                                               (let g ([e* e*] [t** temp**])
                                                 (if (null? e*)
                                                     '()
                                                     (cons `(call ,preinfo (ref #f ,p) ,(car e*)
                                                              ,(map (lambda (t*) (build-ref (car t*))) t**) ...)
-                                                 (g (cdr e*) (map cdr t**))))))))
+                                                      (g (cdr e*) (map cdr t**))))))])
+                                       (if map?
+                                           (build-primcall lvl 'list results)
+                                           (make-seq* ctxt results))))
                                    (non-result-exp (value-visit-operand! (car ls*))
                                      (build-let (car t**) (car e**)
                                        (f (cdr t**) (cdr e**) (cdr ls*))))))))))
                   (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! (car ls*)))
+                    [(quote ,d)
+                     (and (list? d) (loop (cdr ls*) (cons (map (lambda (x) `(quote ,x)) d) e**) all-quoted?))]
                     [(call ,preinfo ,e ,e* ...)
-                      (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**)))]
+                     (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**) #f))]
                     [else #f])))))
         (define-inline 2 map
           [(?p ?ls . ?ls*)
@@ -3611,14 +3621,13 @@
                 (begin
                   (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
                   null-rec)
-                (inline-lists ?p ?ls ?ls* 2 ctxt sc wd name moi))])
+                (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))])
         (define-inline 3 map
           [(?p ?ls . ?ls*)
             (cond
               [(ormap null-rec? (cons ?ls ?ls*))
-                (begin
                (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
-                  null-rec)]
+                null-rec]
               ; could treat map in effect context as for-each, but don't because (our)
               ; map is guaranteed (even at optimization level 3) not to get sick if an
               ; input list is mutated, while for-each is not.
@@ -3628,15 +3637,18 @@
                               (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))))]
+                                   (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))]
                       [else #f]))
                 ; discard effect-free calls to map in effect context
                 (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
                 void-rec]
+              [(inline-lists ?p ?ls ?ls* 3 #t ctxt sc wd name moi)]
               [(ormap (lambda (?ls)
                         (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls))
                           [(quote ,d)
                            (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))]
+                          [(call ,preinfo ,e ,e* ...)
+                           (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))]
                           [else #f]))
                  (cons ?ls ?ls*)) =>
                 (lambda (n)
@@ -3681,7 +3693,7 @@
                                                 ls*) ...)
                                       ropnd*))))))))
                     ctxt empty-env sc wd name moi))]
-              [else (inline-lists ?p ?ls ?ls* 3 ctxt sc wd name moi)])])
+              [else #f])])
 
         (define-inline 2 for-each
           [(?p ?ls . ?ls*)
@@ -3689,34 +3701,37 @@
              [(andmap null-rec? (cons ?ls ?ls*))
               (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
               void-rec]
-             [else #f])])
+             [else
-      )
+             (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])])
         (define-inline 3 for-each
           [(?p ?ls . ?ls*)
            (cond
+              [(ormap null-rec? (cons ?ls ?ls*))
+                 ; (for-each proc e1 ... (begin e2 ... '()) e3 ...) =>
+                 ;   (begin e1 ... (begin e2 ... '()) e3 ... (void))
+                (begin
+                  (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
+                  void-rec)]
              [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p))
                 [,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))))]
+                            (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))]
                 [else #f])
               (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
               void-rec]
+             [(inline-lists ?p ?ls ?ls* 3 #f ctxt sc wd name moi)]
              [(ormap (lambda (?ls)
                        (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls))
                          [(quote ,d)
                           (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))]
+                         [(call ,preinfo ,e ,e* ...)
+                          (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))]
                          [else #f]))
                 (cons ?ls ?ls*)) =>
               (lambda (n)
-              (cond
+                (safe-assert (not (= n 0))) ; guaranteed before we get here
-                [(fx= n 0)
-                 ; (for-each proc e1 ... (begin e2 ... '()) e3 ...) =>
-                 ;   (begin e1 ... (begin e2 ... '()) e3 ... (void))
-                 (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
-                 void-rec]
-                [else
                 ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...)
                 ;   ((lambda (p ls ...)
                 ;      (proc (car ls) ...)
@@ -3760,7 +3775,7 @@
                                              (build-primcall 3 'cdr (list (build-ref x))))
                                         ls*)
                                       (f (fx- n 1) tls*))))))])))
-                    ctxt empty-env sc wd name moi)]))]
+                  ctxt empty-env sc wd name moi))]
              [else
                (and likely-to-be-compiled?
                     (cp0
@@ -3793,6 +3808,7 @@
                                                          (build-primcall 3 'cdr (list (build-ref x))))
                                                     (cdr ls*)) ...)))))))))
                       ctxt empty-env sc wd name moi))])])
+      )
 
       (define-inline 3 vector-map
         [(?p ?v . ?v*)