From 74f0518c891e3d6b78c8e514d0feef1ce5ce56c4 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 8 Jun 2017 01:06:29 -0400 Subject: [PATCH] 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 rebuild boot files original commit: 63c6ae5c2d4354a984bfc210f061c2c2123f0439 --- LOG | 7 +- mats/4.ms | 64 ------------- s/cp0.ss | 266 +++++++++++++++++++++++++----------------------------- 3 files changed, 131 insertions(+), 206 deletions(-) diff --git a/LOG b/LOG index cf2705392e..1a976e7c97 100644 --- a/LOG +++ b/LOG @@ -483,4 +483,9 @@ 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 \ No newline at end of file + 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 diff --git a/mats/4.ms b/mats/4.ms index 61efbee75a..9aa05e6284 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1120,30 +1120,6 @@ (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 @@ -1948,46 +1924,6 @@ '(#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/s/cp0.ss b/s/cp0.ss index a200ab1fc4..4b9fe4738e 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3565,26 +3565,21 @@ (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 map? ctxt sc wd name moi) - ; (map/for-each proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => + (lambda (?p ?ls ?ls* lvl ctxt sc wd name moi) + ; (map 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/begin (p a11 t21 ... tn1) - ; (p a12 t22 ... tn2) - ; ... - ; (p a1m t2m ... tnm))))) - (let loop ([ls* (cons ?ls ?ls*)] [e** '()] [all-quoted? #t]) + ; (list (p a11 t21 ... tn1) + ; (p a12 t22 ... tn2) + ; ... + ; (p a1m t2m ... tnm))))) + (let loop ([ls* (cons ?ls ?ls*)] [e** '()]) (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))] @@ -3595,25 +3590,20 @@ (let f ([t** temp**] [e** e**] [ls* ?ls*]) (if (null? t**) (non-result-exp (value-visit-operand! ?ls) - (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)))) + (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*)))))))))) (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**) #f))] + (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**)))] [else #f]))))) (define-inline 2 map [(?p ?ls . ?ls*) @@ -3621,13 +3611,14 @@ (begin (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) 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 [(?p ?ls . ?ls*) (cond [(ormap null-rec? (cons ?ls ?ls*)) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - null-rec] + (begin + (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. @@ -3637,18 +3628,15 @@ (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))))] + (arity-okay? (primref-arity pr) (+ (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)))] - [(call ,preinfo ,e ,e* ...) - (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] [else #f])) (cons ?ls ?ls*)) => (lambda (n) @@ -3693,7 +3681,7 @@ ls*) ...) ropnd*)))))))) 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 [(?p ?ls . ?ls*) @@ -3701,114 +3689,110 @@ [(andmap null-rec? (cons ?ls ?ls*)) (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] - [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*)) + [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) ; (for-each proc e1 ... (begin e2 ... '()) e3 ...) => ; (begin e1 ... (begin e2 ... '()) e3 ... (void)) - (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))])]) - ) + (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))])]) (define-inline 3 vector-map [(?p ?v . ?v*)