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

Added box optimizations.

Browse Source 
original commit: d6ce6e664f0bd361207725fb3ea9b2a265f39374
This commit is contained in:
Vincent St-Amour 2010-07-19 16:52:30 -04:00
parent 245f1e311c
commit 19f4d78569
4 changed files with 49 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/tests/typed-scheme/optimizer/generic/box.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(: x (Boxof Integer))
(define x (box 1))
(unbox x)
(set-box! x 2)
(unbox x)

29
collects/typed-scheme/optimizer/box.rkt Normal file
View File

@ -0,0 +1,29 @@
#lang scheme/base
(require syntax/parse
unstable/match scheme/match
"../utils/utils.rkt"
(for-template scheme/base scheme/fixnum scheme/unsafe/ops)
(rep type-rep)
(types abbrev type-table utils subtype)
(optimizer utils))
(provide box-opt-expr)
(define-syntax-class box-expr
(pattern e:expr
#:when (match (type-of #'e)
[(tc-result1: (Box: _)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
(define-syntax-class box-op
;; we need the * versions of these unsafe operations to be chaperone-safe
(pattern (~literal unbox) #:with unsafe #'unsafe-unbox*)
(pattern (~literal set-box!) #:with unsafe #'unsafe-set-box*!))
(define-syntax-class box-opt-expr
(pattern (#%plain-app op:box-op b:box-expr new:expr ...)
#:with opt
(begin (log-optimization "box" #'op)
#`(op.unsafe b.opt #,@(map (optimize) (syntax->list #'(new ...)))))))

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

@ -5,7 +5,7 @@
(for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
"../utils/utils.rkt"
(types abbrev type-table utils subtype)
(optimizer utils fixnum float inexact-complex vector pair sequence struct dead-code))
(optimizer utils fixnum float inexact-complex vector pair sequence box struct dead-code))
(provide optimize-top)
@ -24,6 +24,7 @@
(pattern e:vector-opt-expr #:with opt #'e.opt)
(pattern e:pair-opt-expr #:with opt #'e.opt)
(pattern e:sequence-opt-expr #:with opt #'e.opt)
(pattern e:box-opt-expr #:with opt #'e.opt)
(pattern e:struct-opt-expr #:with opt #'e.opt)
(pattern e:dead-code-opt-expr #:with opt #'e.opt)

10
collects/typed-scheme/private/base-env.rkt
View File

@ -200,10 +200,18 @@
[newline (->opt [-Output-Port] -Void)]
[not (-> Univ B)]
[box (-poly (a) (a . -> . (-box a)))]
[unbox (-poly (a) (cl->*
[unbox (-poly (a) (cl->*
((-box a) . -> . a)
((make-BoxTop) . -> . Univ)))]
[set-box! (-poly (a) ((-box a) a . -> . -Void))]
[unsafe-unbox (-poly (a) (cl->*
((-box a) . -> . a)
((make-BoxTop) . -> . Univ)))]
[unsafe-set-box! (-poly (a) ((-box a) a . -> . -Void))]
[unsafe-unbox* (-poly (a) (cl->*
((-box a) . -> . a)
((make-BoxTop) . -> . Univ)))]
[unsafe-set-box*! (-poly (a) ((-box a) a . -> . -Void))]
[box? (make-pred-ty (make-BoxTop))]
[cons? (make-pred-ty (-pair Univ Univ))]
[pair? (make-pred-ty (-pair Univ Univ))]