From b78838a641a40feecd23e3913fd9c16ec6bb379f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Dec 2018 08:15:55 -0700 Subject: [PATCH 1/2] cp0: move only known-single-valued out of single-value context In safe compilation modes, avoid turning an error like (let ([x (values 1 2)]) x) or (car (list (values 1 2))) into a program that returns multiple values or (if (list (values 1 2)) 3 4) into a program that returns without an error. In addition, refrain from moving an expression from a non-tail position within a procedure to a tail position, unless the expression is not only single valued but also gauarnteed not to inspect the immediate continuation (e.g., using `call/cc` and comparing the result to a previously captured continuation). This constraint applies even in unsafe compilation modes, because the intent it to provide some guarantees about non-tail positions to complement existing guarantees of tail positions. original commit: 91e9631576e7b97137be856e985609320e327f32 --- LOG | 4 + mats/cp0.ms | 942 ++++++++++++++++++++++++------------------------ mats/record.ms | 4 +- s/cmacros.ss | 13 +- s/cp0.ss | 404 ++++++++++++++------- s/cpletrec.ss | 13 +- s/cpnanopass.ss | 66 +++- s/patch.ss | 5 +- s/primdata.ss | 23 +- s/priminfo.ss | 20 +- s/prims.ss | 6 + s/primvars.ss | 12 +- s/syntax.ss | 2 +- 13 files changed, 855 insertions(+), 659 deletions(-) diff --git a/LOG b/LOG index e5aae978a0..8c6a97728c 100644 --- a/LOG +++ b/LOG @@ -1027,3 +1027,7 @@ cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms - added initialization of seginfo sorted and trigger_ephemerons fields. segment.c +- adjust compiler, especially cp0, to avoid turning errors like `(let + ([x (values 1 2)]) x)` into programs that return multiple values + cp0.ss, cpletrec.ss, cpnanopass, prims.ss, primdata.ss, priminfo.ss, + primvars.ss, cmacros.ss, syntax.ss, cp0.ms, record.ms diff --git a/mats/cp0.ms b/mats/cp0.ms index e1755e7b57..be4a8f0d46 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) ($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) ($xxx)) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($yyy)) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($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) ($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) ($yyy)) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($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) ($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) ($yyy)) - '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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) ($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 '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) ($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) ($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 @@ -2828,3 +2720,103 @@ `(lambda (x) (= x x))) ; x could be +nan.0 `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x)))) ) + +(mat cp0-non-tail + ;; 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) (#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)))))) + #t) + (simplify-only-nontail? (lambda (e) `(let ([x ,e]) x))) + (simplify-only-nontail? (lambda (e) `(letrec ([x ,e]) x))) + (simplify-only-nontail? (lambda (e) `(values ,e))) + (simplify-only-nontail? (lambda (e) `(list* ,e))) + (simplify-only-nontail? (lambda (e) `(append ,e))) + (simplify-only-nontail? (lambda (e) `(append! ,e))) + (simplify-only-nontail? (lambda (e) `(car (list ,e)))) + (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) + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (equivalent-expansion? + (expand/optimize '(let ([g1 (begin (unknown) (void))]) 10)) + '(begin (unknown) 10))) +) 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/cmacros.ss b/s/cmacros.ss index bd188e982a..e0f0ca60ab 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -1562,18 +1562,19 @@ (ieee #b00000000000000000010000) (proc #b00000000000000000100000) (discard #b00000000000000001000000) - (unrestricted #b00000000000000010000000) - (true #b00000000000000100000000) - (mifoldable #b00000000000001000000000) + (single-valued #b00000000000000010000000) + (true (or #b00000000000000100000000 single-valued)) + (mifoldable (or #b00000000000001000000000 single-valued)) (cp02 #b00000000000010000000000) (cp03 #b00000000000100000000000) (system-keyword #b00000000001000000000000) (r6rs #b00000000010000000000000) - (pure (or #b00000000100000000000000 discard)) + (pure (or #b00000000100000000000000 discard single-valued)) (library-uid #b00000001000000000000000) - (boolean-valued #b00000010000000000000000) + (boolean-valued (or #b00000010000000000000000 single-valued)) (abort-op #b00000100000000000000000) (unsafe #b00001000000000000000000) + (unrestricted #b00010000000000000000000) (arith-op (or proc pure true)) (alloc (or proc discard true)) ; would be nice to check that these and only these actually have cp0 partial folders @@ -1589,6 +1590,8 @@ (simple #b0000100000) (boolean-valued-known #b0001000000) (boolean-valued #b0010000000) + (single-valued-known #b0100000000) + (single-valued #b1000000000) ) (define-syntax define-flag-field diff --git a/s/cp0.ss b/s/cp0.ss index fc599722b4..1c4e3d1b68 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,35 @@ (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) + ;; don't move e1 into a single-value + ;; position unless that's ok + (single-valued? e1)) + 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 +770,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 +790,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)] @@ -755,6 +800,15 @@ (bump sc 1) `(if ,e1 ,e2 ,e3)]))) + (define make-nontail + (lambda (ctxt e) + (if (context-case ctxt + [(tail) (single-valued-nontail? e)] + [(ignored) (single-valued? e)] + [else #t]) + e + (build-primcall 3 '$value (list e))))) + (define result-exp (lambda (e) (nanopass-case (Lsrc Expr) e @@ -879,7 +933,7 @@ ((ids->do-clause '()) clause) #t)))) - (module (pure? ivory? simple? simple/profile? boolean-valued?) + (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) @@ -927,7 +981,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)] @@ -935,7 +989,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] @@ -944,21 +998,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 @@ -982,10 +1041,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)] @@ -993,31 +1052,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 @@ -1035,33 +1099,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) @@ -1080,33 +1150,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 @@ -1140,7 +1215,52 @@ [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f] [(pariah) #f] - [else ($oops who "unrecognized record ~s" e)]))))) + [else ($oops who "unrecognized record ~s" e)])))) + + (define-who single-valued? + (lambda (e) + (with-memoize (single-valued-known single-valued) e + ; known to produce a single value + (nanopass-case (Lsrc Expr) e + [(quote ,d) #t] + [(call ,preinfo ,e ,e* ...) + (nanopass-case (Lsrc Expr) e + [,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? body))] + [else #f])] + [(ref ,maybe-src ,x) #t] + [(case-lambda ,preinfo ,cl* ...) #t] + [(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? 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] + [(record-set! ,rtd ,type ,index ,e1 ,e2) #t] + [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t] + [(record-type ,rtd ,e) #t] + [(record ,rtd ,rtd-expr ,e* ...) #t] + [(pariah) #t] + [(profile ,src) #t] + [(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)])))) + + (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) @@ -1274,7 +1394,7 @@ [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 @@ -1436,7 +1556,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 @@ -1451,7 +1571,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) @@ -1463,7 +1583,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)]) @@ -1609,7 +1729,7 @@ [else (residualize-ref maybe-src id sc)])] [,pr (context-case ctxt - [(value) + [(value tail) (if (all-set? (prim-mask (or primitive proc)) (primref-flags pr)) rhs (residualize-ref maybe-src id sc))] @@ -1625,11 +1745,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) @@ -1642,7 +1765,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)]))))) @@ -1691,7 +1814,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) @@ -2052,24 +2175,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 @@ -2117,11 +2227,18 @@ [args #f]) (define-inline 2 (cons* list* values append append!) - [(x) (let ((xval (value-visit-operand! x))) + [(x) (begin (residualize-seq (list x) '() ctxt) - xval)] + (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) @@ -3619,7 +3736,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)) @@ -3656,7 +3773,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) @@ -3705,8 +3822,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* @@ -3836,7 +3953,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) @@ -4173,19 +4290,19 @@ (and (not (null? e*)) (begin (residualize-seq '() (list ?x) 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 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)) - (car e*) + (lambda (e1 e2) (make-1seq (app-ctxt ctxt) e1 e2)) + (make-nontail (app-ctxt ctxt) (car e*)) (cdr e*)))] [else #f])]) @@ -4203,18 +4320,18 @@ (guard (eq? (primref-name pr) 'cons)) (residualize-seq (list ?x) '() ctxt) (non-result-exp (operand-value ?x) - (make-seq (app-ctxt ctxt) e1 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])]) @@ -4228,12 +4345,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 - e))))))) + (make-nontail (app-ctxt ctxt) e)))))))) (define tryref (lambda (ctxt ?x ?i seqprim maybe-pred) @@ -4419,7 +4536,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) @@ -4486,7 +4603,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)] @@ -4500,7 +4617,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 @@ -4545,7 +4668,7 @@ (let ([x ($symbol-name name)]) (if (pair? x) (cdr x) x)))) (context-case ctxt - [(value) + [(value tail) (bump sc 1) `(case-lambda ,preinfo ,(let f ([cl* cl*] [mask 0]) @@ -4558,10 +4681,10 @@ (f (cdr cl*) new-mask) (cons (with-extended-env ((env x*) (env x* #f)) - `(clause (,x* ...) ,interface ,(cp0 body 'value env sc wd #f name))) + `(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) @@ -4591,11 +4714,13 @@ (make-if ctxt sc e1 true-rec (do-e3))])) - (if (eq? (app-ctxt ctxt) 'value) - (let ([e1 (value-visit-operand! (car (app-opnds ctxt)))]) - (and (boolean-valued? e1) (finish e1))) - (and (eq? (app-ctxt ctxt) 'test) - (finish (test-visit-operand! (car (app-opnds ctxt)))))))] + (let ([r-ctxt (app-ctxt ctxt)]) + (if (or (eq? r-ctxt 'value) + (eq? r-ctxt 'tail)) + (let ([e1 (visit-operand! (car (app-opnds ctxt)) r-ctxt)]) + (and (boolean-valued? e1) (finish e1))) + (and (eq? (app-ctxt ctxt) 'test) + (finish (test-visit-operand! (car (app-opnds ctxt))))))))] [else #f])) (cp0-let preinfo ids body ctxt env sc wd name moi))] [() (cp0 ir 'value env sc wd name moi)]))])] @@ -4604,8 +4729,8 @@ [(letrec* ([,x* ,e*] ...) ,body) (cp0-rec-let #t x* e* body ctxt env sc wd name moi)] [,pr (context-case ctxt - [(value) (bump sc 1) pr] - [(effect) void-rec] + [(value tail) (bump sc 1) pr] + [(effect ignored) void-rec] [(test) (if (all-set? (prim-mask proc) (primref-flags pr)) true-rec @@ -4613,16 +4738,17 @@ [(app) (fold-primref pr ctxt sc wd name moi)])] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (context-case ctxt - [(value 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)])] + [(value tail app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] + [(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 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)])] + [(value tail app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] + [(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 app) + [(value tail app) (let ([rtd-expr (cp0 rtd-expr 'value env sc wd #f moi)] [e* (map (lambda (e) (cp0 e 'value env sc wd #f moi)) e*)]) (or (nanopass-case (Lsrc Expr) (result-exp rtd-expr) @@ -4634,26 +4760,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) @@ -4666,8 +4792,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) @@ -4728,7 +4854,7 @@ (fluid-let ([likely-to-be-compiled? ltbc?] [opending-list '()] [cp0-info-hashtable (make-weak-eq-hashtable)]) - (cp0 x 'value empty-env (new-scorer) (new-watchdog) #f #f))])))) + (cp0 x 'tail empty-env (new-scorer) (new-watchdog) #f #f))])))) ; check to make sure all required handlers were seen, after expansion of the ; expression above has been completed 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 310054441b..45b5c68110 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -2673,6 +2673,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) @@ -3805,8 +3843,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 @@ -3879,7 +3919,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 @@ -3896,7 +3936,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) @@ -3994,7 +4034,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 @@ -4174,7 +4214,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 @@ -4592,7 +4632,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 @@ -4600,7 +4640,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 @@ -4867,10 +4907,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 #())] @@ -6524,13 +6564,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*)]) @@ -6593,7 +6633,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)] @@ -6601,7 +6641,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 5193d9ce7a..c3ad5fb24c 100644 --- a/s/patch.ss +++ b/s/patch.ss @@ -13,10 +13,7 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. -(define generate-procedure-source-information - (case-lambda - [() #f] - [(v) (void)])) +(define ($value x) x) (printf "loading ~s cross compiler~%" (constant machine-type-name)) diff --git a/s/primdata.ss b/s/primdata.ss index 244c957bd3..8c8b096d62 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]) @@ -900,7 +900,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]) ) @@ -2041,7 +2041,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]) @@ -2210,7 +2210,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]) @@ -2218,8 +2218,8 @@ ($tlc-ht [flags mifoldable discard]) ($tlc-keyval [flags pure mifoldable discard]) ($tlc-next [flags mifoldable discard]) - ($top-level-bound? [flags discard]) - ($top-level-value [flags discard cp02]) + ($top-level-bound? [flags discard single-valued]) + ($top-level-value [flags discard cp02 single-valued]) ($trace-closure [flags pure alloc]) ($trace [flags]) ($track-dynamic-closure-counts [flags]) ; added for closure instrumentation @@ -2239,6 +2239,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 a56fde1174..25666b1881 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -340,6 +340,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) diff --git a/s/syntax.ss b/s/syntax.ss index 239bb23d67..fb8cb2c855 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -8757,7 +8757,7 @@ ;; but tell `$foreign-procedure` that the result is actually an & form #`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))] [else - #`(values #,(datum->syntax #'foreign-procedure result-type))])])] + #`(begin #,(datum->syntax #'foreign-procedure result-type))])])] [([extra ...] [extra-arg ...] [extra-check ...]) ;; When the result type is `(& )`, the `$foreign-procedure` result ;; expects an extra argument as a `(* )` that it uses to store the From 6afcc310ddd1ce035aa59e8a2a9763c4765e3bd1 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Thu, 10 Jan 2019 19:23:36 -0700 Subject: [PATCH 2/2] use "single-valued" to simplify some `call-with-values` patterns original commit: 0b9d2f0d778789ee9fda8a7249c8d7da329c9bcd --- LOG | 3 +++ mats/cp0.ms | 34 ++++++++++++++++++++++++++++++ s/cp0.ss | 60 ++++++++++++++++++++++++++++++++++++++++++----------- 3 files changed, 85 insertions(+), 12 deletions(-) diff --git a/LOG b/LOG index 8c6a97728c..6df7aa457a 100644 --- a/LOG +++ b/LOG @@ -1031,3 +1031,6 @@ ([x (values 1 2)]) x)` into programs that return multiple values cp0.ss, cpletrec.ss, cpnanopass, prims.ss, primdata.ss, priminfo.ss, primvars.ss, cmacros.ss, syntax.ss, cp0.ms, record.ms +- use the "single-valued" flag on primitives to simplify certain + call-with-values patterns + cp0.ss, cp0.ms diff --git a/mats/cp0.ms b/mats/cp0.ms index be4a8f0d46..61ea35c257 100644 --- a/mats/cp0.ms +++ b/mats/cp0.ms @@ -636,6 +636,40 @@ (tester)))) (test2 10)) 11) + (test-cp0-expansion + '(lambda (x) + (call-with-values (lambda () (unbox x)) display)) + (if (eqv? (optimize-level) 3) + '(lambda (x) (#3%display (#3%unbox x))) + '(lambda (x) (#2%display (#2%unbox x))))) + (test-cp0-expansion + '(lambda (x) + (call-with-values (lambda () (if x 1 2)) display)) + (if (eqv? (optimize-level) 3) + '(lambda (x) (#3%display (if x 1 2))) + '(lambda (x) (#2%display (if x 1 2))))) + ; verify optimization of begin0 pattern + (test-cp0-expansion + '(lambda (x) + (call-with-values (lambda () + (call-with-values (lambda () (unbox x)) + (case-lambda + [(x) (values x #f)] + [args (values args #t)]))) + (lambda (l apply?) + (newline) + (if apply? + (apply values l) + l)))) + (if (eqv? (optimize-level) 3) + '(lambda (x) + (let ([temp (#3%unbox x)]) + (#3%newline) + temp)) + '(lambda (x) + (let ([temp (#2%unbox x)]) + (#2%newline) + temp)))) ) (cp0-mat apply-partial-folding diff --git a/s/cp0.ss b/s/cp0.ss index 1c4e3d1b68..a50b703cec 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -1182,18 +1182,45 @@ (and (simple/profile? e) (or (fx= (optimize-level) 3) (single-valued? e))))) + (define (extract-called-procedure pr e*) + (case (primref-name pr) + [(call-with-values) + (and (fx= (length e*) 2) + (cadr e*))] + [(r6rs:dynamic-wind) + (and (fx= (length e*) 3) + (cadr e*))] + [(dynamic-wind) + (cond + [(fx= (length e*) 3) (cadr e*)] + [(fx= (length e*) 4) (caddr e*)] + [else #f])] + [(apply $apply) + (and (fx>= (length e*) 1) + (car e*))] + [else #f])) + (define-who boolean-valued? (lambda (e) (with-memoize (boolean-valued-known boolean-valued) e ; 2015/02/11 sorted by frequency (nanopass-case (Lsrc Expr) e [(call ,preinfo ,e ,e* ...) - (nanopass-case (Lsrc Expr) (result-exp e) - [,pr (all-set? (prim-mask boolean-valued) (primref-flags pr))] - [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) - (guard (fx= interface (length e*))) - (memoize (boolean-valued? body))] - [else #f])] + (let procedure-boolean-valued? ([e e] [e* e*]) + (nanopass-case (Lsrc Expr) (result-exp e) + [,pr + (or (all-set? (prim-mask boolean-valued) (primref-flags pr)) + (and e* + (let ([proc-e (extract-called-procedure pr e*)]) + (and proc-e + (memoize (procedure-boolean-valued? proc-e #f))))))] + [(case-lambda ,preinfo ,cl* ...) + (memoize (andmap (lambda (cl) + (nanopass-case (Lsrc CaseLambdaClause) cl + [(clause (,x* ...) ,interface ,body) + (boolean-valued? body)])) + cl*))] + [else #f]))] [(if ,e0 ,e1 ,e2) (memoize (and (boolean-valued? e1) (boolean-valued? e2)))] [(record-ref ,rtd ,type ,index ,e) (eq? type 'boolean)] [(ref ,maybe-src ,x) #f] @@ -1224,12 +1251,21 @@ (nanopass-case (Lsrc Expr) e [(quote ,d) #t] [(call ,preinfo ,e ,e* ...) - (nanopass-case (Lsrc Expr) e - [,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? body))] - [else #f])] + (let procedure-single-valued? ([e e] [e* e*]) + (nanopass-case (Lsrc Expr) (result-exp e) + [,pr + (or (all-set? (prim-mask single-valued) (primref-flags pr)) + (and e* + (let ([proc-e (extract-called-procedure pr e*)]) + (and proc-e + (memoize (procedure-single-valued? proc-e #f))))))] + [(case-lambda ,preinfo ,cl* ...) + (memoize (andmap (lambda (cl) + (nanopass-case (Lsrc CaseLambdaClause) cl + [(clause (,x* ...) ,interface ,body) + (single-valued? body)])) + cl*))] + [else #f]))] [(ref ,maybe-src ,x) #t] [(case-lambda ,preinfo ,cl* ...) #t] [(if ,e1 ,e2 ,e3) (memoize (and (single-valued? e2) (single-valued? e3)))]