From a004a67b3f4da79ad52f663b47ad2a63f066f28c Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 8 Jun 2017 02:43:14 -0400 Subject: [PATCH] - restored the map and for-each optimizations with a fix for the evaluation-order bug. cp0.ss, 4.ms original commit: b395a763a3167c6a044273ea7deb000de35b0f09 --- LOG | 4 + mats/4.ms | 64 ++++++++ mats/patch-compile-0-f-t-f | 38 ++++- mats/patch-compile-0-t-f-f | 4 +- mats/patch-interpret-0-f-f-f | 4 +- mats/patch-interpret-0-f-t-f | 4 +- mats/patch-interpret-3-f-f-f | 4 +- mats/patch-interpret-3-f-t-f | 4 +- s/cp0.ss | 292 ++++++++++++++++++----------------- 9 files changed, 267 insertions(+), 151 deletions(-) diff --git a/LOG b/LOG index 1a976e7c97..5ed469245e 100644 --- a/LOG +++ b/LOG @@ -489,3 +489,7 @@ corresponding equivalent-expansion tests. cp0.ss, 4.ms +- restored the map and for-each optimizations with a fix for the + evaluation-order bug. + cp0.ss, + 4.ms diff --git a/mats/4.ms b/mats/4.ms index 9aa05e6284..61efbee75a 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1120,6 +1120,30 @@ (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 @@ -1924,6 +1948,46 @@ '(#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 diff --git a/mats/patch-compile-0-f-t-f b/mats/patch-compile-0-f-t-f index 1b11079849..f456c0fe97 100644 --- a/mats/patch-compile-0-f-t-f +++ b/mats/patch-compile-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-29 03:04:27.000000000 -0400 ---- errors-compile-0-f-t-f 2017-05-29 02:30:33.000000000 -0400 +*** errors-compile-0-f-f-f 2017-06-08 02:10:03.000000000 -0400 +--- errors-compile-0-f-t-f 2017-06-08 01:38:37.000000000 -0400 *************** *** 125,131 **** 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". @@ -58,6 +58,40 @@ 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". 3.mo:Expected error in mat mrvs: "returned two values to single value return context". *************** +*** 249,255 **** + 4.mo:Expected error in mat r6rs:case: "invalid syntax (r6rs:case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat r6rs:case: "invalid syntax (case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)". +! 4.mo:Expected error in mat map: "map: 3 is not a procedure". + 4.mo:Expected error in mat map: "map: a is not a proper list". + 4.mo:Expected error in mat map: "map: (a . b) is not a proper list". + 4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular". +--- 249,255 ---- + 4.mo:Expected error in mat r6rs:case: "invalid syntax (r6rs:case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat r6rs:case: "invalid syntax (case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)". +! 4.mo:Expected error in mat map: "attempt to apply non-procedure 3". + 4.mo:Expected error in mat map: "map: a is not a proper list". + 4.mo:Expected error in mat map: "map: (a . b) is not a proper list". + 4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular". +*************** +*** 319,325 **** + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". +! 4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure". + 4.mo:Expected error in mat for-each: "for-each: a is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a . b) is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a a a a a a ...) is circular". +--- 319,325 ---- + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". +! 4.mo:Expected error in mat for-each: "attempt to apply non-procedure 3". + 4.mo:Expected error in mat for-each: "for-each: a is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a . b) is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a a a a a a ...) is circular". +*************** *** 3645,3651 **** misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q". diff --git a/mats/patch-compile-0-t-f-f b/mats/patch-compile-0-t-f-f index 3cbf9aae0e..b3795bc557 100644 --- a/mats/patch-compile-0-t-f-f +++ b/mats/patch-compile-0-t-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-29 03:04:27.000000000 -0400 ---- errors-compile-0-t-f-f 2017-05-29 02:38:26.000000000 -0400 +*** errors-compile-0-f-f-f 2017-06-08 02:10:03.000000000 -0400 +--- errors-compile-0-t-f-f 2017-06-08 01:45:53.000000000 -0400 *************** *** 93,99 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #". diff --git a/mats/patch-interpret-0-f-f-f b/mats/patch-interpret-0-f-f-f index af6d3d9e2e..fdbbb9b59b 100644 --- a/mats/patch-interpret-0-f-f-f +++ b/mats/patch-interpret-0-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-29 03:04:27.000000000 -0400 ---- errors-interpret-0-f-f-f 2017-05-29 02:47:10.000000000 -0400 +*** errors-compile-0-f-f-f 2017-06-08 02:10:03.000000000 -0400 +--- errors-interpret-0-f-f-f 2017-06-08 01:53:14.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". diff --git a/mats/patch-interpret-0-f-t-f b/mats/patch-interpret-0-f-t-f index 9b574165cb..3b08a510a6 100644 --- a/mats/patch-interpret-0-f-t-f +++ b/mats/patch-interpret-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-t-f 2017-05-29 02:30:33.000000000 -0400 ---- errors-interpret-0-f-t-f 2017-05-29 02:54:57.000000000 -0400 +*** errors-compile-0-f-t-f 2017-06-08 01:38:37.000000000 -0400 +--- errors-interpret-0-f-t-f 2017-06-08 02:00:50.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". diff --git a/mats/patch-interpret-3-f-f-f b/mats/patch-interpret-3-f-f-f index ac9ad0085f..47d2dcead4 100644 --- a/mats/patch-interpret-3-f-f-f +++ b/mats/patch-interpret-3-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-3-f-f-f 2017-05-29 02:26:29.000000000 -0400 ---- errors-interpret-3-f-f-f 2017-05-29 03:10:12.000000000 -0400 +*** errors-compile-3-f-f-f 2017-06-08 01:35:00.000000000 -0400 +--- errors-interpret-3-f-f-f 2017-06-08 02:15:41.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/mats/patch-interpret-3-f-t-f b/mats/patch-interpret-3-f-t-f index 9178cd04c0..7f05db4eb3 100644 --- a/mats/patch-interpret-3-f-t-f +++ b/mats/patch-interpret-3-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-3-f-t-f 2017-05-29 02:34:27.000000000 -0400 ---- errors-interpret-3-f-t-f 2017-05-29 02:58:45.000000000 -0400 +*** errors-compile-3-f-t-f 2017-06-08 01:42:09.000000000 -0400 +--- errors-interpret-3-f-t-f 2017-06-08 02:04:33.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/s/cp0.ss b/s/cp0.ss index 4b9fe4738e..b86eec2770 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3565,45 +3565,53 @@ (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 ([t11 a11] ... [t1m a1m]) ; ... - ; (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** '()]) + ; (let ([tn1 an1] ... [tnm anm]) + ; (list/begin (p t11 ... tn1) + ; (p t12 ... tn2) + ; ... + ; (p t1m ... tnm))))) + (let loop ([ls* (cons ?ls ?ls*)] [e** '()] [all-quoted? #t]) (if (null? ls*) (and (apply = (map length e**)) - (let* ([e** (reverse e**)] [e* (car e**)] [e** (cdr e**)]) + (or (not all-quoted?) (fx<= (length (car e**)) 4)) + (let ([p (cp0-make-temp (fx> (length (car e**)) 1))] + [temp** (map (lambda (e*) + (map (lambda (x) (cp0-make-temp #f)) e*)) + e**)]) (residualize-seq (list* ?p ?ls ?ls*) '() ctxt) - (let ([p (cp0-make-temp (fx> (length e*) 1))] - [temp** (map (lambda (e*) - (map (lambda (x) (cp0-make-temp #f)) e*)) - e**)]) - (build-let (list p) (list (value-visit-operand! ?p)) - (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**)))))))) - (non-result-exp (value-visit-operand! (car ls*)) - (build-let (car t**) (car e**) - (f (cdr t**) (cdr e**) (cdr ls*)))))))))) + (build-let (list p) (list (value-visit-operand! ?p)) + (let f ([t** temp**] [e** (reverse e**)] [ls* (cons ?ls ?ls*)]) + (if (null? t**) + (let ([results + (let ([preinfo (app-preinfo ctxt)]) + (let g ([t** temp**]) + (if (null? (car t**)) + '() + (cons `(call ,preinfo (ref #f ,p) + ,(map (lambda (t*) (build-ref (car t*))) t**) ...) + (g (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 +3619,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 +3635,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 +3691,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 +3699,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*)