From fc29e7e8562e4b00c6e7de5882d8ccf374051ca1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 14 Jul 2010 19:13:34 -0400 Subject: [PATCH] Added mutable pair optimizations. --- .../optimizer/generic/invalid-mpair.rkt | 4 ++++ .../typed-scheme/optimizer/generic/mpair.rkt | 14 ++++++++++++++ .../optimizer/hand-optimized/invalid-mpair.rkt | 4 ++++ .../optimizer/hand-optimized/mpair.rkt | 14 ++++++++++++++ .../optimizer/non-optimized/invalid-mpair.rkt | 4 ++++ .../optimizer/non-optimized/mpair.rkt | 14 ++++++++++++++ collects/typed-scheme/optimizer/pair.rkt | 18 +++++++++++++++++- collects/typed-scheme/private/base-env.rkt | 12 ++++++++++++ 8 files changed, 83 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/mpair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/hand-optimized/invalid-mpair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/hand-optimized/mpair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/non-optimized/invalid-mpair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/non-optimized/mpair.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt new file mode 100644 index 0000000000..a7a745116c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt @@ -0,0 +1,4 @@ +#lang typed/scheme #:optimize +(: f ((MListof Integer) -> Integer)) +(define (f x) + (mcar x)) diff --git a/collects/tests/typed-scheme/optimizer/generic/mpair.rkt b/collects/tests/typed-scheme/optimizer/generic/mpair.rkt new file mode 100644 index 0000000000..5fc67a699d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/mpair.rkt @@ -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))) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-mpair.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-mpair.rkt new file mode 100644 index 0000000000..59f4ff4e76 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/invalid-mpair.rkt @@ -0,0 +1,4 @@ +#lang typed/scheme +(: f ((MListof Integer) -> Integer)) +(define f + (#%plain-lambda (x) (mcar x))) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/mpair.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/mpair.rkt new file mode 100644 index 0000000000..aa3ba28a83 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/mpair.rkt @@ -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))) diff --git a/collects/tests/typed-scheme/optimizer/non-optimized/invalid-mpair.rkt b/collects/tests/typed-scheme/optimizer/non-optimized/invalid-mpair.rkt new file mode 100644 index 0000000000..fdf5c8858a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/non-optimized/invalid-mpair.rkt @@ -0,0 +1,4 @@ +#lang typed/scheme +(: f ((MListof Integer) -> Integer)) +(define (f x) + (mcar x)) diff --git a/collects/tests/typed-scheme/optimizer/non-optimized/mpair.rkt b/collects/tests/typed-scheme/optimizer/non-optimized/mpair.rkt new file mode 100644 index 0000000000..91fb312f64 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/non-optimized/mpair.rkt @@ -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))) diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index 0ac9a77af6..145d31bcc0 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -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 ...))))))) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 5cf07c3f9a..7f865c7a5a 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -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))]