From 968f60d8e14d1c6e0e849ca82f302afcae2a412c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 13 May 2011 17:25:55 -0400 Subject: [PATCH] Report close calls for pair/mpair optimizations. original commit: 89ca99210ec6e62167e1aebc846b48882a31354e --- .../optimizer/close-calls/pair.rkt | 62 +++++++++++++++++++ .../optimizer/tests/derived-pair.rkt | 4 +- .../optimizer/tests/derived-pair2.rkt | 16 ++--- .../optimizer/tests/derived-pair3.rkt | 44 ++++++------- .../optimizer/tests/nested-pair1.rkt | 2 +- .../optimizer/tests/nested-pair2.rkt | 2 +- .../tests/pair-known-length-list.rkt | 12 ++-- collects/typed-scheme/optimizer/pair.rkt | 43 +++++++------ 8 files changed, 127 insertions(+), 58 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/close-calls/pair.rkt diff --git a/collects/tests/typed-scheme/optimizer/close-calls/pair.rkt b/collects/tests/typed-scheme/optimizer/close-calls/pair.rkt new file mode 100644 index 00000000..12d13e1a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/close-calls/pair.rkt @@ -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)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt index cb8f1816..d17ad864 100644 --- a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt index e146235d..fe6959f8 100644 --- a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt index 2451497a..d893831c 100644 --- a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt @@ -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 diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt index d18b33cd..c1836b01 100644 --- a/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt @@ -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 ) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt index 54f71fb1..8ff67ad4 100644 --- a/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt @@ -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) ) diff --git a/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt b/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt index a488056d..5f138e42 100644 --- a/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt @@ -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 diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index 7a362da7..13de3d07 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -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,