Merge pull request #169 from gus-massa/17-4-Map-List
more optimizations for map and for-each with explicit list original commit: fbcffe71c4515d75e2c2ba94c2d24850b561b17c
This commit is contained in:
R. Kent Dybvig
GitHub
commit
de8929221f
5
LOG
5
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
|
||||
209
mats/4.ms
209
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
|
||||
|
|
|
|||
266
s/cp0.ss
266
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*)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user