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

Merge branch 'sv' of github.com:mflatt/ChezScheme

Browse Source 
original commit: 9dd62e2d4a44879ddb210bb6ebe7ad600b832634
This commit is contained in:
Matthew Flatt 2019-01-10 19:26:37 -07:00
commit ea29ba02f7
4 changed files with 92 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
LOG
View File

@ -1055,3 +1055,10 @@
inspect.ss, bitset.ss, cmacros.ss, prims.ss, primdata.ss, Mf-base,
prim.c, types.h, misc.ms, thread.ms, debug.stex, threads.stex,
release_notes.stex
- 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
- use the "single-valued" flag on primitives to simplify certain
call-with-values patterns
cp0.ss, cp0.ms

34
mats/cp0.ms
View File

@ -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

4
s/cmacros.ss
View File

@ -1614,8 +1614,8 @@
(simple #b0000100000)
(boolean-valued-known #b0001000000)
(boolean-valued #b0010000000)
(single-valued-nontail-known #b0100000000)
(single-valued-nontail #b1000000000)
(single-valued-known #b0100000000)
(single-valued #b1000000000)
)
(define-syntax define-flag-field

62
s/cp0.ss
View File

@ -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]
@ -1219,17 +1246,26 @@
(define-who single-valued?
(lambda (e)
(with-memoize (single-valued-nontail-known single-valued-nontail) 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])]
(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)))]