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

Chez Scheme: make inlining see through make-wrapper-procedure

Browse Source 
For example,

 (let ([f (make-wrapper-procedure (lambda (x) x) 2 'metadata)])
   (f 5))

optimizes to just 5.
This commit is contained in:
Matthew Flatt 2020-12-08 10:28:19 -07:00
parent cbd7a2b2af
commit 535fa16813
2 changed files with 98 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
racket/src/ChezScheme/mats/cp0.ms
View File

@ -3141,3 +3141,65 @@
'(#t #f)))
)
(mat make-wrapper-procedure
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '((make-wrapper-procedure (lambda (x) x) 2 'ok) 5)))
5)
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 2 'ok) 5)))
5)
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '((make-wrapper-procedure (lambda (x) x) 2 (g)) 5)))
(if (= 3 (optimize-level))
'(begin (g) 5)
'(begin (#3%$value (g)) 5)))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 2 (g)) 5)))
(if (= 3 (optimize-level))
'(begin (g) 5)
'(begin (#3%$value (g)) 5)))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([f (make-wrapper-procedure (lambda (x) x) 2 (g))]) (f 5))))
(if (= 3 (optimize-level))
'(begin (g) 5)
'(begin (#3%$value (g)) 5)))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([f (make-arity-wrapper-procedure (lambda (x) x) 2 (g))]) (f 5))))
(if (= 3 (optimize-level))
'(begin (g) 5)
'(begin (#3%$value (g)) 5)))
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([g (let ([f (make-wrapper-procedure (lambda (x) x) 2 (g))]) f)]) (g 5))))
(if (= 3 (optimize-level))
'(begin (g) 5)
'(begin (#3%$value (g)) 5)))
(not
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([f (#2%make-wrapper-procedure (lambda (x) x) 2 (g))]) (#2%list (g f) (f 5)))))
'(#2%list (g (#2%make-wrapper-procedure (lambda (x) x) 2 (g))) 5)))
(not
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
(expand/optimize '(let ([f (#2%make-arity-wrapper-procedure (lambda (x) x) 2 (g))]) (#2%list (g f) (f 5)))))
'(#2%list (g (#2%make-arity-wrapper-procedure (lambda (x) x) 2 (g))) 5)))
(not
(equivalent-expansion?
(parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
;; arity mismatch:
(expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 1 'ok) 5)))
5))
)

36
racket/src/ChezScheme/s/cp0.ss
View File

@ -5117,6 +5117,42 @@
(preinfo-call-mask))
(preinfo-call-mask no-inline)))])
(cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))]
[(call ,preinfo ,pr ,e1 ,e2 ,e3)
;; remove wrapper for immediately applied
(guard (app? ctxt)
(or (eq? (primref-name pr) 'make-wrapper-procedure)
(eq? (primref-name pr) 'make-arity-wrapper-procedure))
(nanopass-case (Lsrc Expr) e2
[(quote ,d)
(and (exact? d) (integer? d)
(bitwise-bit-set? d (length (app-opnds ctxt))))]
[else #f]))
(let ([e1 (cp0 e1 ctxt env sc wd name moi)])
(if (app-used ctxt)
(make-1seq ctxt (make-seq* 'ignored (list e2 e3)) e1)
(let ([e2 (cp0 e2 'value env sc wd #f moi)]
[e3 (cp0 e2 'value env sc wd #f moi)])
`(call ,preinfo ,pr ,e1 ,e2 ,e3))))]
[(call ,preinfo ,pr ,e1 ,e2 ,e3)
;; discard unused, non-error wrapper construction
(guard (or (eq? (primref-name pr) 'make-wrapper-procedure)
(eq? (primref-name pr) 'make-arity-wrapper-procedure))
(unused-value-context? ctxt))
(let ([e1 (cp0 e1 'value env sc wd name moi)]
[e2 (cp0 e2 'value env sc wd #f moi)]
[e3 (cp0 e3 'value env sc wd #f moi)])
(cond
[(nanopass-case (Lsrc Expr) e2
[(quote ,d)
(and (exact? d) (integer? d)
(nanopass-case (Lsrc Expr) e1
[(case-lambda ,preinfo (clause (,x* ...) ,interface ,body) ...) #t]
[else #f]))]
[else #f])
;; can drop call
(make-1seq* 'ignored (list e1 e3))]
[else
`(call ,preinfo ,pr ,e1 ,e2 ,e3)]))]
[(call ,preinfo ,e ,e* ...)
(let ()
(define lift-let