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

reverted to the preceding version of cp0 due to failure to preserve

Browse Source 
the expected evaluation order in one of the mats; removed the
corresponding equivalent-expansion tests.
  cp0.ss,
  4.ms
rebuild boot files

original commit: 63c6ae5c2d4354a984bfc210f061c2c2123f0439
This commit is contained in:
dyb 2017-06-08 01:06:29 -04:00
parent de8929221f
commit 74f0518c89
3 changed files with 131 additions and 206 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
LOG
View File

@ -483,4 +483,9 @@
extend the reductions for map and for-each when the arguments are extend the reductions for map and for-each when the arguments are
explicit lists like (list 1 2 3 ...) or '(1 2 3 ...). explicit lists like (list 1 2 3 ...) or '(1 2 3 ...).
cp0.ss, cp0.ss,
4.ms 4.ms
- reverted to the preceding version of cp0 due to failure to preserve
the expected evaluation order in one of the mats; removed the
corresponding equivalent-expansion tests.
cp0.ss,
4.ms

64
mats/4.ms
View File

@ -1120,30 +1120,6 @@
(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? (equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize
@ -1948,46 +1924,6 @@
'(#2%void))) '(#2%void)))
;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en) ;; 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 ;; 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? (equivalent-expansion?
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize (expand/optimize

266
s/cp0.ss
View File

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