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

Optimize (apply + (map f l)) to avoid the intermediate list.

Browse Source 
original commit: 5bb730f72c91f52166009d1e5fbe52a346c91edf
This commit is contained in:
Sam Tobin-Hochstadt 2010-07-23 14:10:17 -04:00
parent 9bef097987
commit 69476bba24
4 changed files with 48 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/optimizer/generic/apply-plus.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/racket #:optimize
(require racket/unsafe/ops)
(apply + (map add1 (list 1 2 3)))
(apply * (map add1 (list 1 2 3)))

32
collects/typed-scheme/optimizer/apply.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang scheme/base
(require syntax/parse
syntax/id-table racket/dict
unstable/match scheme/match
(for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel))
(for-syntax racket/base)
"../utils/utils.rkt"
(rep type-rep)
(types abbrev type-table utils subtype)
(optimizer utils))
(provide apply-opt-expr)
(define-syntax-class apply-op
#:literals (+ *)
(pattern + #:with identity #'0)
(pattern * #:with identity #'1))
(define-syntax-class apply-opt-expr
#:literals (k:apply map #%plain-app #%app)
(pattern (#%plain-app k:apply op:apply-op (#%plain-app map f l))
#:with opt
(begin (reset-unboxed-gensym)
(with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))]
[l ((optimize) #'l)]
[f ((optimize) #'f)])
(log-optimization "apply-map" #'op)
#'(let ([f* f])
(let lp ([v op.identity] [lst l])
(if (null? lst)
v
(lp (op v (f* (unsafe-car lst))) (unsafe-cdr lst)))))))))

22
collects/typed-scheme/optimizer/optimizer.rkt
View File

@ -8,7 +8,7 @@
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
(optimizer utils number fixnum float inexact-complex vector string
pair sequence box struct dead-code))
pair sequence box struct dead-code apply))
(provide optimize-top)
@ -21,6 +21,7 @@
#:literal-sets (kernel-literals)
;; interesting cases, where something is optimized
(pattern e:apply-opt-expr #:with opt #'e.opt)
(pattern e:number-opt-expr #:with opt #'e.opt)
(pattern e:fixnum-opt-expr #:with opt #'e.opt)
(pattern e:float-opt-expr #:with opt #'e.opt)
@ -47,9 +48,10 @@
(pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...)
#:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
(pattern (kw:identifier expr ...)
#:when (ormap (lambda (k) (free-identifier=? k #'kw))
(list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark))
#:when
(for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
#'#%variable-reference #'with-continuation-mark)])
(free-identifier=? k #'kw))
;; we don't want to optimize in the cases that don't match the #:when clause
#:with (expr*:opt-expr ...) #'(expr ...)
#:with opt #'(kw expr*.opt ...))
@ -64,12 +66,8 @@
(current-output-port))))
(begin0
(parameterize ([current-output-port port]
[optimize (lambda (stx)
(syntax-parse stx #:literal-sets (kernel-literals)
[e:opt-expr
(syntax/loc stx e.opt)]))])
[optimize (syntax-parser [e:opt-expr #'e.opt])])
((optimize) stx))
(if (and *log-optimizations?*
*log-optimizatons-to-log-file?*)
(close-output-port port)
#t))))
(when (and *log-optimizations?*
*log-optimizatons-to-log-file?*)
(close-output-port port)))))

4
collects/typed-scheme/optimizer/utils.rkt
View File

@ -52,9 +52,9 @@
;; necessary to have predictable symbols to add in the hand-optimized versions
;; of the optimizer tests (which check for equality of expanded code)
(define *unboxed-gensym-counter* 0)
(define (unboxed-gensym)
(define (unboxed-gensym [name 'unboxed-gensym-])
(set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*))
(format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*))
(format-unique-id #'here "~a~a" name *unboxed-gensym-counter*))
(define (reset-unboxed-gensym)
(set! *unboxed-gensym-counter* 0))