suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
more optimizations for map and for-each with explicit list
original commit: fbcffe71c4515d75e2c2ba94c2d24850b561b17c
This commit is contained in:
R. Kent Dybvig 2017-06-07 22:59:21 -04:00 committed by GitHub
commit de8929221f
3 changed files with 348 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
LOG
View File

@ -479,3 +479,8 @@
strip.ss, 7.ss, newhash.ss, misc.ms strip.ss, 7.ss, newhash.ss, misc.ms
- fix signature of fxbit-set? - fix signature of fxbit-set?
primdata.ss 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

209
mats/4.ms
View File

@ -1102,7 +1102,7 @@
(expand/optimize (expand/optimize
'(begin (#3%map cons '(5 4 3 2 1 0)) 7))) '(begin (#3%map cons '(5 4 3 2 1 0)) 7)))
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 ;; avoid creating each list and doing the actual map
(equivalent-expansion? (equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
@ -1120,6 +1120,38 @@
(list 4 5 6) (list 4 5 6)
(list '(7) '(8) '(9))))) (list '(7) '(8) '(9)))))
'(#3%list 12 15 18)) '(#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? (equivalent-expansion?
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -1179,12 +1211,51 @@
(begin (write 'a) (list (begin (write 'b) 'g) 'j)) (begin (write 'a) (list (begin (write 'b) 'g) 'j))
(begin (write 'c) (list (begin (write 'd) 'h) 'k)) (begin (write 'c) (list (begin (write 'd) 'h) 'k))
(begin (write 'e) (list (begin (write 'f) 'i) 'l)))))) (begin (write 'e) (list (begin (write 'f) 'i) 'l))))))
'("abcdef((g h . i) (j k . l))\n" '("abcdef((g h . i) (j k . l))\n"
"abefcd((g h . i) (j k . l))\n" "abefcd((g h . i) (j k . l))\n"
"cdabef((g h . i) (j k . l))\n" "cdabef((g h . i) (j k . l))\n"
"cdefab((g h . i) (j k . l))\n" "cdefab((g h . i) (j k . l))\n"
"efabcd((g h . i) (j k . l))\n" "efabcd((g h . i) (j k . l))\n"
"efcdab((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 (mat fold-left
@ -1875,6 +1946,130 @@
(expand/optimize (expand/optimize
'(#3%for-each cons '(5 4 3 2 1 0)))) '(#3%for-each cons '(5 4 3 2 1 0))))
'(#2%void))) '(#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 (mat ormap

266
s/cp0.ss
View File

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