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

Cleanup apply.rkt

Browse Source 
original commit: 41f2092953ea2999c72921ce435887a7636559f0
This commit is contained in:
Eric Dobson 2013-08-30 08:25:10 -07:00
parent 6787b131da
commit 75f8759f36
1 changed files with 17 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/apply.rkt
View File

@ -1,36 +1,34 @@
#lang racket/base
(require syntax/parse racket/syntax
(for-template racket/unsafe/ops racket/base (prefix-in k: '#%kernel))
(for-template racket/unsafe/ops racket/base (prefix-in k- '#%kernel))
"../utils/utils.rkt"
(utils tc-utils)
(optimizer utils logging))
(provide apply-opt-expr)
(define-literal-syntax-class +)
(define-literal-syntax-class *)
(define-literal-syntax-class k-apply)
(define-literal-syntax-class map)
(define-literal-syntax-class app^ (#%plain-app))
(define-syntax-class apply-op
#:commit
#:literals (+ *)
(pattern + #:with identity #'0)
(pattern * #:with identity #'1))
(pattern :+^ #:with identity #'0)
(pattern :*^ #:with identity #'1))
(define-syntax-class apply-opt-expr
#:commit
#:literals (k:apply map #%plain-app #%app)
(pattern ((~and kw #%plain-app) (~and appl k:apply) op:apply-op
((~and kw2 #%plain-app) (~and m map) f l))
#:with opt (with-syntax ([(f* lp v lst) (map generate-temporary '(f* loop v lst))]
[l ((optimize) #'l)]
[f ((optimize) #'f)])
(log-optimization "apply-map" "apply-map deforestation."
this-syntax)
(add-disappeared-use #'appl)
(add-disappeared-use #'kw2)
(add-disappeared-use #'m)
(pattern (kw:app^ appl:k-apply^ op:apply-op (kw2:app^ m:map^ f:opt-expr l:opt-expr))
#:do [(log-opt "apply-map" "apply-map deforestation.")]
#:with opt (with-syntax ([(f* lp v lst) (map generate-temporary '(f* loop v lst))])
(syntax/loc/origin
this-syntax #'kw
(let ([f* f])
(let lp ([v op.identity] [lst l])
(let ([f* f.opt])
(let loop ([v op.identity] [lst l.opt])
(if (null? lst)
v
(lp (op v (f* (unsafe-car lst)))
(unsafe-cdr lst)))))))))
(loop (op v (f* (unsafe-car lst)))
(unsafe-cdr lst)))))))))