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

Report close calls for pair/mpair optimizations.

Browse Source 
original commit: 89ca99210ec6e62167e1aebc846b48882a31354e
This commit is contained in:
Vincent St-Amour 2011-05-13 17:25:55 -04:00
parent c21628133e
commit 968f60d8e1
8 changed files with 127 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/tests/typed-scheme/optimizer/close-calls/pair.rkt Normal file
View File

@ -0,0 +1,62 @@
#;
(
pair.rkt 36:0 (#%app car (#%app list (quote 1) (quote 2) (quote 3))) -- car/cdr on a potentially empty list -- caused by: 36:10 (#%app list (quote 1) (quote 2) (quote 3))
pair.rkt 38:0 (#%app cdr (#%app list (quote 1) (quote 2) (quote 3))) -- car/cdr on a potentially empty list -- caused by: 38:10 (#%app list (quote 1) (quote 2) (quote 3))
pair.rkt 42:16 (#%app cdr (#%app cdr (#%app cdr (#%app cdr (#%app list (quote 1) (quote 2) (quote 3)))))) -- car/cdr on a potentially empty list -- caused by: 42:21 (#%app cdr (#%app cdr (#%app cdr (#%app list (quote 1) (quote 2) (quote 3)))))
pair.rkt 45:0 (#%app mcar (#%app mcons (quote 1) null)) -- mpair op on a potentially empty mlist -- caused by: (no location) (#%app mcons (quote 1) null)
pair.rkt 47:0 (#%app mcdr (#%app mcons (quote 1) null)) -- mpair op on a potentially empty mlist -- caused by: (no location) (#%app mcons (quote 1) null)
pair.rkt 51:0 (#%app set-mcar! (#%app mcons (quote 2) null) (quote 2)) -- mpair op on a potentially empty mlist -- caused by: (no location) (#%app mcons (quote 2) null)
pair.rkt 53:0 (#%app set-mcdr! (#%app mcons (quote 2) null) (#%app mcons (quote 2) null)) -- mpair op on a potentially empty mlist -- caused by: (no location) (#%app mcons (quote 2) null)
pair.rkt 59:17 (#%app mcar (quote ())) -- mpair op on a potentially empty mlist -- caused by: 59:23 (quote ())
pair.rkt 60:17 (#%app mcdr (quote ())) -- mpair op on a potentially empty mlist -- caused by: 60:23 (quote ())
pair.rkt 61:17 (#%app set-mcar! (quote ()) (quote 2)) -- mpair op on a potentially empty mlist -- caused by: 61:28 (quote ())
pair.rkt 62:17 (#%app set-mcdr! (quote ()) (#%app mcons (quote 3) null)) -- mpair op on a potentially empty mlist -- caused by: 62:33 (quote ())
1
1
'(2 3)
'(2 3)
'(3)
'()
1
1
'()
(mcons 2 (mcons 3))
(mcons 3)
'()
2
3
)
#lang typed/racket
(require racket/mpair)
;; car/cdr can be optimized if they are guaranteed to be applied only to
;; non-empty lists. otherwise, we miss a potential optimization
(car (ann (list 1 2 3) (Listof Byte)))
(car (list 1 2 3)) ; non-empty list type, shouldn't be reported
(cdr (ann (list 1 2 3) (Listof Byte)))
(cdr (list 1 2 3))
(cdr (cdr (list 1 2 3)))
(cdr (cdr (cdr (list 1 2 3))))
(define (dummy) (cdr (cdr (cdr (cdr (list 1 2 3)))))) ; unsafe, so missed opt
;; similar for mpairs
(mcar (ann (mlist 1) (MListof Byte)))
(mcar (mlist 1 2 3))
(mcdr (ann (mlist 1) (MListof Byte)))
(mcdr (mlist 1 2 3))
(mcdr (mcdr (mlist 1 2 3)))
(mcdr (mcdr (mcdr (mlist 1 2 3))))
(set-mcar! (ann (mlist 2) (MListof Byte)) 2)
(set-mcar! (mlist 2 3 4) 2)
(set-mcdr! (ann (mlist 2) (MListof Byte)) (ann (mlist 2) (MListof Byte)))
(mcar (mcons 2 3))
(mcdr (mcons 2 3))
(set-mcar! (mcons 2 3) 3)
(set-mcdr! (mcons 2 3) 4)
(define (dummy2) (mcar '()))
(define (dummy3) (mcdr '()))
(define (dummy4) (set-mcar! '() 2))
(define (dummy5) (set-mcdr! (ann '() (MListof Integer)) (ann (mlist 3) (MListof Integer))))

4
collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt
View File

@ -3,11 +3,11 @@
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair.rkt 23:0 (#%app caar (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3))) -- derived pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
derived-pair.rkt 24:0 (#%app cadr (#%app cons (quote 1) (#%app cons (quote 2) (quote 3)))) -- derived pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
derived-pair.rkt 25:0 (#%app cdar (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair

16
collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt
View File

@ -4,29 +4,29 @@
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair2.rkt 47:0 (#%app caaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) -- derived pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair2.rkt 48:0 (#%app caadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) -- derived pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
derived-pair2.rkt 49:0 (#%app cadar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
derived-pair2.rkt 50:0 (#%app caddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) -- derived pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair2.rkt 51:0 (#%app cdaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) -- derived pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
derived-pair2.rkt 52:0 (#%app cdadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
derived-pair2.rkt 53:0 (#%app cddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair

44
collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt
View File

@ -5,75 +5,75 @@
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair3.rkt 103:0 (#%app caaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) -- derived pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair3.rkt 104:0 (#%app caaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) -- derived pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
derived-pair3.rkt 105:0 (#%app caadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 106:0 (#%app caaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) -- derived pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair3.rkt 107:0 (#%app cadaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 108:0 (#%app cadadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) -- derived pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
derived-pair3.rkt 109:0 (#%app caddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 110:0 (#%app cadddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) -- derived pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair3.rkt 111:0 (#%app cdaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 112:0 (#%app cdaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) -- derived pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
derived-pair3.rkt 113:0 (#%app cdadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 114:0 (#%app cdaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) -- derived pair
#f (no location) car -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) car -- pair
derived-pair3.rkt 115:0 (#%app cddaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 116:0 (#%app cddadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) car -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair
derived-pair3.rkt 117:0 (#%app cdddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) -- derived pair
#f (no location) cdr -- pair
#f (no location) cdr -- pair

2
collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt
View File

@ -1,7 +1,7 @@
#;
(
nested-pair1.rkt 11:6 cdr -- pair
nested-pair1.rkt 11:1 car -- pair
nested-pair1.rkt 11:6 cdr -- pair
2
)

2
collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt
View File

@ -1,7 +1,7 @@
#;
(
nested-pair2.rkt 11:6 cdr -- pair
nested-pair2.rkt 11:1 car -- pair
nested-pair2.rkt 11:6 cdr -- pair
'(2)
)

12
collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt
View File

@ -2,16 +2,16 @@
(
pair-known-length-list.rkt 27:1 car -- pair
pair-known-length-list.rkt 28:1 cdr -- pair
pair-known-length-list.rkt 29:6 cdr -- pair
pair-known-length-list.rkt 29:1 car -- pair
pair-known-length-list.rkt 30:6 cdr -- pair
pair-known-length-list.rkt 29:6 cdr -- pair
pair-known-length-list.rkt 30:1 cdr -- pair
pair-known-length-list.rkt 31:11 cdr -- pair
pair-known-length-list.rkt 31:6 cdr -- pair
pair-known-length-list.rkt 30:6 cdr -- pair
pair-known-length-list.rkt 31:1 car -- pair
pair-known-length-list.rkt 32:11 cdr -- pair
pair-known-length-list.rkt 32:6 cdr -- pair
pair-known-length-list.rkt 31:6 cdr -- pair
pair-known-length-list.rkt 31:11 cdr -- pair
pair-known-length-list.rkt 32:1 cdr -- pair
pair-known-length-list.rkt 32:6 cdr -- pair
pair-known-length-list.rkt 32:11 cdr -- pair
1
'(2 3)
2

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

@ -24,20 +24,14 @@
(pattern (~literal set-mcdr!) #:with unsafe #'unsafe-set-mcdr!))
(define-syntax-class pair-expr
#:commit
(pattern e:expr
#:when (match (type-of #'e) ; type of the operand
[(tc-result1: (Pair: _ _)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
(define-syntax-class mpair-expr
#:commit
(pattern e:expr
#:when (match (type-of #'e) ; type of the operand
[(tc-result1: (MPair: _ _)) #t]
[_ #f])
#:with opt ((optimize) #'e)))
(define (has-pair-type? e)
(match (type-of e) ; type of the operand
[(tc-result1: (Pair: _ _)) #t]
[_ #f]))
(define (has-mpair-type? e)
(match (type-of e) ; type of the operand
[(tc-result1: (MPair: _ _)) #t]
[_ #f]))
(define-syntax-class pair-opt-expr
#:commit
@ -45,14 +39,27 @@
#:with opt
(begin (log-optimization "derived pair" #'e)
#'e.opt))
(pattern (#%plain-app op:pair-op p:pair-expr)
(pattern (#%plain-app op:pair-op p:expr)
#:when (or (has-pair-type? #'p)
;; in this case, we have a potentially empty list, but
;; it has to be a list, otherwise, there would have been
;; a type error
(begin
(log-close-call "car/cdr on a potentially empty list"
this-syntax #'p)
#f))
#:with opt
(begin (log-optimization "pair" #'op)
#'(op.unsafe p.opt)))
(pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...)
#`(op.unsafe #,((optimize) #'p))))
(pattern (#%plain-app op:mpair-op p:expr e:expr ...)
#:when (or (has-mpair-type? #'p)
(begin
(log-close-call "mpair op on a potentially empty mlist"
this-syntax #'p)
#f))
#:with opt
(begin (log-optimization "mutable pair" #'op)
#`(op.unsafe p.opt #,@(syntax-map (optimize) #'(e ...))))))
#`(op.unsafe #,@(syntax-map (optimize) #'(p e ...))))))
;; if the equivalent sequence of cars and cdrs is guaranteed not to fail,