diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt index 21234c07..6cc4e161 100644 --- a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt @@ -1,11 +1,15 @@ #; ( -#f (no location) car -- pair -derived-pair.rkt 17:0 (#%app caar (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3))) -- derived pair -#f (no location) cdr -- pair -derived-pair.rkt 18:0 (#%app cadr (#%app cons (quote 1) (#%app cons (quote 2) (quote 3)))) -- derived pair -derived-pair.rkt 19:0 (#%app cdar (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3))) -- derived pair -derived-pair.rkt 20:0 (#%app cddr (#%app cons (quote 1) (#%app cons (quote 2) (quote 3)))) -- derived pair +derived-pair.rkt 21:0 car -- pair +derived-pair.rkt 21:0 (#%app caar (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3))) -- derived pair +derived-pair.rkt 22:0 car -- pair +derived-pair.rkt 22:0 cdr -- pair +derived-pair.rkt 22:0 (#%app cadr (#%app cons (quote 1) (#%app cons (quote 2) (quote 3)))) -- derived pair +derived-pair.rkt 23:0 cdr -- pair +derived-pair.rkt 23:0 car -- pair +derived-pair.rkt 23:0 (#%app cdar (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3))) -- derived pair +derived-pair.rkt 24:0 cdr -- pair +derived-pair.rkt 24:0 (#%app cddr (#%app cons (quote 1) (#%app cons (quote 2) (quote 3)))) -- derived pair 1 2 2 diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt index c80814cf..d76a3910 100644 --- a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt @@ -1,15 +1,27 @@ #; ( -#f (no location) car -- pair -derived-pair2.rkt 25:0 (#%app caaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) -- derived pair -#f (no location) cdr -- pair -derived-pair2.rkt 26:0 (#%app caadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) -- derived pair -derived-pair2.rkt 27:0 (#%app cadar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) -- derived pair -derived-pair2.rkt 28:0 (#%app caddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) -- derived pair -derived-pair2.rkt 29:0 (#%app cdaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) -- derived pair -derived-pair2.rkt 30:0 (#%app cdadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) -- derived pair -derived-pair2.rkt 31:0 (#%app cddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) -- derived pair -derived-pair2.rkt 32:0 (#%app cdddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) -- derived pair +derived-pair2.rkt 37:0 car -- pair +derived-pair2.rkt 37:0 (#%app caaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) -- derived pair +derived-pair2.rkt 38:0 car -- pair +derived-pair2.rkt 38:0 cdr -- pair +derived-pair2.rkt 38:0 (#%app caadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) -- derived pair +derived-pair2.rkt 39:0 car -- pair +derived-pair2.rkt 39:0 cdr -- pair +derived-pair2.rkt 39:0 (#%app cadar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) -- derived pair +derived-pair2.rkt 40:0 car -- pair +derived-pair2.rkt 40:0 cdr -- pair +derived-pair2.rkt 40:0 (#%app caddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) -- derived pair +derived-pair2.rkt 41:0 cdr -- pair +derived-pair2.rkt 41:0 car -- pair +derived-pair2.rkt 41:0 (#%app cdaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) -- derived pair +derived-pair2.rkt 42:0 cdr -- pair +derived-pair2.rkt 42:0 car -- pair +derived-pair2.rkt 42:0 (#%app cdadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) -- derived pair +derived-pair2.rkt 43:0 cdr -- pair +derived-pair2.rkt 43:0 car -- pair +derived-pair2.rkt 43:0 (#%app cddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) -- derived pair +derived-pair2.rkt 44:0 cdr -- pair +derived-pair2.rkt 44:0 (#%app cdddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) -- derived pair 1 2 2 diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt index bb6ee5e9..c7978c46 100644 --- a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt @@ -1,23 +1,51 @@ #; ( -#f (no location) car -- pair -derived-pair3.rkt 41: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) cdr -- pair -derived-pair3.rkt 42:0 (#%app caaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) -- derived pair -derived-pair3.rkt 43:0 (#%app caadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) -- derived pair -derived-pair3.rkt 44:0 (#%app caaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) -- derived pair -derived-pair3.rkt 45:0 (#%app cadaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) -- derived pair -derived-pair3.rkt 46:0 (#%app cadadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) -- derived pair -derived-pair3.rkt 47:0 (#%app caddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) -- derived pair -derived-pair3.rkt 48:0 (#%app cadddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) -- derived pair -derived-pair3.rkt 49:0 (#%app cdaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) -- derived pair -derived-pair3.rkt 50:0 (#%app cdaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) -- derived pair -derived-pair3.rkt 51:0 (#%app cdadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) -- derived pair -derived-pair3.rkt 52:0 (#%app cdaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) -- derived pair -derived-pair3.rkt 53:0 (#%app cddaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) -- derived pair -derived-pair3.rkt 54:0 (#%app cddadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) -- derived pair -derived-pair3.rkt 55:0 (#%app cdddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) -- derived pair -derived-pair3.rkt 56:0 (#%app cddddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) -- derived pair +derived-pair3.rkt 69:0 car -- pair +derived-pair3.rkt 69:0 (#%app caaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) -- derived pair +derived-pair3.rkt 70:0 car -- pair +derived-pair3.rkt 70:0 cdr -- pair +derived-pair3.rkt 70:0 (#%app caaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) -- derived pair +derived-pair3.rkt 71:0 car -- pair +derived-pair3.rkt 71:0 cdr -- pair +derived-pair3.rkt 71:0 (#%app caadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) -- derived pair +derived-pair3.rkt 72:0 car -- pair +derived-pair3.rkt 72:0 cdr -- pair +derived-pair3.rkt 72:0 (#%app caaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) -- derived pair +derived-pair3.rkt 73:0 car -- pair +derived-pair3.rkt 73:0 cdr -- pair +derived-pair3.rkt 73:0 (#%app cadaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) -- derived pair +derived-pair3.rkt 74:0 car -- pair +derived-pair3.rkt 74:0 cdr -- pair +derived-pair3.rkt 74:0 (#%app cadadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) -- derived pair +derived-pair3.rkt 75:0 car -- pair +derived-pair3.rkt 75:0 cdr -- pair +derived-pair3.rkt 75:0 (#%app caddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) -- derived pair +derived-pair3.rkt 76:0 car -- pair +derived-pair3.rkt 76:0 cdr -- pair +derived-pair3.rkt 76:0 (#%app cadddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) -- derived pair +derived-pair3.rkt 77:0 cdr -- pair +derived-pair3.rkt 77:0 car -- pair +derived-pair3.rkt 77:0 (#%app cdaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) -- derived pair +derived-pair3.rkt 78:0 cdr -- pair +derived-pair3.rkt 78:0 car -- pair +derived-pair3.rkt 78:0 (#%app cdaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) -- derived pair +derived-pair3.rkt 79:0 cdr -- pair +derived-pair3.rkt 79:0 car -- pair +derived-pair3.rkt 79:0 (#%app cdadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) -- derived pair +derived-pair3.rkt 80:0 cdr -- pair +derived-pair3.rkt 80:0 car -- pair +derived-pair3.rkt 80:0 (#%app cdaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) -- derived pair +derived-pair3.rkt 81:0 cdr -- pair +derived-pair3.rkt 81:0 car -- pair +derived-pair3.rkt 81:0 (#%app cddaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) -- derived pair +derived-pair3.rkt 82:0 cdr -- pair +derived-pair3.rkt 82:0 car -- pair +derived-pair3.rkt 82:0 (#%app cddadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) -- derived pair +derived-pair3.rkt 83:0 cdr -- pair +derived-pair3.rkt 83:0 car -- pair +derived-pair3.rkt 83:0 (#%app cdddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) -- derived pair +derived-pair3.rkt 84:0 cdr -- pair +derived-pair3.rkt 84:0 (#%app cddddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) -- derived pair 1 2 2 diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index d4f68170..70971866 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -62,6 +62,10 @@ #`(op.unsafe #,@(syntax-map (optimize) #'(p e ...)))))) +;; change the source location of a given syntax object +(define (relocate stx loc-stx) + (datum->syntax stx (syntax->datum stx) loc-stx stx stx)) + ;; if the equivalent sequence of cars and cdrs is guaranteed not to fail, ;; we can optimize @@ -73,7 +77,7 @@ (if (null? accessors) #'arg (quasisyntax/loc stx - (#%plain-app #,(car accessors) + (#%plain-app #,(relocate (car accessors) stx) #,(gen-alt-helper (cdr accessors)))))) (let ((ty (type-of stx)) (obj (gen-alt-helper accessors)))