From caa5949dc2a757b68f4afd711281133ae7b0ba14 Mon Sep 17 00:00:00 2001
From: Gustavo Massaccesi <gustavo@oma.org.ar>
Date: Fri, 21 Apr 2017 23:25:56 -0300
Subject: [PATCH] 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

original commit: 4522ccdabd461370ad2d3fa91a92be0e6798d4d8
---
 LOG       |   4 +
 mats/4.ms | 209 ++++++++++++++++++++++++++++++++++++++++--
 s/cp0.ss  | 266 +++++++++++++++++++++++++++++-------------------------
 3 files changed, 347 insertions(+), 132 deletions(-)

diff --git a/LOG b/LOG
index 922b7b077f..b9caec252a 100644
--- a/LOG
+++ b/LOG
@@ -456,3 +456,7 @@
 - fix overflow detection for fxsll, fxarithmetic-shift-left, and
   fxarithmetic-shift
     library.ss, fx.ms, release_notes.stex
+- 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
diff --git a/mats/4.ms b/mats/4.ms
index 777fd76884..b95a3bc981 100644
--- a/mats/4.ms
+++ b/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
@@ -1179,12 +1211,51 @@
                         (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))\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"))
+    '("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 '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
diff --git a/s/cp0.ss b/s/cp0.ss
index 4b9fe4738e..a200ab1fc4 100644
--- a/s/cp0.ss
+++ b/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)
-            ; (map proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) =>
+          (lambda (?p ?ls ?ls* lvl map? ctxt sc wd name moi)
+            ; (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)
-            ;                 (p a12 t22 ... tn2)
-            ;                   ...
-            ;                 (p a1m t2m ... tnm)))))
-            (let loop ([ls* (cons ?ls ?ls*)] [e** '()])
+            ;           (list/begin (p a11 t21 ... tn1)
+            ;                       (p a12 t22 ... tn2)
+            ;                        ...
+            ;                       (p a1m t2m ... tnm)))))
+            (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 ([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**))))))))
+                                     (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**))))))])
+                                       (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)]
+               (residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
+                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)))]
+                           (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,110 +3701,114 @@
              [(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 (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]
-           [(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)))]
-                       [else #f]))
-              (cons ?ls ?ls*)) =>
-            (lambda (n)
-              (cond
-                [(fx= n 0)
+             [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))
-                 (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) ...)
-                  ;      (let ([t1 (cdr ls)] ...)
-                  ;        (proc (car t1) ...)
-                  ;        (let ([t2 (cdr t1)] ...)
-                  ;          (proc (car t2) ...)
-                  ;          (proc (cadr t2) ...))))
-                  ;    proc e1 ... (begin e2 ... '(a b c d)) e3 ...)
-                  (cp0
-                    (let ([p (cp0-make-temp (fx> n 1))]
-                          [ls* (cons (cp0-make-temp #t)
-                                 (map (lambda (x) (cp0-make-temp #t)) ?ls*))])
-                      (build-lambda (cons p ls*)
-                        (cond
-                          [(fx= n 1)
-                           `(call ,(app-preinfo ctxt) (ref #f ,p)
-                              ,(map (lambda (x)
-                                      (build-primcall 3 'car (list (build-ref x))))
-                                 ls*) ...)]
-                          [else
-                            (let f ([n n] [ls* ls*])
-                              (if (fx= n 2)
-                                  (make-seq 'value
-                                    `(call ,(app-preinfo ctxt) (ref #f ,p)
-                                       ,(map (lambda (x)
-                                               (build-primcall 3 'car (list (build-ref x))))
-                                          ls*) ...)
-                                    `(call ,(app-preinfo ctxt) (ref #f ,p)
-                                       ,(map (lambda (x)
-                                               (build-primcall 3 'cadr (list (build-ref x))))
-                                          ls*) ...))
-                                  (make-seq 'value
-                                    `(call ,(app-preinfo ctxt) (ref #f ,p)
-                                       ,(map (lambda (x)
-                                               (build-primcall 3 'car (list (build-ref x))))
-                                          ls*) ...)
-                                    (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)])
-                                      (build-let tls*
-                                        (map (lambda (x)
-                                               (build-primcall 3 'cdr (list (build-ref x))))
-                                          ls*)
-                                        (f (fx- n 1) tls*))))))])))
-                    ctxt empty-env sc wd name moi)]))]
-           [else
-             (and likely-to-be-compiled?
-                  (cp0
-                    (let ([?ls* (cons ?ls ?ls*)])
-                      (let ([p (cp0-make-temp #t)]
-                            [r (cp0-make-temp #t)]
-                            [do (cp0-make-temp #t)]
-                            [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]
-                            [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)])
-                        (build-lambda (cons p tls*)
-                          `(if ,(build-primcall 3 'null?
-                                  (list (build-ref (car tls*))))
-                               ,void-rec
-                               ,(build-named-let do ls*
-                                  (map build-ref tls*)
-                                  (build-let (list r)
-                                    (list (build-primcall 3 'cdr (list (build-ref (car ls*)))))
-                                    `(if ,(build-primcall 3 'null?  (list (build-ref r)))
-                                         (call ,(app-preinfo ctxt) (ref #f ,p)
-                                           ,(map (lambda (x)
-                                                   (build-primcall 3 'car (list (build-ref x))))
-                                              ls*) ...)
-                                         ,(make-seq 'value
-                                            `(call ,(app-preinfo ctxt) (ref #f ,p)
-                                               ,(map (lambda (x)
-                                                       (build-primcall 3 'car (list (build-ref x))))
-                                                  ls*) ...)
-                                            `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r)
-                                               ,(map (lambda (x)
-                                                       (build-primcall 3 'cdr (list (build-ref x))))
-                                                  (cdr ls*)) ...)))))))))
-                    ctxt empty-env sc wd name moi))])])
+                (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) (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)
+                (safe-assert (not (= n 0))) ; guaranteed before we get here
+                ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...)
+                ;   ((lambda (p ls ...)
+                ;      (proc (car ls) ...)
+                ;      (let ([t1 (cdr ls)] ...)
+                ;        (proc (car t1) ...)
+                ;        (let ([t2 (cdr t1)] ...)
+                ;          (proc (car t2) ...)
+                ;          (proc (cadr t2) ...))))
+                ;    proc e1 ... (begin e2 ... '(a b c d)) e3 ...)
+                (cp0
+                  (let ([p (cp0-make-temp (fx> n 1))]
+                        [ls* (cons (cp0-make-temp #t)
+                               (map (lambda (x) (cp0-make-temp #t)) ?ls*))])
+                    (build-lambda (cons p ls*)
+                      (cond
+                        [(fx= n 1)
+                         `(call ,(app-preinfo ctxt) (ref #f ,p)
+                            ,(map (lambda (x)
+                                    (build-primcall 3 'car (list (build-ref x))))
+                               ls*) ...)]
+                        [else
+                          (let f ([n n] [ls* ls*])
+                            (if (fx= n 2)
+                                (make-seq 'value
+                                  `(call ,(app-preinfo ctxt) (ref #f ,p)
+                                     ,(map (lambda (x)
+                                             (build-primcall 3 'car (list (build-ref x))))
+                                        ls*) ...)
+                                  `(call ,(app-preinfo ctxt) (ref #f ,p)
+                                     ,(map (lambda (x)
+                                             (build-primcall 3 'cadr (list (build-ref x))))
+                                        ls*) ...))
+                                (make-seq 'value
+                                  `(call ,(app-preinfo ctxt) (ref #f ,p)
+                                     ,(map (lambda (x)
+                                             (build-primcall 3 'car (list (build-ref x))))
+                                        ls*) ...)
+                                  (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)])
+                                    (build-let tls*
+                                      (map (lambda (x)
+                                             (build-primcall 3 'cdr (list (build-ref x))))
+                                        ls*)
+                                      (f (fx- n 1) tls*))))))])))
+                  ctxt empty-env sc wd name moi))]
+             [else
+               (and likely-to-be-compiled?
+                    (cp0
+                      (let ([?ls* (cons ?ls ?ls*)])
+                        (let ([p (cp0-make-temp #t)]
+                              [r (cp0-make-temp #t)]
+                              [do (cp0-make-temp #t)]
+                              [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]
+                              [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)])
+                          (build-lambda (cons p tls*)
+                            `(if ,(build-primcall 3 'null?
+                                    (list (build-ref (car tls*))))
+                                 ,void-rec
+                                 ,(build-named-let do ls*
+                                    (map build-ref tls*)
+                                    (build-let (list r)
+                                      (list (build-primcall 3 'cdr (list (build-ref (car ls*)))))
+                                      `(if ,(build-primcall 3 'null?  (list (build-ref r)))
+                                           (call ,(app-preinfo ctxt) (ref #f ,p)
+                                             ,(map (lambda (x)
+                                                     (build-primcall 3 'car (list (build-ref x))))
+                                                ls*) ...)
+                                           ,(make-seq 'value
+                                              `(call ,(app-preinfo ctxt) (ref #f ,p)
+                                                 ,(map (lambda (x)
+                                                         (build-primcall 3 'car (list (build-ref x))))
+                                                    ls*) ...)
+                                              `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r)
+                                                 ,(map (lambda (x)
+                                                         (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*)