From 8e53fec779eeeaaab66bc11afaa4c3794580b4f7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 7 Jan 2019 12:58:37 -0700 Subject: [PATCH] revise optimizations from the "noncm" branch original commit: 444a284e69c652344174d730596caf7852be050b --- mats/cp0.ms | 915 +++++++++++++++++++++++------------------------- mats/record.ms | 4 +- s/cp0.ss | 358 +++++++++++-------- s/cpletrec.ss | 13 +- s/cpnanopass.ss | 66 +++- s/patch.ss | 2 +- s/primdata.ss | 21 +- s/priminfo.ss | 20 +- s/prims.ss | 6 + s/primvars.ss | 12 +- 10 files changed, 759 insertions(+), 658 deletions(-) diff --git a/mats/cp0.ms b/mats/cp0.ms index ccc3ddf34c..255911553f 100644 --- a/mats/cp0.ms +++ b/mats/cp0.ms @@ -1977,178 +1977,182 @@ ) (mat cp0-car/cdr - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + (begin + (define (expansion-matches? src expect) + ;; Check that expansion matches or doesn't match under various conditions. + ;; Expansion should not match in safe mode for expression involving the names + ;; `$xxx`, `$yyy`, and `$zzz`, but it should match when those are wrapped with + ;; `add1` (whcih makes the expression known-single-valued). + ;; The names `$nontail-xxx`, `$nontail-yyy`, and `$nontail-zzz` must similarly + ;; be wrapped to match in either safe or unsafe mode, since unsafe mode is obliged + ;; to preserve non-tailness. + ;; Other names, including `$xxx-ok`, can match without wrapping. + (define (contains-id? id l) + (or (eq? id l) + (and (pair? l) (or (contains-id? id (car l)) (contains-id? id (cdr l)))))) + (define (primitive->level l) + (cond + [(pair? l) + (if (and (eq? (car l) '$primitive) + (null? (cddr l))) + (cons* (car l) (if (= (optimize-level) 3) 3 2) (cdr l)) + (cons (primitive->level (car l)) (primitive->level (cdr l))))] + [else l])) + (define (add-add1s l around-ids) + (cond + [(pair? l) + (if (memq (car l) around-ids) + `(#%add1 ,l) + (cons (add-add1s (car l) around-ids) (add-add1s (cdr l) around-ids)))] + [else l])) + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (let* ([nontail-ids '($nontail-xxx $nontail-yyy $nontail-zzz)] + [non-nontail-ids '($xxx $yyy $zzz)] + [all-ids (if (= (optimize-level) 3) + nontail-ids + (append non-nontail-ids nontail-ids))]) + (and (if (andmap (lambda (id) (not (contains-id? id src))) all-ids) + (equivalent-expansion? (expand/optimize src) + (primitive->level expect)) + (not (equivalent-expansion? (expand/optimize src) + (primitive->level expect)))) + (equivalent-expansion? (expand/optimize (add-add1s src all-ids)) + (primitive->level (add-add1s expect all-ids))) + ;; Try subsets: + (andmap (lambda (ids) + (if (ormap (lambda (id) (and (not (member id ids)) (contains-id? id src))) all-ids) + (not (equivalent-expansion? (expand/optimize (add-add1s src ids)) + (primitive->level (add-add1s expect ids)))) + (equivalent-expansion? (expand/optimize (add-add1s src ids)) + (primitive->level (add-add1s expect ids))))) + (let loop ([ids all-ids]) + (if (null? ids) + '() + (let ([subs (loop (cdr ids))]) + (append (list (list (car ids))) + subs + (map (lambda (sub) (cons (car ids) sub)) subs)))))))))) + #t) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%car) (begin (#%write 'c) ((begin (#%write 'd) #%cons) - (begin (#%write 'e) (add1 ($xxx))) - (begin (#%write 'f) ($yyy)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'e) (#3%add1 ($xxx))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) (#2%add1 ($xxx))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + (begin (#%write 'e) ($nontail-xxx)) + (begin (#%write 'f) ($yyy)))))) + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'f) ($yyy) (#%write 'e) ($nontail-xxx))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%car) (begin (#%write 'c) - ((begin (#%write 'd) #%list) - (begin (#%write 'e) (add1 ($xxx))) - (begin (#%write 'f) ($yyy)) - (begin (#%write 'g) ($zzz)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%cons) + (begin (#%write 'e) ($nontail-xxx)) + (begin (#%write 'f) ($yyy)))))) + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'f) ($yyy) (#%write 'e) ($nontail-xxx))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%car) (begin (#%write 'c) - ((begin (#%write 'd) #%list*) - (begin (#%write 'e) (add1 ($xxx))) - (begin (#%write 'f) ($yyy)) - (begin (#%write 'g) ($zzz)))))))) + ((begin (#%write 'd) #%list) + (begin (#%write 'e) ($nontail-xxx)) + (begin (#%write 'f) ($yyy)) + (begin (#%write 'g) ($zzz)))))) ; other possibilities exist but are too many to list and too difficult to construct with $permutations. ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'f) ($yyy) (#%write 'g) ($zzz) (#%write 'e) ($nontail-xxx))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%car) (begin (#%write 'c) - ((begin (#%write 'd) #%cons*) - (begin (#%write 'e) (add1 ($xxx))) - (begin (#%write 'f) ($yyy)) - (begin (#%write 'g) ($zzz)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%list*) + (begin (#%write 'e) ($nontail-xxx)) + (begin (#%write 'f) ($yyy)) + (begin (#%write 'g) ($zzz)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'f) ($yyy) (#%write 'g) ($zzz) (#%write 'e) ($nontail-xxx))) + (expansion-matches? + '(begin (#%write 'a) + ((begin (#%write 'b) #%car) + (begin (#%write 'c) + ((begin (#%write 'd) #%cons*) + (begin (#%write 'e) ($nontail-xxx)) + (begin (#%write 'f) ($yyy)) + (begin (#%write 'g) ($zzz)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'f) ($yyy) (#%write 'g) ($zzz) (#%write 'e) ($nontail-xxx))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%cons) - (begin (#%write 'e) ($xxx)) - (begin (#%write 'f) (add1 ($yyy))))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%cons) + (begin (#%write 'e) ($xxx)) + (begin (#%write 'f) ($nontail-yyy)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'f) ($nontail-yyy))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%list) - (begin (#%write 'e) ($xxx)) - (begin (#%write 'f) ($yyy)) - (begin (#%write 'g) ($zzz)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%list (begin (#3%write 'f) ($yyy)) (begin (#3%write 'g) ($zzz)))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%list (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz)))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%list) + (begin (#%write 'e) ($xxx)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%list (begin (#%write 'f) ($yyy-ok)) (begin (#%write 'g) ($zzz-ok))))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%list*) - (begin (#%write 'e) ($xxx)) - (begin (#%write 'f) ($yyy)) - (begin (#%write 'g) ($zzz)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%list* (begin (#3%write 'f) ($yyy)) (begin (#3%write 'g) ($zzz)))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%list* (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz)))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%list*) + (begin (#%write 'e) ($xxx)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%list* (begin (#%write 'f) ($yyy-ok)) (begin (#%write 'g) ($zzz-ok))))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%cons*) - (begin (#%write 'e) ($xxx)) - (begin (#%write 'f) ($yyy)) - (begin (#%write 'g) ($zzz)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%cons* (begin (#3%write 'f) ($yyy)) (begin (#3%write 'g) ($zzz)))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%cons* (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz)))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%cons*) + (begin (#%write 'e) ($xxx)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%cons* (begin (#%write 'f) ($yyy-ok)) (begin (#%write 'g) ($zzz-ok))))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%list*) - (begin (#%write 'e) ($xxx)) - (begin (#%write 'f) (add1 ($yyy))))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%list*) + (begin (#%write 'e) ($xxx)) + (begin (#%write 'f) ($nontail-yyy)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'f) ($nontail-yyy))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%cons*) - (begin (#%write 'e) ($xxx)) - (begin (#%write 'f) (add1 ($yyy))))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%cons*) + (begin (#%write 'e) ($xxx)) + (begin (#%write 'f) ($nontail-yyy)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'f) ($nontail-yyy))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%list*) - (begin (#%write 'e) ($xxx)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%cdr (begin (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx)))) - '(begin (#2%write 'a) (#2%write 'b) (#2%cdr (begin (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx)))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(begin (#%write 'a) + ((begin (#%write 'd) #%list*) + (begin (#%write 'e) ($xxx-ok)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%cdr (begin (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok))))) + (expansion-matches? + '(begin (#%write 'a) ((begin (#%write 'b) #%cdr) (begin (#%write 'c) - ((begin (#%write 'd) #%cons*) - (begin (#%write 'e) ($xxx)))))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%cdr (begin (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx)))) - '(begin (#2%write 'a) (#2%write 'b) (#2%cdr (begin (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx)))))) + ((begin (#%write 'd) #%cons*) + (begin (#%write 'e) ($xxx-ok)))))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%cdr (begin (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok))))) ) (mat cp0-seq-ref @@ -2182,438 +2186,326 @@ (expand/optimize '(string-ref (string #\1 #\2 #\3) 1))) #\2) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (expansion-matches? '(begin (write 'a) ((begin (write 'b) vector-ref) (begin (write 'c) ((begin (write 'd) vector) (begin (write 'e) ($xxx)) - (begin (write 'f) (add1 ($yyy))) + (begin (write 'f) ($nontail-yyy)) (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (begin (write 'h) 1))) + ; other possibilities exist ... + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'g) ($zzz) (#%write 'f) ($nontail-yyy))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) vector-ref) (begin (write 'c) ((begin (write 'd) vector) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 3))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) ($yyy-ok)) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 3))) + ; other possibilities exist... '(begin - (#3%write 'a) - (#3%write 'b) - (#3%vector-ref + (#%write 'a) + (#%write 'b) + (#%vector-ref (begin - (#3%write 'c) - (#3%write 'd) - (#3%vector - (begin (#3%write 'e) ($xxx)) - (begin (#3%write 'f) ($yyy)) - (begin (#3%write 'g) ($zzz)))) - (begin (#3%write 'h) 3))) - '(begin - (#2%write 'a) - (#2%write 'b) - (#2%vector-ref - (begin - (#2%write 'c) - (#2%write 'd) - (#2%vector - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 3))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (#%write 'c) + (#%write 'd) + (#%vector + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 3)))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) list-ref) (begin (write 'c) ((begin (write 'd) list) (begin (write 'e) ($xxx)) - (begin (write 'f) (add1 ($yyy))) + (begin (write 'f) ($nontail-yyy)) (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (begin (write 'h) 1))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'g) ($zzz) (#%write 'f) ($nontail-yyy))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) list-ref) (begin (write 'c) ((begin (write 'd) list*) (begin (write 'e) ($xxx)) - (begin (write 'f) (add1 ($yyy))) + (begin (write 'f) ($nontail-yyy)) (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (begin (write 'h) 1))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'g) ($zzz) (#%write 'f) ($nontail-yyy))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) list-ref) (begin (write 'c) ((begin (write 'd) cons*) (begin (write 'e) ($xxx)) - (begin (write 'f) (add1 ($yyy))) + (begin (write 'f) ($nontail-yyy)) (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy))) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (begin (write 'h) 1))) + ; other possibilities exist... + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx) (#%write 'g) ($zzz) (#%write 'f) ($nontail-yyy))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) list-ref) (begin (write 'c) ((begin (write 'd) cons*) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 2))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) ($yyy-ok)) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 2))) + ; other possibilities exist... '(begin - (#3%write 'a) - (#3%write 'b) - (#3%list-ref + (#%write 'a) + (#%write 'b) + (#%list-ref (begin - (#3%write 'c) - (#3%write 'd) - (#3%cons* - (begin (#3%write 'e) ($xxx)) - (begin (#3%write 'f) ($yyy)) - (begin (#3%write 'g) ($zzz)))) - (begin (#3%write 'h) 2))) - '(begin - (#2%write 'a) - (#2%write 'b) - (#2%list-ref - (begin - (#2%write 'c) - (#2%write 'd) - (#2%cons* - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 2))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (#%write 'c) + (#%write 'd) + (#%cons* + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 2)))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) string-ref) (begin (write 'c) ((begin (write 'd) string) - (begin (write 'e) ($xxx)) + (begin (write 'e) ($xxx-ok)) (begin (write 'f) #\y) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) #\y) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) #\y))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok) (#%write 'g) ($zzz-ok) (#%write 'f) #\y) + '(begin + (#%write 'a) + (#%write 'b) + (#%string-ref + (begin + (#%write 'c) + (#%write 'd) + (#%string + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) #\y) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1))))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) string-ref) (begin (write 'c) ((begin (write 'd) string) - (begin (write 'e) ($xxx)) + (begin (write 'e) ($xxx-ok)) (begin (write 'f) 'oops) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) 'oops) + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok) (#%write 'g) ($zzz-ok) (#%write 'f) 'oops) '(begin - (#2%write 'a) - (#2%write 'b) - (#2%string-ref + (#%write 'a) + (#%write 'b) + (#%string-ref (begin - (#2%write 'c) - (#2%write 'd) - (#2%string - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) 'oops) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 1))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize - '(begin (write 'a) + (#%write 'c) + (#%write 'd) + (#%string + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) 'oops) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1))))) + (expansion-matches? + `(begin (write 'a) ((begin (write 'b) string-ref) (begin (write 'c) ((begin (write 'd) string) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) (,(if (= (optimize-level) 3) '$nontail-yyy '$yyy-ok))) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy)) + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok) (#%write 'g) ($zzz-ok) (#%write 'f) ($nontail-yyy)) '(begin - (#2%write 'a) - (#2%write 'b) - (#2%string-ref + (#%write 'a) + (#%write 'b) + (#%string-ref (begin - (#2%write 'c) - (#2%write 'd) - (#2%string - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 1))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (#%write 'c) + (#%write 'd) + (#%string + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1))))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) string-ref) (begin (write 'c) ((begin (write 'd) #2%string) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) ($yyy-ok)) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... '(begin - (#3%write 'a) - (#3%write 'b) - (#3%string-ref + (#%write 'a) + (#%write 'b) + (#%string-ref (begin - (#3%write 'c) - (#3%write 'd) + (#%write 'c) + (#%write 'd) (#2%string - (begin (#3%write 'e) ($xxx)) - (begin (#3%write 'f) ($yyy)) - (begin (#3%write 'g) ($zzz)))) - (begin (#3%write 'h) 1))) - '(begin - (#2%write 'a) - (#2%write 'b) - (#2%string-ref - (begin - (#2%write 'c) - (#2%write 'd) - (#2%string - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 1))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1)))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) string-ref) (begin (write 'c) ((begin (write 'd) string) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 3))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) ($yyy-ok)) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 3))) + ; other possibilities exist... '(begin - (#3%write 'a) - (#3%write 'b) - (#3%string-ref + (#%write 'a) + (#%write 'b) + (#%string-ref (begin - (#3%write 'c) - (#3%write 'd) - (#3%string - (begin (#3%write 'e) ($xxx)) - (begin (#3%write 'f) ($yyy)) - (begin (#3%write 'g) ($zzz)))) - (begin (#3%write 'h) 3))) - '(begin - (#2%write 'a) - (#2%write 'b) - (#2%string-ref - (begin - (#2%write 'c) - (#2%write 'd) - (#2%string - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 3))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (#%write 'c) + (#%write 'd) + (#%string + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 3)))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) fxvector-ref) (begin (write 'c) ((begin (write 'd) fxvector) - (begin (write 'e) ($xxx)) + (begin (write 'e) ($xxx-ok)) (begin (write 'f) 121) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) 121) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) 121))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok) (#%write 'g) ($zzz-ok) (#%write 'f) 121) + '(begin + (#%write 'a) + (#%write 'b) + (#%fxvector-ref + (begin + (#%write 'c) + (#%write 'd) + (#%fxvector + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) 121) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1))))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) fxvector-ref) (begin (write 'c) ((begin (write 'd) fxvector) - (begin (write 'e) ($xxx)) + (begin (write 'e) ($xxx-ok)) (begin (write 'f) 'oops) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) 'oops) + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok) (#%write 'g) ($zzz-ok) (#%write 'f) 'oops) '(begin - (#2%write 'a) - (#2%write 'b) - (#2%fxvector-ref + (#%write 'a) + (#%write 'b) + (#%fxvector-ref (begin - (#2%write 'c) - (#2%write 'd) - (#2%fxvector - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) 'oops) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 1))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize - '(begin (write 'a) + (#%write 'c) + (#%write 'd) + (#%fxvector + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) 'oops) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1))))) + (expansion-matches? + `(begin (write 'a) ((begin (write 'b) fxvector-ref) (begin (write 'c) ((begin (write 'd) fxvector) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) (,(if (= (optimize-level) 3) '$nontail-yyy '$yyy-ok))) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... (if (= (optimize-level) 3) - '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy)) + '(begin (#%write 'a) (#%write 'b) (#%write 'h) (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok) (#%write 'g) ($zzz-ok) (#%write 'f) ($nontail-yyy)) '(begin - (#2%write 'a) - (#2%write 'b) - (#2%fxvector-ref + (#%write 'a) + (#%write 'b) + (#%fxvector-ref (begin - (#2%write 'c) - (#2%write 'd) - (#2%fxvector - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 1))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (#%write 'c) + (#%write 'd) + (#%fxvector + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1))))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) fxvector-ref) (begin (write 'c) ((begin (write 'd) #2%fxvector) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 1))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) ($yyy-ok)) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 1))) + ; other possibilities exist... '(begin - (#3%write 'a) - (#3%write 'b) - (#3%fxvector-ref + (#%write 'a) + (#%write 'b) + (#%fxvector-ref (begin - (#3%write 'c) - (#3%write 'd) + (#%write 'c) + (#%write 'd) (#2%fxvector - (begin (#3%write 'e) ($xxx)) - (begin (#3%write 'f) ($yyy)) - (begin (#3%write 'g) ($zzz)))) - (begin (#3%write 'h) 1))) - '(begin - (#2%write 'a) - (#2%write 'b) - (#2%fxvector-ref - (begin - (#2%write 'c) - (#2%write 'd) - (#2%fxvector - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 1))))) - (equivalent-expansion? - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)]) - (expand/optimize + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 1)))) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) fxvector-ref) (begin (write 'c) ((begin (write 'd) fxvector) - (begin (write 'e) ($xxx)) - (begin (write 'f) ($yyy)) - (begin (write 'g) ($zzz)))) - (begin (write 'h) 3))))) - ; other possibilities exist but are too many to list and too difficult to construct with $permutations. - ; if you see a problem, convert to use $check-writes (defined above) - (if (= (optimize-level) 3) + (begin (write 'e) ($xxx-ok)) + (begin (write 'f) ($yyy-ok)) + (begin (write 'g) ($zzz-ok)))) + (begin (write 'h) 3))) + ; other possibilities exist... '(begin - (#3%write 'a) - (#3%write 'b) - (#3%fxvector-ref + (#%write 'a) + (#%write 'b) + (#%fxvector-ref (begin - (#3%write 'c) - (#3%write 'd) - (#3%fxvector - (begin (#3%write 'e) ($xxx)) - (begin (#3%write 'f) ($yyy)) - (begin (#3%write 'g) ($zzz)))) - (begin (#3%write 'h) 3))) - '(begin - (#2%write 'a) - (#2%write 'b) - (#2%fxvector-ref - (begin - (#2%write 'c) - (#2%write 'd) - (#2%fxvector - (begin (#2%write 'e) ($xxx)) - (begin (#2%write 'f) ($yyy)) - (begin (#2%write 'g) ($zzz)))) - (begin (#2%write 'h) 3))))) + (#%write 'c) + (#%write 'd) + (#%fxvector + (begin (#%write 'e) ($xxx-ok)) + (begin (#%write 'f) ($yyy-ok)) + (begin (#%write 'g) ($zzz-ok)))) + (begin (#%write 'h) 3)))) ) (mat let-pushing @@ -2830,26 +2722,39 @@ ) (mat cp0-non-tail - ;; Make sure that an expression that might return multiple values is - ;; not moved out of a position that expects a single result. + ;; Make sure that an expression that might depend on a specific + ;; continuation is not moved out of its continuation --- that is, + ;; that it's not moved from non-taul to tail position within a + ;; function. This constaint applies even with optimization level 3, + ;; since it's about the behavior of programs without errors. Also + ;; make sure that redudant wrappers are not left around expressions + ;; where the context otherwise enforces a single-valued result. (begin (define (simplify-only-nontail? mk) (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (and + ;; Identifier is known single-valued, doesn't use continuation: (equivalent-expansion? (expand/optimize `(lambda (g) ,(mk `g))) '(lambda (g) g)) + ;; Call to identifier is not known single-valued, might depend + ;; on the continuation: (not (equivalent-expansion? (expand/optimize `(lambda (g) ,(mk `(g)))) '(lambda (g) (g)))) + ;; Ditto, but in a nested procedure: (not (equivalent-expansion? (expand/optimize `(lambda () (lambda (g) ,(mk `(g))))) '(lambda () (lambda (g) (g))))) + ;; Argument position already enforces single-valued and no + ;; dependency on surrounding continuation: (equivalent-expansion? - (expand/optimize `(lambda (g) (list ,(mk `(g))))) - (if (eqv? (optimize-level) 3) - '(lambda (g) (#3%list (g))) - '(lambda (g) (#2%list (g))))) + (expand/optimize `(lambda (g) (#2%list ,(mk `(g))))) + '(lambda (g) (#2%list (g)))) + (equivalent-expansion? + (expand/optimize `(lambda (g) (#3%list ,(mk `(g))))) + '(lambda (g) (#3%list (g)))) + ;; Same for the test position of `if`: (equivalent-expansion? (expand/optimize `(lambda (g) (if ,(mk `(g)) 1 2))) '(lambda (g) (if (g) 1 2)))))) @@ -2864,3 +2769,51 @@ (simplify-only-nontail? (lambda (e) `(car (cons ,e 2)))) (simplify-only-nontail? (lambda (e) `(cdr (cons 2 ,e)))) ) + +(mat cp0-single-valued + ;; Make sure that lifted-out expressions retain a single-result + ;; check in safe mode even when the result is not used, but no + ;; check in unsafe mode. + (begin + (define adds-needed-$value? + (case-lambda + [(mk safe-extras) + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (and + (equivalent-expansion? + (expand/optimize `(lambda (g) ,(mk '(g) 3))) + (if (= (optimize-level) 3) + '(lambda (g) (g) 3) + `(lambda (g) ,@safe-extras (#3%$value (g)) 3)))))] + [(mk) (adds-needed-$value? mk '())])) + (define posn-decl-expanded + '((#2%$make-record-type-descriptor + #!base-rtd 'posn #f #f #f #f + '#((immutable x) (immutable y)) 'define-record-type))) + #t) + (adds-needed-$value? (lambda (e v) `(if (let ([x ,e]) #t) ,v 'other))) + (adds-needed-$value? (lambda (e v) `(if (list ,e) ,v 'other))) + (adds-needed-$value? (lambda (e v) `(if (if ,e #t 'yes) ,v 'other))) + (adds-needed-$value? (lambda (e v) `(if (if ,e #f #f) 'other ,v))) + (adds-needed-$value? (lambda (e v) `(if (if ,e #f #t) ,v ,v))) + (adds-needed-$value? (lambda (e v) `(let ([unused 0]) (set! unused ,e) ,v))) + (adds-needed-$value? (lambda (e v) `(car (cons ,v ,e)))) + (adds-needed-$value? (lambda (e v) `(vector-ref (vector ,v ,e) 0))) + (adds-needed-$value? (lambda (e v) `(begin + (define-record-type posn + (fields x y)) + (make-posn -1 ,e) + ,v)) + posn-decl-expanded) + (adds-needed-$value? (lambda (e v) `(let () + (define-record-type posn + (fields x y)) + (posn-x (make-posn ,v ,e)))) + posn-decl-expanded) + (adds-needed-$value? (lambda (e v) `(let () + (define-record-type posn + (fields x y)) + (if (make-posn 0 ,e) ,v 'other))) + posn-decl-expanded) + +) diff --git a/mats/record.ms b/mats/record.ms index c8aa0dcf15..19e67f09ca 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -8853,7 +8853,7 @@ (make-foo 3)))) `(let ([ctr 0]) (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))]) - (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type) + (#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)) (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr))))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) @@ -8872,7 +8872,7 @@ (make-foo 3)))) `(let ([ctr 0]) (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))]) - (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type) + (#3%$value (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)) (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr))))) (error? ; invalid uid (let () diff --git a/s/cp0.ss b/s/cp0.ss index 9b8d752747..0de44ec923 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -230,6 +230,26 @@ ;;; contexts + ;; 'value - result used, context checks for single-value result, + ;; not in tail position within an enclosing function + ;; 'test - result used as boolean, context checks for single-value result, + ;; not in tail position within an enclosing function + ;; 'tail - result used, multiple values ok, in tail position + ;; within an enclosing function + ;; 'effect - result not used, multiple values ok, not in tail + ;; position + ;; 'ignored - result not used, must produce a single value, + ;; not in tail position + + ;; Beware that "ctxt" sometimes actually refers to an app context, + ;; not one of the above contexts. + + (define (context-imposes-single-value? ctxt) + (or (eq? ctxt 'value) (eq? ctxt 'test))) + + (define (unused-value-context? ctxt) + (or (eq? ctxt 'effect) (eq? ctxt 'ignored))) + ;; app context: ;; opnds are the operands at the call site ;; ctxt is the outer context @@ -456,7 +476,7 @@ ; further, require each RHS to be pure unless the body is pure, since it's ; unsound to split apart two things that can observe a side effect or two ; allocation operations that can be separated by a continuation grab. - [(if (ivory? body) (andmap simple/profile? e*) (andmap ivory? e*)) + [(if (ivory? body) (andmap simple/profile1? e*) (andmap ivory1? e*)) ; assocate each lhs with cooked operand for corresponding rhs. make-record-constructor-descriptor, ; at least, counts on this to allow protocols to be inlined. (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*) @@ -496,7 +516,7 @@ ; pure OR body to be pure, since we can't separate non-pure ; RHS and body expressions [(letrec ([,x* ,e*] ...) ,body) - (guard (or (ivory? body) (andmap ivory? e*))) + (guard (or (ivory? body) (andmap ivory1? e*))) ; assocate each lhs with cooked operand for corresponding rhs. see note above. (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*) (values (make-lifted #f x* e*) body)] @@ -510,7 +530,7 @@ (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*) (values (make-lifted #t x* e*) (build-ref x))))] [(letrec* ([,x* ,e*] ...) ,body) - (guard (or (ivory? body) (andmap ivory? e*))) + (guard (or (ivory? body) (andmap ivory1? e*))) ; assocate each lhs with cooked operand for corresponding rhs. see note above. (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*) (values (make-lifted #t x* e*) body)] @@ -597,9 +617,9 @@ (if (null? todo) e (f (cdr todo) - (make-seq ctxt + (make-1seq ctxt (let ((opnd (car todo))) - (cp0 (operand-exp opnd) 'effect (operand-env opnd) + (cp0 (operand-exp opnd) 'ignored (operand-env opnd) sc (operand-wd opnd) (operand-name opnd) (operand-moi opnd))) e))))) (let ((opnd (car unused))) @@ -614,7 +634,7 @@ ; we add in the entire score here ; if singly-referenced integration attempt in copy2 succeeded, but ; value isn't simple, we also pay the whole price - (make-seq ctxt e (f (cdr unused) (fx+ n (operand-score opnd)) todo))) + (make-1seq ctxt e (f (cdr unused) (fx+ n (operand-score opnd)) todo))) (if (operand-singly-referenced-score opnd) ; singly-referenced integration attempt in ref-case of cp0 succeeded (f (cdr unused) (fx+ (operand-singly-referenced-score opnd) n) todo) @@ -714,16 +734,32 @@ (lambda (ctxt e1 e2) (if (simple? e1) e2 - (if (and (eq? ctxt 'effect) (simple? e2)) - e1 - (let ([e1 (nanopass-case (Lsrc Expr) e1 - [(seq ,e11 ,e12) - (guard (simple? e12)) - e11] - [else e1])]) - (nanopass-case (Lsrc Expr) e2 - [(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)] - [else `(seq ,e1 ,e2)])))))) + (cond + [(and (eq? ctxt 'effect) (simple? e2)) + e1] + [(and (eq? ctxt 'ignored) (simple1? e2)) + e1] + [else + (let ([e1 (nanopass-case (Lsrc Expr) e1 + [(seq ,e11 ,e12) + (guard (simple? e12)) + e11] + [else e1])]) + (nanopass-case (Lsrc Expr) e2 + [(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)] + [else `(seq ,e1 ,e2)]))])))) + + (define make-1seq + ;; like `make-seq`, but preserves the requirement that `e1` + ;; produces a single value when compiling in safe mode + (lambda (ctxt e1 e2) + (make-seq ctxt (safe-single-value e1) e2))) + + (define (safe-single-value e1) + (if (or (fx= (optimize-level) 3) + (single-valued? e1)) + e1 + (build-primcall 3 '$value (list e1)))) (define make-seq* ; requires at least one operand (lambda (ctxt e*) @@ -731,10 +767,16 @@ (car e*) (make-seq ctxt (car e*) (make-seq* ctxt (cdr e*)))))) + (define make-1seq* ; requires at least one operand + (lambda (ctxt e*) + (if (null? (cdr e*)) + (safe-single-value (car e*)) + (make-1seq ctxt (car e*) (make-1seq* ctxt (cdr e*)))))) + (define make-if (lambda (ctxt sc e1 e2 e3) (cond - [(record-equal? e2 e3 ctxt) (make-seq ctxt e1 e2)] + [(record-equal? e2 e3 ctxt) (make-1seq ctxt e1 e2)] [(and (cp0-constant? (lambda (x) (eq? x #f)) e3) (record-equal? e1 e2 (if (eq? ctxt 'test) 'test 'value)) (simple? e1)) @@ -745,8 +787,8 @@ (let ([d12 (cp0-datum re12)] [d13 (cp0-datum re13)]) (non-result-exp e1 (cond - [(and d12 d13) (make-seq ctxt (make-if 'effect sc e11 e12 e13) e2)] - [(not (or d12 d13)) (make-seq ctxt (make-if 'effect sc e11 e12 e13) e3)] + [(and d12 d13) (make-1seq ctxt (make-if 'ignored sc e11 e12 e13) e2)] + [(not (or d12 d13)) (make-1seq ctxt (make-if 'ignored sc e11 e12 e13) e3)] [else (let-values ([(e2 e3) (if d12 (values e2 e3) (values e3 e2))]) (make-if ctxt sc e11 (non-result-exp e12 e2) (non-result-exp e13 e3)))]))) #f)] @@ -757,11 +799,12 @@ (define make-nontail (lambda (ctxt e) - (if (or (not (eq? (app-ctxt ctxt) 'tail)) - (single-valued-nontail? e)) + (if (context-case ctxt + [(tail) (single-valued-nontail? e)] + [(ignored) (single-valued? e)] + [else #t]) e - (let ([tmp (cp0-make-temp #f)]) - (build-let (list tmp) (list e) (build-ref tmp)))))) + (build-primcall 3 '$value (list e))))) (define result-exp (lambda (e) @@ -887,7 +930,7 @@ ((ids->do-clause '()) clause) #t)))) - (module (pure? ivory? simple? simple/profile? boolean-valued? single-valued-nontail?) + (module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued? single-valued? single-valued-nontail?) (define-syntax make-$memoize (syntax-rules () [(_ flag-known flag) @@ -935,7 +978,7 @@ (memoize (and (or (not maybe-e) (pure? maybe-e)) (andmap pure? e*))))] [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) (guard (fx= interface (length e*))) - (memoize (and (or (not maybe-e) (pure? maybe-e)) (pure? body) (andmap pure? e*)))] + (memoize (and (or (not maybe-e) (pure? maybe-e)) (pure? body) (andmap pure1? e*)))] [else #f]))) (nanopass-case (Lsrc Expr) e [(seq ,e1 ,e2) (pure-call? e1 e2)] @@ -943,7 +986,7 @@ [(quote ,d) #t] [,pr (all-set? (prim-mask proc) (primref-flags pr))] [(case-lambda ,preinfo ,cl* ...) #t] - [(if ,e1 ,e2 ,e3) (memoize (and (pure? e1) (pure? e2) (pure? e3)))] + [(if ,e1 ,e2 ,e3) (memoize (and (pure1? e1) (pure? e2) (pure? e3)))] [(seq ,e1 ,e2) (memoize (and (pure? e1) (pure? e2)))] [(record-ref ,rtd ,type ,index ,e) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] @@ -952,21 +995,26 @@ (and (not (fld-mutable? fld)) (eq? (filter-foreign-type (fld-type fld)) 'scheme-object))) (rtd-flds rtd)) - (memoize (and (pure? rtd-expr) (andmap pure? e*))))] + (memoize (and (pure1? rtd-expr) (andmap pure1? e*))))] [(set! ,maybe-src ,x ,e) #f] - [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))] - [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] - [(record-type ,rtd ,e) (memoize (pure? e))] + [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure1? e))] + [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure1? e*) (pure? body)))] + [(record-type ,rtd ,e) (memoize (pure1? e))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] - [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] - [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))] + [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure1? e*) (pure? body)))] + [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure1? e*) (pure? e)))] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (pure? e))] [(moi) #t] - [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] + [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure1? e))] [(pariah) #t] [else ($oops who "unrecognized record ~s" e)])))) + (define pure1? + (lambda (e) + (and (pure? e) + (or (fx= (optimize-level) 3) (single-valued? e))))) + (define-who ivory? ; 99.44% pure ; does not cause or observe any effects, capture or invoke a continuation, ; or allocate mutable data structures. might contain profile forms, so @@ -990,10 +1038,10 @@ (all-set? (prim-mask pure) flags) (all-set? (prim-mask (or pure unrestricted)) flags))) (arity-okay? (primref-arity e) (length e*)) - (memoize (and (or (not maybe-e) (ivory? maybe-e)) (andmap ivory? e*))))] + (memoize (and (or (not maybe-e) (ivory? maybe-e)) (andmap ivory1? e*))))] [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) (guard (fx= interface (length e*))) - (memoize (and (or (not maybe-e) (ivory? maybe-e)) (ivory? body) (andmap ivory? e*)))] + (memoize (and (or (not maybe-e) (ivory? maybe-e)) (ivory? body) (andmap ivory1? e*)))] [else #f]))) (nanopass-case (Lsrc Expr) e [(seq ,e1 ,e2) (ivory-call? e1 e2)] @@ -1001,31 +1049,36 @@ [(quote ,d) #t] [,pr (all-set? (prim-mask proc) (primref-flags pr))] [(case-lambda ,preinfo ,cl* ...) #t] - [(if ,e1 ,e2 ,e3) (memoize (and (ivory? e1) (ivory? e2) (ivory? e3)))] + [(if ,e1 ,e2 ,e3) (memoize (and (ivory1? e1) (ivory? e2) (ivory? e3)))] [(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))] [(record-ref ,rtd ,type ,index ,e) ; here ivory? differs from pure? (and (not (fld-mutable? (list-ref (rtd-flds rtd) index))) - (memoize (ivory? e)))] + (memoize (ivory1? e)))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record ,rtd ,rtd-expr ,e* ...) ; here ivory? differs from pure? (and (andmap (lambda (fld) (not (fld-mutable? fld))) (rtd-flds rtd)) - (memoize (and (ivory? rtd-expr) (andmap ivory? e*))))] + (memoize (and (ivory1? rtd-expr) (andmap ivory1? e*))))] [(set! ,maybe-src ,x ,e) #f] - [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))] - [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] - [(record-type ,rtd ,e) (memoize (ivory? e))] - [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] - [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] - [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))] + [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory1? e))] + [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))] + [(record-type ,rtd ,e) (memoize (ivory1? e))] + [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))] + [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory1? e*) (ivory? body)))] + [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory1? e*) (ivory? e)))] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (ivory? e))] [(moi) #t] - [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] + [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory1? e))] [(pariah) #t] [else ($oops who "unrecognized record ~s" e)])))) + (define ivory1? + (lambda (e) + (and (ivory? e) + (or (fx= (optimize-level) 3) (single-valued? e))))) + (define-who simple? (lambda (e) (with-memoize (simple-known simple) e @@ -1043,33 +1096,39 @@ (all-set? (prim-mask discard) flags) (all-set? (prim-mask (or discard unrestricted)) flags)) (arity-okay? (primref-arity pr) (length e*)) - (memoize (andmap simple? e*))))] + (memoize (andmap simple1? e*))))] [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) (guard (fx= interface (length e*))) - (memoize (and (simple? body) (andmap simple? e*)))] + (memoize (and (simple? body) (andmap simple1? e*)))] [else #f])] [(ref ,maybe-src ,x) #t] [(case-lambda ,preinfo ,cl* ...) #t] - [(if ,e1 ,e2 ,e3) (memoize (and (simple? e1) (simple? e2) (simple? e3)))] + [(if ,e1 ,e2 ,e3) (memoize (and (simple1? e1) (simple? e2) (simple? e3)))] [(seq ,e1 ,e2) (memoize (and (simple? e1) (simple? e2)))] [(set! ,maybe-src ,x ,e) #f] - [(immutable-list (,e* ...) ,e) (memoize (and (andmap simple? e*) (simple? e)))] - [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple? e*) (simple? body)))] - [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple? e*) (simple? body)))] + [(immutable-list (,e* ...) ,e) (memoize (and (andmap simple1? e*) (simple? e)))] + [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple1? e*) (simple? body)))] + [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple1? e*) (simple? body)))] [,pr #t] - [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))] - [(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))] + [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple1? e))] + [(record-ref ,rtd ,type ,index ,e) (memoize (simple1? e))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] - [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] - [(record-type ,rtd ,e) (memoize (simple? e))] - [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))] + [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple1? e))] + [(record-type ,rtd ,e) (memoize (simple1? e))] + [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple1? rtd-expr) (andmap simple1? e*)))] [(pariah) #f] [(profile ,src) #f] [(cte-optimization-loc ,box ,e) (memoize (simple? e))] [(moi) #t] - [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] + [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple1? e))] [else ($oops who "unrecognized record ~s" e)])))) + (define simple1? + (lambda (e) + (and (simple? e) + (or (fx= (optimize-level) 3) + (single-valued? e))))) + (define-who simple/profile? ; like simple? but allows profile forms. used for lifting bindings. (lambda (e) @@ -1088,33 +1147,38 @@ (all-set? (prim-mask discard) flags) (all-set? (prim-mask (or discard unrestricted)) flags)) (arity-okay? (primref-arity pr) (length e*)) - (memoize (andmap simple/profile? e*))))] + (memoize (andmap simple/profile1? e*))))] [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) (guard (fx= interface (length e*))) - (memoize (and (simple/profile? body) (andmap simple/profile? e*)))] + (memoize (and (simple/profile? body) (andmap simple/profile1? e*)))] [else #f])] [(ref ,maybe-src ,x) #t] [(case-lambda ,preinfo ,cl* ...) #t] - [(if ,e1 ,e2 ,e3) (memoize (and (simple/profile? e1) (simple/profile? e2) (simple/profile? e3)))] + [(if ,e1 ,e2 ,e3) (memoize (and (simple/profile1? e1) (simple/profile? e2) (simple/profile? e3)))] [(seq ,e1 ,e2) (memoize (and (simple/profile? e1) (simple/profile? e2)))] [(set! ,maybe-src ,x ,e) #f] - [(immutable-list (,e* ...) ,e) (memoize (and (andmap simple/profile? e*) (simple/profile? e)))] - [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile? e*) (simple/profile? body)))] - [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile? e*) (simple/profile? body)))] + [(immutable-list (,e* ...) ,e) (memoize (and (andmap simple/profile1? e*) (simple/profile? e)))] + [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile1? e*) (simple/profile? body)))] + [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile1? e*) (simple/profile? body)))] [,pr #t] - [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))] - [(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))] + [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile1? e))] + [(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile1? e))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] - [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] - [(record-type ,rtd ,e) (memoize (simple/profile? e))] - [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))] + [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))] + [(record-type ,rtd ,e) (memoize (simple/profile1? e))] + [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile1? rtd-expr) (andmap simple/profile1? e*)))] [(pariah) #t] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))] [(moi) #t] - [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] + [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile1? e))] [else ($oops who "unrecognized record ~s" e)])))) + (define simple/profile1? + (lambda (e) + (and (simple/profile? e) + (or (fx= (optimize-level) 3) (single-valued? e))))) + (define-who boolean-valued? (lambda (e) (with-memoize (boolean-valued-known boolean-valued) e @@ -1150,12 +1214,10 @@ [(pariah) #f] [else ($oops who "unrecognized record ~s" e)])))) - (define-who single-valued-nontail? + (define-who single-valued? (lambda (e) (with-memoize (single-valued-nontail-known single-valued-nontail) e - ; known to produce a single value, and does not observe - ; or affect the immediate continuation frame (so removing - ; (an enclosing frame would be ok) + ; known to produce a single value (nanopass-case (Lsrc Expr) e [(quote ,d) #t] [(call ,preinfo ,e ,e* ...) @@ -1163,16 +1225,16 @@ [,pr (all-set? (prim-mask single-valued) (primref-flags pr))] [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) (guard (fx= interface (length e*))) - (memoize (single-valued-nontail? body))] + (memoize (single-valued? body))] [else #f])] [(ref ,maybe-src ,x) #t] [(case-lambda ,preinfo ,cl* ...) #t] - [(if ,e1 ,e2 ,e3) (memoize (and (single-valued-nontail? e2) (single-valued-nontail? e3)))] - [(seq ,e1 ,e2) (memoize (single-valued-nontail? e2))] + [(if ,e1 ,e2 ,e3) (memoize (and (single-valued? e2) (single-valued? e3)))] + [(seq ,e1 ,e2) (memoize (single-valued? e2))] [(set! ,maybe-src ,x ,e) #t] [(immutable-list (,e* ...) ,e) #t] - [(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued-nontail? body))] - [(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued-nontail? body))] + [(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued? body))] + [(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued? body))] [,pr #t] [(record-cd ,rcd ,rtd-expr ,e) #t] [(record-ref ,rtd ,type ,index ,e) #t] @@ -1182,10 +1244,20 @@ [(record ,rtd ,rtd-expr ,e* ...) #t] [(pariah) #t] [(profile ,src) #t] - [(cte-optimization-loc ,box ,e) (memoize (single-valued-nontail? e))] + [(cte-optimization-loc ,box ,e) (memoize (single-valued? e))] [(moi) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t] - [else ($oops who "unrecognized record ~s" e)]))))) + [else ($oops who "unrecognized record ~s" e)])))) + + (define-who single-valued-nontail? + (lambda (e) + ;; Single-valued and does not observe or affect the + ;; immediate continuation frame (so removing (an enclosing + ;; frame would be ok). This currently can be implemented as + ;; `single-valued?`, because `single-valued?` does not look + ;; into continuation-observing calls like `(call/cc (lambda + ;; (k) ))` to detect that `` is single valued. + (single-valued? e)))) (define find-call-lambda-clause (lambda (exp opnds) @@ -1316,12 +1388,10 @@ [(and (= (length id*) 1) (nanopass-case (Lsrc Expr) body [(ref ,maybe-src ,x) (eq? x (car id*))] - [else #f]) - (or (not (eq? (app-ctxt ctxt) 'tail)) - (single-valued-nontail? (car rhs*)))) + [else #f])) ; (let ((x e)) x) => e ; x is clearly not assigned, even if flags are polluted and say it is - (car rhs*)] + (make-nontail (app-ctxt ctxt) (car rhs*))] ; we drop the RHS of a let binding into the let body when the body expression is a call ; and we can do so without violating evaluation order of bindings wrt the let body: ; * for pure, singly referenced bindings, we drop them to the variable reference site @@ -1483,7 +1553,7 @@ (when change? (loop pending-ids pending-opnds '() '() #f)) (let ([id (car ids)] [opnd (car opnds)]) (if (or (prelex-referenced id) - (not (simple? (operand-exp opnd)))) + (not (simple1? (operand-exp opnd)))) (begin (value-visit-operand! opnd) (loop (cdr ids) (cdr opnds) pending-ids pending-opnds @@ -1498,7 +1568,7 @@ (bump sc n) (if (or (null? ids) ; don't allow conservative referenced flags prevent constant folding - (and (cp0-constant? body) (andmap simple? vals))) + (and (cp0-constant? body) (andmap simple1? vals))) body (if seq? `(letrec* ([,(reverse ids) ,(reverse vals)] ...) ,body) @@ -1510,7 +1580,7 @@ ; scoring bug: we don't count size of bindings when we ; drop the rest of the RHS (define (f ids vals seq?) - (if (or (prelex-referenced id) (not (simple? val))) + (if (or (prelex-referenced id) (not (simple1? val))) (loop (cdr old-ids) (cdr opnds) (cons id ids) (cons val vals) (+ n (operand-score opnd)) seq?) (let ([n (+ (or (operand-singly-referenced-score opnd) 0) n)]) @@ -1672,11 +1742,14 @@ (let ([opnds (app-opnds ctxt)] [outer-ctxt (app-ctxt ctxt)]) (let ([flags (primref-flags pr)]) (cond - [(and (eq? outer-ctxt 'effect) + [(and (unused-value-context? outer-ctxt) (if (all-set? (prim-mask unsafe) flags) (all-set? (prim-mask discard) flags) (and (all-set? (prim-mask (or unrestricted discard)) flags) - (arity-okay? (primref-arity pr) (length opnds))))) + (arity-okay? (primref-arity pr) (length opnds)))) + (or (not (eq? outer-ctxt 'ignored)) + (fx= (optimize-level) 3) + (all-set? (prim-mask single-valued) flags))) (residualize-seq '() opnds ctxt) void-rec] [(and (eq? outer-ctxt 'test) @@ -1689,7 +1762,7 @@ true-rec] [(and (eq? outer-ctxt 'test) (all-set? (prim-mask true) flags)) - (make-seq outer-ctxt + (make-1seq outer-ctxt (fold-primref2 pr (primref-name pr) opnds flags ctxt sc wd name moi) true-rec)] [else (fold-primref2 pr (primref-name pr) opnds flags ctxt sc wd name moi)]))))) @@ -1738,7 +1811,7 @@ (define record-equal? ; not very ambitious (lambda (e1 e2 ctxt) - (if (eq? ctxt 'effect) + (if (unused-value-context? ctxt) (and (simple? e1) (simple? e2)) (nanopass-case (Lsrc Expr) e1 [(ref ,maybe-src1 ,x1) @@ -2099,24 +2172,11 @@ [(and (app-used ctxt1) (let ([e (result-exp *p-val)]) (nanopass-case (Lsrc Expr) e - ; in dire need of matching more than one pattern - [(quote ,d) (list e)] - [(ref ,maybe-src ,x) (list e)] - [(set! ,maybe-src ,x0 ,e0) (list e)] - [(case-lambda ,preinfo ,cl* ...) (list e)] - [,pr (list e)] - [(foreign (,conv* ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)] - [(fcallable (,conv* ...) ,e0 (,arg-type* ...) ,result-type) (list e)] - [(record-type ,rtd0 ,e0) (list e)] - [(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)] - [(immutable-list (,e0* ...) ,e0) (list e)] - [(record-ref ,rtd ,type ,index ,e0) (list e)] - [(record-set! ,rtd ,type ,index ,e1 ,e2) (list e)] - [(record ,rtd ,rtd-expr ,e* ...) (list e)] [(call ,preinfo ,pr ,e* ...) (guard (eq? (primref-name pr) 'values)) e*] - [else #f]))) => + [else (and (single-valued? e) + (list e))]))) => (lambda (args) ; (with-values (values arg ...) c-temp) => (c-temp arg ...) (letify (make-preinfo-lambda) ids ctxt @@ -2166,9 +2226,16 @@ (define-inline 2 (cons* list* values append append!) [(x) (begin (residualize-seq (list x) '() ctxt) - (make-nontail ctxt (value-visit-operand! x)))] + (make-nontail (app-ctxt ctxt) (value-visit-operand! x)))] [args #f]) + (define-inline 2 $value + [(x) (let ([v (value-visit-operand! x)]) + (and (single-valued? v) + (begin + (residualize-seq (list x) '() ctxt) + v)))]) + (define-inline 2 vector [() (begin (residualize-seq '() '() ctxt) @@ -3670,7 +3737,7 @@ (cons `(call ,preinfo (ref #f ,p) ,(map (lambda (t*) (build-ref (car t*))) t**) ...) (g (map cdr t**))))))]) - (if (and map? (not (eq? (app-ctxt ctxt) 'effect))) + (if (and map? (not (unused-value-context? (app-ctxt ctxt)))) (if (null? results) null-rec (build-primcall lvl 'list results)) @@ -3707,7 +3774,7 @@ ; 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. - [(and (eq? (app-ctxt ctxt) 'effect) + [(and (unused-value-context? (app-ctxt ctxt)) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) [,pr (let ([flags (primref-flags pr)]) (and (if (all-set? (prim-mask unsafe) flags) @@ -3756,8 +3823,8 @@ (list (build-ref x)))) ls*) ...) ropnd*))]) - (if (eq? ctxt 'effect) - (make-seq* ctxt opnd*) + (if (unused-value-context? ctxt) + (make-1seq* ctxt opnd*) (build-primcall 3 'list opnd*))) (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) (build-let tls* @@ -3887,7 +3954,7 @@ (define-inline 3 vector-map [(?p ?v . ?v*) (cond - [(eq? (app-ctxt ctxt) 'effect) + [(unused-value-context? (app-ctxt ctxt)) ; treat vector-map in effect context as vector-for-each (cp0 (lookup-primref 3 'vector-for-each) ctxt empty-env sc wd name moi)] [(ormap (lambda (?v) @@ -4224,19 +4291,19 @@ (and (not (null? e*)) (begin (residualize-seq '() (list ?x) ctxt) - (make-nontail ctxt (car e*))))] + (make-nontail (app-ctxt ctxt) (car e*))))] [(call ,preinfo ,pr ,e1 ,e2) (guard (eq? (primref-name pr) 'cons)) (residualize-seq (list ?x) '() ctxt) (non-result-exp (operand-value ?x) - (make-seq (app-ctxt ctxt) e2 (make-nontail ctxt e1)))] + (make-1seq (app-ctxt ctxt) e2 (make-nontail (app-ctxt ctxt) e1)))] [(call ,preinfo ,pr ,e* ...) (guard (memq (primref-name pr) '(list list* cons*)) (not (null? e*))) (residualize-seq (list ?x) '() ctxt) (non-result-exp (operand-value ?x) (fold-right - (lambda (e1 e2) (make-seq (app-ctxt ctxt) e1 e2)) - (make-nontail ctxt (car e*)) + (lambda (e1 e2) (make-1seq (app-ctxt ctxt) e1 e2)) + (make-nontail (app-ctxt ctxt) (car e*)) (cdr e*)))] [else #f])]) @@ -4254,18 +4321,18 @@ (guard (eq? (primref-name pr) 'cons)) (residualize-seq (list ?x) '() ctxt) (non-result-exp (operand-value ?x) - (make-seq (app-ctxt ctxt) e1 (make-nontail ctxt e2)))] + (make-1seq (app-ctxt ctxt) e1 (make-nontail (app-ctxt ctxt) e2)))] [(call ,preinfo ,pr ,e* ...) (guard (eq? (primref-name pr) 'list) (not (null? e*))) (residualize-seq (list ?x) '() ctxt) (non-result-exp (operand-value ?x) - (make-seq (app-ctxt ctxt) (car e*) + (make-1seq (app-ctxt ctxt) (car e*) (build-call (app-preinfo ctxt) pr (cdr e*))))] [(call ,preinfo ,pr ,e* ...) (guard (memq (primref-name pr) '(list* cons*)) (>= (length e*) 2)) (residualize-seq (list ?x) '() ctxt) (non-result-exp (operand-value ?x) - (make-seq (app-ctxt ctxt) (car e*) + (make-1seq (app-ctxt ctxt) (car e*) (build-call (app-preinfo ctxt) pr (cdr e*))))] [else #f])]) @@ -4279,12 +4346,12 @@ (let ([ed (car e*)]) (and (edok? (result-exp ed)) (f (cdr e*) (fx- d 1) ed))) (let ([e (f (cdr e*) (fx- d 1) ed)]) - (and e (make-seq (app-ctxt ctxt) (car e*) e))))))]) + (and e (edok? (result-exp (car e*))) (make-1seq (app-ctxt ctxt) (car e*) e))))))]) (and e (begin (residualize-seq (list ?x ?i) '() ctxt) (non-result-exp (operand-value ?i) ; do first ... (non-result-exp (operand-value ?x) ; ... so we keep ?x related side effects together - (make-nontail ctxt e)))))))) + (make-nontail (app-ctxt ctxt) e)))))))) (define tryref (lambda (ctxt ?x ?i seqprim maybe-pred) @@ -4482,7 +4549,7 @@ [(quote ,d) ir] [(ref ,maybe-src ,x) (context-case ctxt - [(effect) void-rec] + [(effect ignored) void-rec] [else (let ((new-id (lookup x env))) (when (eq? new-id x) @@ -4549,7 +4616,7 @@ [(if ,[cp0 : e1 'test env sc wd #f moi -> e1] ,e2 ,e3) (nanopass-case (Lsrc Expr) (result-exp e1) [(quote ,d) - (make-seq ctxt e1 (cp0 (if d e2 e3) ctxt env sc wd name moi))] + (make-1seq ctxt e1 (cp0 (if d e2 e3) ctxt env sc wd name moi))] [else (let ((noappctxt (if (app? ctxt) 'value ctxt))) (let ([e2 (cp0 e2 noappctxt env sc wd name moi)] @@ -4563,7 +4630,13 @@ (let ((e (cp0 e 'value env sc wd (prelex-name x) moi))) (set-prelex-assigned! new-id #t) `(set! ,maybe-src ,new-id ,e))) - (make-seq ctxt (cp0 e 'effect env sc wd (prelex-name x) moi) void-rec)))] + (make-1seq ctxt (cp0 e 'ignored env sc wd (prelex-name x) moi) void-rec)))] + [(call ,preinfo ,pr (seq ,e1 ,e2)) + (guard (eq? (primref-name pr) '$value)) + ;; This simplication probably doesn't enable optimizations, but + ;; it cleans up and normalizes output, which is at least helpful + ;; for testing + (cp0 `(seq ,e1 (call ,preinfo ,pr ,e2)) ctxt env sc wd name moi)] [(call ,preinfo ,e ,e* ...) (let () (define lift-let @@ -4624,7 +4697,7 @@ `(clause (,x* ...) ,interface ,(cp0 body 'tail env sc wd #f name))) (f (cdr cl*) new-mask))))]))) ...)] - [(effect) void-rec] + [(effect ignored) void-rec] [(test) true-rec] [(app) (with-values (find-lambda-clause ir ctxt) @@ -4670,7 +4743,7 @@ (cp0-rec-let #t x* e* body ctxt env sc wd name moi)] [,pr (context-case ctxt [(value tail) (bump sc 1) pr] - [(effect) void-rec] + [(effect ignored) void-rec] [(test) (if (all-set? (prim-mask proc) (primref-flags pr)) true-rec @@ -4679,12 +4752,13 @@ [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (context-case ctxt [(value tail app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] - [(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])] + [(effect ignored) (make-nontail ctxt (cp0 e 'ignored env sc wd #f moi))] + [(test) (make-1seq ctxt (cp0 e 'ignored env sc wd #f moi) true-rec)])] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (context-case ctxt [(value tail app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] - [(effect) (cp0 e 'effect env sc wd #f moi)] - [(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])] + [(effect ignored) (make-nontail ctxt (cp0 e 'ignored env sc wd #f moi))] + [(test) (make-1seq ctxt (cp0 e 'ignored env sc wd #f moi) true-rec)])] [(record ,rtd ,rtd-expr ,e* ...) (context-case ctxt [(value tail app) @@ -4699,26 +4773,26 @@ (rtd-flds d)) (let ([d* (objs-if-constant e*)]) (and d* - (make-seq ctxt - (make-seq* 'effect (cons rtd-expr e*)) + (make-1seq ctxt + (make-1seq* 'ignored (cons rtd-expr e*)) `(quote ,(apply $record d d*))))))] [else #f]) `(record ,rtd ,rtd-expr ,e* ...)))] - [(effect) - (make-seq* ctxt + [(effect ignored) + (make-1seq* ctxt (cons - (cp0 rtd-expr 'effect env sc wd #f moi) - (map (lambda (e) (cp0 e 'effect env sc wd #f moi)) e*)))] + (cp0 rtd-expr 'ignored env sc wd #f moi) + (map (lambda (e) (cp0 e 'ignored env sc wd #f moi)) e*)))] [(test) - (make-seq ctxt - (make-seq* 'effect + (make-1seq ctxt + (make-seq* 'ignored (cons - (cp0 rtd-expr 'effect env sc wd #f moi) - (map (lambda (e) (cp0 e 'effect env sc wd #f moi)) e*))) + (cp0 rtd-expr 'ignored env sc wd #f moi) + (map (lambda (e) (cp0 e 'ignored env sc wd #f moi)) e*))) true-rec)])] [(record-ref ,rtd ,type ,index ,e) (context-case ctxt - [(effect) (cp0 e 'effect env sc wd name moi)] + [(effect ignored) (make-nontail ctxt (cp0 e 'ignored env sc wd name moi))] [else (let ([e (cp0 e 'value env sc wd name moi)]) (or (nanopass-case (Lsrc Expr) (result-exp e) @@ -4731,8 +4805,8 @@ (if (= index 0) (let ([e (car e*)] [e* (rappend re* (cdr e*))]) (if (null? e*) - e - (make-seq ctxt (make-seq* 'effect e*) e))) + (make-nontail ctxt e) + (make-1seq ctxt (make-seq* 'ignored e*) (make-nontail ctxt e)))) (loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))] [else #f]) (nanopass-case (Lsrc Expr) (result-exp/indirect-ref e) diff --git a/s/cpletrec.ss b/s/cpletrec.ss index f5b2fb00c0..3dc856d276 100644 --- a/s/cpletrec.ss +++ b/s/cpletrec.ss @@ -135,8 +135,15 @@ Handling letrec and letrec* (values (cons e e*) (and e-pure? e*-pure?))))) (with-output-language (Lsrc Expr) (define build-seq - (lambda (e* body) - (fold-right (lambda (e body) `(seq ,e ,body)) body e*))) + (lambda (pure? e* body) + ;; Unless `pure?`, wrap `$value` around forms added to a `begin`, so that + ;; there's a check to make sure they result is a single value. The wrapper + ;; can be removed by other compiler passes if the argument obviously produces + ;; a single value. + (fold-right (lambda (e body) + (let ([e (if pure? e `(call ,(make-preinfo) ,(lookup-primref 3 '$value) ,e))]) + `(seq ,e ,body))) + body e*))) (define build-let (lambda (call-preinfo lambda-preinfo lhs* rhs* body) (if (null? lhs*) @@ -306,7 +313,7 @@ Handling letrec and letrec* (values (if e-pure? pre* (cons e pre*)) lhs* rhs* (and e-pure? pure?)))))))]) (values - (build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body)) + (build-seq pure? pre* (build-let preinfo0 preinfo1 lhs* rhs* body)) (and body-pure? pure?))))))] [(call ,preinfo ,pr ,e* ...) (let () diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 6c8172a808..67b4280061 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -2770,6 +2770,44 @@ [(k ?sym) (with-implicit (k quasiquote) #'`(literal ,(make-info-literal #t 'object ?sym (constant symbol-value-disp))))]))) + (define single-valued? + (case-lambda + [(e) (single-valued? e 5)] + [(e fuel) + (and (not (zero? fuel)) + (nanopass-case (L7 Expr) e + [,x #t] + [(immediate ,imm) #t] + [(literal ,info) #t] + [(label-ref ,l ,offset) #t] + [(mref ,e1 ,e2 ,imm) #t] + [(quote ,d) #t] + [,pr #t] + [(call ,info ,mdcl ,pr ,e* ...) + (all-set? (prim-mask single-valued) (primref-flags pr))] + [(foreign-call ,info ,e, e* ...) #t] + [(alloc ,info ,e) #t] + [(set! ,lvalue ,e) #t] + [(profile ,src) #t] + [(pariah) #t] + [(let ([,x* ,e*] ...) ,body) + (single-valued? body (fx- fuel 1))] + [(if ,e0 ,e1 ,e2) + (and (single-valued? e1 (fx- fuel 1)) + (single-valued? e2 (fx- fuel 1)))] + [(seq ,e0 ,e1) + (single-valued? e1 (fx- fuel 1))] + [else #f]))])) + (define ensure-single-valued + (case-lambda + [(e unsafe-omit?) + (if (or unsafe-omit? + (single-valued? e)) + e + (with-output-language (L7 Expr) + (let ([t (make-tmp 'v)]) + `(values ,(make-info-call #f #f #f #f #f) ,e))))] + [(e) (ensure-single-valued e (fx= (optimize-level) 3))])) (define-pass np-expand-primitives : L7 (ir) -> L9 () (Program : Program (ir) -> Program () [(labels ([,l* ,le*] ...) ,l) @@ -3946,8 +3984,10 @@ [else #f]))] [else #f]))) (define-inline 2 values - [(e) e] + [(e) (ensure-single-valued e)] [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)]) + (define-inline 2 $value + [(e) (ensure-single-valued e #f)]) (define-inline 2 eq? [(e1 e2) (%inline eq? ,e1 ,e2)]) (define-inline 2 $keep-live @@ -4020,7 +4060,7 @@ reduce-equality reduce-inequality)) (define-inline 3 op - [(e) `(seq ,e ,(%constant strue))] + [(e) `(seq ,(ensure-single-valued e) ,(%constant strue))] [(e1 e2) (go e1 e2)] [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) (define-inline 3 r6rs:op @@ -4037,7 +4077,7 @@ [(_ op inline-op base) (define-inline 3 op [() `(immediate ,(fix base))] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (%inline inline-op ,e1 ,e2)] [(e1 . e*) (reduce src sexpr moi e1 e*)])])) (fxlogop fxlogand logand -1) @@ -4135,7 +4175,7 @@ (%inline u< ,e1 ,e2))]) (define-inline 3 fx+ [() `(immediate 0)] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (%inline + ,e1 ,e2)] [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 r6rs:fx+ ; limited to two arguments @@ -4315,7 +4355,7 @@ (%inline * ,e1 ,t))))])])) (define-inline 3 fx* [() `(immediate ,(fix 1))] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (build-fx* e1 e2 #f)] [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 r6rs:fx* ; limited to two arguments @@ -4733,7 +4773,7 @@ ; [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 fxmin - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (bind #t (e1 e2) `(if ,(%inline < ,e1 ,e2) ,e1 @@ -4741,7 +4781,7 @@ [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 fxmax - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (bind #t (e1 e2) `(if ,(%inline < ,e2 ,e1) ,e1 @@ -5019,10 +5059,10 @@ ,(%inline + ,t (immediate ,next-i))) ,(loop e2 e* next-i))))))))))) (define-inline 2 list* - [(e) e] + [(e) (ensure-single-valued e)] [(e . e*) (go e e*)]) (define-inline 2 cons* - [(e) e] + [(e) (ensure-single-valued e)] [(e . e*) (go e e*)])) (define-inline 2 vector [() `(quote #())] @@ -6813,13 +6853,13 @@ ;; allocated across nested fl+, fl*, fl-, fl/ etc. operation (define-inline 3 fl+ [() `(quote 0.0)] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (bind #f (e1 e2) (build-flop-2 %fl+ e1 e2))] [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 fl* [() `(quote 1.0)] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (bind #f (e1 e2) (build-flop-2 %fl* e1 e2))] [(e1 . e*) (reduce src sexpr moi e1 e*)]) @@ -6882,7 +6922,7 @@ (define-inline 3 cfl+ [() `(quote 0.0)] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (build-libcall #f src sexpr cfl+ e1 e2)] ; TODO: add 3 argument version of cfl+ library function #;[(e1 e2 e3) (build-libcall #f src sexpr cfl+ e1 e2 e3)] @@ -6890,7 +6930,7 @@ (define-inline 3 cfl* [() `(quote 1.0)] - [(e) e] + [(e) (ensure-single-valued e)] [(e1 e2) (build-libcall #f src sexpr cfl* e1 e2)] ; TODO: add 3 argument version of cfl* library function #;[(e1 e2 e3) (build-libcall #f src sexpr cfl* e1 e2 e3)] diff --git a/s/patch.ss b/s/patch.ss index 24b7e5bad0..c3ad5fb24c 100644 --- a/s/patch.ss +++ b/s/patch.ss @@ -13,7 +13,7 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. -(define (generate-vfasl) #f) +(define ($value x) x) (printf "loading ~s cross compiler~%" (constant machine-type-name)) diff --git a/s/primdata.ss b/s/primdata.ss index d541483345..422fc829dc 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -61,9 +61,9 @@ (fxdiv0-and-mod0 [sig [(fixnum fixnum) -> (fixnum fixnum)]] [flags discard]) (fxdiv0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxmod0 [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02]) - (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02]) - (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags arith-op cp02]) + (fx+/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02]) + (fx-/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02]) + (fx*/carry [sig [(fixnum fixnum fixnum) -> (fixnum fixnum)]] [flags cp02]) (fxnot [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxand [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxior [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) @@ -240,7 +240,7 @@ (acos [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (atan [sig [(number) (number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) - (exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags arith-op mifoldable discard]) + (exact-integer-sqrt [sig [(integer) -> (integer integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled (expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold (make-rectangular [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) (make-polar [sig [(number number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs]) @@ -530,7 +530,7 @@ (hashtable-copy [sig [(hashtable) (hashtable ptr) -> (hashtable)]] [flags alloc]) (hashtable-clear! [sig [(hashtable) (hashtable sub-uint) -> (void)]] [flags true]) (hashtable-keys [sig [(hashtable) -> (vector)]] [flags alloc]) - (hashtable-entries [sig [(hashtable) -> (vector vector)]] [flags alloc]) + (hashtable-entries [sig [(hashtable) -> (vector vector)]] [flags discard]) (hashtable-equivalence-function [sig [(hashtable) -> (ptr)]] [flags]) (hashtable-hash-function [sig [(hashtable) -> (ptr)]] [flags]) (hashtable-mutable? [sig [(hashtable) -> (boolean)]] [flags mifoldable discard]) @@ -613,7 +613,7 @@ (open-file-output-port [sig [(pathname) (pathname file-options) (pathname file-options sub-symbol) (pathname file-options sub-symbol maybe-transcoder) -> (output-port)]] [flags true]) (open-bytevector-output-port [sig [() (maybe-transcoder) -> (output-port procedure)]] [flags discard]) (call-with-bytevector-output-port [sig [(procedure) (procedure maybe-transcoder) -> (bytevector)]] [flags]) - (open-string-output-port [sig [() -> (textual-output-port procedure)]] [flags alloc]) + (open-string-output-port [sig [() -> (textual-output-port procedure)]] [flags discard]) (call-with-string-output-port [sig [(procedure) -> (string)]] [flags]) ((r6rs: standard-output-port) [sig [() -> (binary-output-port)]] [flags true]) ((r6rs: standard-error-port) [sig [() -> (binary-output-port)]] [flags true]) @@ -901,7 +901,7 @@ (most-positive-fixnum [sig [() -> (ufixnum)]] [flags pure unrestricted true cp02]) (petite? [sig [() -> (boolean)]] [flags pure unrestricted]) (scheme-version [sig [() -> (string)]] [flags pure unrestricted true]) - (scheme-version-number [sig [() -> (uint uint uint)]] [flags pure unrestricted true]) + (scheme-version-number [sig [() -> (uint uint uint)]] [flags discard unrestricted]) (threaded? [sig [() -> (boolean)]] [flags pure unrestricted cp02]) ) @@ -1692,7 +1692,7 @@ (top-level-mutable? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-syntax [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard]) (top-level-syntax? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) - (top-level-value [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard single-valued]) + (top-level-value [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard]) (transcoder? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (transcript-cafe [sig [(pathname) -> (ptr ...)]] [flags]) (transcript-off [sig [() -> (void)]] [flags true ieee r5rs]) @@ -2067,7 +2067,7 @@ ($lexical-error [flags]) ($library-requirements-options [flags]) ($library-search [flags]) - ($list-length [flags]) + ($list-length [flags single-valued]) ($load-library [flags]) ($locate-source [flags]) ($logand [flags]) @@ -2241,7 +2241,7 @@ ($system-library? [flags]) ($system-procedure? [flags]) ($system-property-list [flags]) - ($tc-field [flags]) + ($tc-field [flags single-valued]) ($tc [flags]) ($thread-list [flags]) ($thread-tc [flags]) @@ -2270,6 +2270,7 @@ ($undefined-violation [flags abort-op]) ($untrace [flags]) ($unwrap-ftype-pointer [flags]) + ($value [flags unrestricted discard single-valued cp02]) ($vector-ref-check? [flags]) ($vector-set!-check? [flags]) ($vector-set-immutable! #;[sig [(vector) -> (ptr)]] [flags true]) diff --git a/s/priminfo.ss b/s/priminfo.ss index 4f54e66feb..628536927e 100644 --- a/s/priminfo.ss +++ b/s/priminfo.ss @@ -13,7 +13,8 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. -(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-signatures priminfo-arity primvec get-priminfo priminfo-boolean?) +(module priminfo (priminfo-unprefixed priminfo-libraries priminfo-mask priminfo-signatures priminfo-arity primvec + get-priminfo priminfo-boolean? priminfo-result-arity) (define-record-type priminfo (nongenerative) (sealed #t) @@ -37,7 +38,22 @@ (andmap (lambda (sig) (let ([out (cdr sig)]) (and (pair? out) (eq? (car out) 'boolean) (null? (cdr out))))) - signature*))))) + signature*))))) + + (define priminfo-result-arity + (lambda (info) + (let ([signature* (priminfo-signatures info)]) + (cond + [(null? signature*) 'unknown] + [(andmap (lambda (sig) + (let ([out (cdr sig)]) + (and (pair? out) (null? (cdr out))))) + signature*) + ;; Note that a `(bottom)` result is treated as single-valued, + ;; which is ok in the sense that the aborting operation will + ;; produce a single value when it (never) returns. + 'single] + [else 'multiple])))) (define signature->interface (lambda (sig) diff --git a/s/prims.ss b/s/prims.ss index 3374d304ca..92768c9eff 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -339,6 +339,12 @@ (define values ($hand-coded 'values-procedure)) +;; When applied, ensures the argument expression produces a single +;; value. Unlike other primitives, an immediate application of +;; `$value` won't be optimized away with optimization level 3 unless +;; the argument expression definitely produces a single value. +(define $value (lambda (x) x)) + (define call-with-values (lambda (producer consumer) (unless (procedure? producer) diff --git a/s/primvars.ss b/s/primvars.ss index 3a5b6748aa..abff2037a6 100644 --- a/s/primvars.ss +++ b/s/primvars.ss @@ -18,10 +18,13 @@ (include "primref.ss") (define record-prim! - (lambda (prim unprefixed flags arity boolean-valued?) + (lambda (prim unprefixed flags arity boolean-valued? result-arity) (unless (eq? unprefixed prim) ($sputprop prim '*unprefixed* unprefixed)) - (let ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)] - [arity (and (not (null? arity)) arity)]) + (let* ([flags (if boolean-valued? (fxlogor flags (prim-mask boolean-valued)) flags)] + [flags (if (eq? 'single result-arity) (fxlogor flags (prim-mask single-valued)) flags)] + [arity (and (not (null? arity)) arity)]) + (when (and (eq? result-arity 'multiple) (any-set? (prim-mask single-valued) flags)) + ($oops 'prims "inconsistent single-value information for ~s" prim)) ($sputprop prim '*flags* flags) (when (any-set? (prim-mask (or primitive system)) flags) ($sputprop prim '*prim2* (make-primref prim flags arity)) @@ -38,7 +41,8 @@ '#,(datum->syntax #'* (vector-map priminfo-unprefixed v-info)) '#,(datum->syntax #'* (vector-map priminfo-mask v-info)) '#,(datum->syntax #'* (vector-map priminfo-arity v-info)) - '#,(datum->syntax #'* (vector-map priminfo-boolean? v-info))))))) + '#,(datum->syntax #'* (vector-map priminfo-boolean? v-info)) + '#,(datum->syntax #'* (vector-map priminfo-result-arity v-info))))))) (for-each (lambda (x) (for-each (lambda (key) ($sremprop x key)) '(*prim2* *prim3* *flags* *unprefixed*))) (oblist)) setup)