Added mutable pair optimizations.

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))

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)))

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)))

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)))

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))

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)))

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 ...)))))))

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))]