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

Added mutable pair optimizations.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-07-14 19:13:34 -04:00
parent f21454e711
commit fc29e7e856
8 changed files with 83 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/scheme #:optimize
(: f ((MListof Integer) -> Integer))
(define (f x)
(mcar x))

14
collects/tests/typed-scheme/optimizer/generic/mpair.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(: x (MPairof Integer Float))
(define x (mcons 1 1.0))
(mcar x)
(mcdr x)
(set-mcar! x (+ 1 2))
(set-mcdr! x (+ 1.0 2.0))
(: f ((MListof Integer) -> Integer))
(define (f x)
(if (null? x)
0
(mcar x)))

4
collects/tests/typed-scheme/optimizer/hand-optimized/invalid-mpair.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/scheme
(: f ((MListof Integer) -> Integer))
(define f
(#%plain-lambda (x) (mcar x)))

14
collects/tests/typed-scheme/optimizer/hand-optimized/mpair.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang typed/scheme #:optimize
(require racket/unsafe/ops)
(: x (MPairof Integer Float))
(define x (mcons 1 1.0))
(unsafe-mcar x)
(unsafe-mcdr x)
(unsafe-set-mcar! x (+ 1 2))
(unsafe-set-mcdr! x (+ 1.0 2.0))
(: f ((MListof Integer) -> Integer))
(define (f x)
(if (null? x)
0
(unsafe-mcar x)))

4
collects/tests/typed-scheme/optimizer/non-optimized/invalid-mpair.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang typed/scheme
(: f ((MListof Integer) -> Integer))
(define (f x)
(mcar x))

14
collects/tests/typed-scheme/optimizer/non-optimized/mpair.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang typed/scheme
(require racket/unsafe/ops)
(: x (MPairof Integer Float))
(define x (mcons 1 1.0))
(mcar x)
(mcdr x)
(set-mcar! x (+ 1 2))
(set-mcdr! x (+ 1.0 2.0))
(: f ((MListof Integer) -> Integer))
(define (f x)
(if (null? x)
0
(mcar x)))

18
collects/typed-scheme/optimizer/pair.rkt
View File

@ -15,6 +15,12 @@
(define-syntax-class pair-unary-op
(pattern (~literal car) #:with unsafe #'unsafe-car)
(pattern (~literal cdr) #:with unsafe #'unsafe-cdr))
(define-syntax-class mpair-op
(pattern (~literal mcar) #:with unsafe #'unsafe-mcar)
(pattern (~literal mcdr) #:with unsafe #'unsafe-mcdr)
(pattern (~literal set-mcar!) #:with unsafe #'unsafe-set-mcar!)
(pattern (~literal set-mcdr!) #:with unsafe #'unsafe-set-mcdr!))
(define-syntax-class pair-expr
(pattern e:expr
@ -22,9 +28,19 @@
[(tc-result1: (Pair: _ _)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
(define-syntax-class mpair-expr
(pattern e:expr
#:when (match (type-of #'e) ; type of the operand
[(tc-result1: (MPair: _ _)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
(define-syntax-class pair-opt-expr
(pattern (#%plain-app op:pair-unary-op p:pair-expr)
#:with opt
(begin (log-optimization "unary pair" #'op)
#'(op.unsafe p.opt))))
#'(op.unsafe p.opt)))
(pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...)
#:with opt
(begin (log-optimization "mutable pair" #'op)
#`(op.unsafe p.opt #,@(map (optimize) (syntax->list #'(e ...)))))))

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

@ -908,6 +908,18 @@
[set-mcdr! (-poly (a b)
(cl->* (-> (-mpair a b) b -Void)
(-> (-mlst a) (-mlst a) -Void)))]
[unsafe-mcar (-poly (a b)
(cl->* (-> (-mpair a b) a)
(-> (-mlst a) a)))]
[unsafe-mcdr (-poly (a b)
(cl->* (-> (-mpair a b) b)
(-> (-mlst a) (-mlst a))))]
[unsafe-set-mcar! (-poly (a b)
(cl->* (-> (-mpair a b) a -Void)
(-> (-mlst a) a -Void)))]
[unsafe-set-mcdr! (-poly (a b)
(cl->* (-> (-mpair a b) b -Void)
(-> (-mlst a) (-mlst a) -Void)))]
[mpair? (make-pred-ty (make-MPairTop))]
[mlist (-poly (a) (->* (list) a (-mlst a)))]
[mlength (-poly (a) (-> (-mlst a) -NonnegativeFixnum))]