From 11304827253eb2b88bbf99b1f54f85cf89f2ab96 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 16 Jul 2010 15:24:23 -0400 Subject: [PATCH 1/4] Documented the optimizer. (cherry picked from commit 8d6230956dc8c207c097a389fa1f0c7273bb55b7) original commit: 536551ce5ec30081a4823a21512e8ecbfc448bbf --- .../scribblings/optimization.scrbl | 21 +++++++++++++++++++ .../typed-scheme/scribblings/ts-guide.scrbl | 1 + .../scribblings/ts-reference.scrbl | 13 ++++++++++++ 3 files changed, 35 insertions(+) create mode 100644 collects/typed-scheme/scribblings/optimization.scrbl diff --git a/collects/typed-scheme/scribblings/optimization.scrbl b/collects/typed-scheme/scribblings/optimization.scrbl new file mode 100644 index 00000000..e7d70054 --- /dev/null +++ b/collects/typed-scheme/scribblings/optimization.scrbl @@ -0,0 +1,21 @@ +#lang scribble/manual + +@begin[(require (for-label (only-meta-in 0 typed/racket)) scribble/eval + "utils.rkt" (only-in "quick.scrbl" typed-mod))] + +@(define the-eval (make-base-eval)) +@(the-eval '(require typed/racket)) + +@title[#:tag "optimization"]{Optimization in Typed Racket} + +Typed Racket provides a type-driven optimizer that rewrites well-typed +programs to potentially make them faster. It should in no way make +your programs slower or unsafe. + +@section{Using the optimizer} + +Typed Racket's optimizer is not currently turned on by default. If you +want to activate it, you must add the @racket[#:optimize] keyword when +specifying the language of your program: + +@racketmod[typed/racket #:optimize] diff --git a/collects/typed-scheme/scribblings/ts-guide.scrbl b/collects/typed-scheme/scribblings/ts-guide.scrbl index 1c58c25c..948f7dbe 100644 --- a/collects/typed-scheme/scribblings/ts-guide.scrbl +++ b/collects/typed-scheme/scribblings/ts-guide.scrbl @@ -19,6 +19,7 @@ with Racket. For an introduction to Racket, see the @(other-manual '(lib "scrib @include-section["begin.scrbl"] @include-section["more.scrbl"] @include-section["types.scrbl"] +@include-section["optimization.scrbl"] @;@section{How the Type System Works} diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 4e063ef2..4b546d66 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -603,4 +603,17 @@ have the types ascribed to them; these types are converted to contracts and chec (define val 17)) (fun val)] + +@section{Optimization in Typed Racket} + +Typed Racket provides a type-driven optimizer that rewrites well-typed +programs to potentially make them faster. It should in no way make +your programs slower or unsafe. + +Typed Racket's optimizer is not currently turned on by default. If you +want to activate it, you must add the @racket[#:optimize] keyword when +specifying the language of your program: + +@racketmod[typed/racket #:optimize] + } From 0161cda2d40715f3a4c156c209a2f119d8f6f778 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 16 Jul 2010 16:57:29 -0400 Subject: [PATCH 2/4] Two fixes in overlap checking. - Names were not being resolved, so a superstruct name and substruct name could be seen as non-overlapping. - Struct parents were not checked in the overlapping algorithm. (cherry picked from commit 654b7df1decd52763ffedcdc507a4bf367b1cecf) original commit: 3884d5661022ef970a77f127e7a58d052760d635 --- .../typed-scheme/types/remove-intersect.rkt | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index a646a54c..074af5da 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -23,7 +23,8 @@ [(list _ (Univ:)) #t] [(list (F: _) _) #t] [(list _ (F: _)) #t] - [(list (Name: n) (Name: n*)) (free-identifier=? n n*)] + [(list (Name: n) (Name: n*)) + (overlap (resolve-once t1) (resolve-once t2))] [(list (? Mu?) _) (overlap (unfold t1) t2)] [(list _ (? Mu?)) (overlap t1 (unfold t2))] [(list (Union: e) t) @@ -68,12 +69,16 @@ [(list (Struct: n #f flds _ _ _ _ _) (StructTop: (Struct: n* #f flds* _ _ _ _ _))) #f] - [(list (Struct: n p flds _ _ _ _ _) - (Struct: n* p* flds* _ _ _ _ _)) - (and (= (length flds) (length flds*)) - (for/and ([f flds] [f* flds*]) - (match* (f f*) - [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))] + [(list (and t1 (Struct: n p flds _ _ _ _ _)) + (and t2 (Struct: n* p* flds* _ _ _ _ _))) + (let ([p1 (if (Name? p) (resolve-name p) p)] + [p2 (if (Name? p*) (resolve-name p*) p*)]) + (or (overlap t1 p2) + (overlap t2 p1) + (and (= (length flds) (length flds*)) + (for/and ([f flds] [f* flds*]) + (match* (f f*) + [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))))] [(list (== (-val eof)) (Function: _)) #f] From b71fbae36a7d6c51d7814d545d60e476a8c7efec Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 16 Jul 2010 18:16:51 -0400 Subject: [PATCH 3/4] Further fixes in overlap checking. Rhss of code dispatching on overlapping structs are no longer considered dead, and as such, are now typechecked. Had to fix a test that passed only because some not-really-dead code was not being typechecked. (cherry picked from commit 4d5b50dee9e04aee167a7e04fbbe23526131fcad) original commit: e0614cfed24dfc9e7f89b9a8c77e7930695b0269 --- .../typed-scheme/fail/dead-substruct.rkt | 16 +++ .../optimizer/generic/dead-substructs.rkt | 17 +++ .../typed-scheme/succeed/priority-queue.scm | 18 ++-- .../typed-scheme/xfail/priority-queue.scm | 101 ++++++++++++++++++ .../typed-scheme/types/remove-intersect.rkt | 7 +- 5 files changed, 147 insertions(+), 12 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/dead-substruct.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt create mode 100644 collects/tests/typed-scheme/xfail/priority-queue.scm diff --git a/collects/tests/typed-scheme/fail/dead-substruct.rkt b/collects/tests/typed-scheme/fail/dead-substruct.rkt new file mode 100644 index 00000000..eed75288 --- /dev/null +++ b/collects/tests/typed-scheme/fail/dead-substruct.rkt @@ -0,0 +1,16 @@ +#; +(exn-pred 1) +#lang typed/scheme + +(define-struct: parent ((x : Integer))) +(define-struct: (child1 parent) ((y : Integer))) +(define-struct: (child2 parent) ((y : Float))) + +(: f (parent -> Integer)) +(define (f x) + (cond [(child1? x) (+ "a" "b")] ; rhs was considered dead code + [(child2? x) 2] + [else (error "eh?")])) + +(f (make-child1 1 2)) +(f (make-child2 1 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt new file mode 100644 index 00000000..a01a5e5b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt @@ -0,0 +1,17 @@ +#lang typed/scheme #:optimize + +;; originally from nucleic3 +;; cond on substructs, branches were considered dead + +(define-struct: parent ((x : Integer))) +(define-struct: (child1 parent) ((y : Integer))) +(define-struct: (child2 parent) ((y : Float))) + +(: f (parent -> Integer)) +(define (f x) + (cond [(child1? x) 1] + [(child2? x) 2] + [else (error "eh?")])) + +(f (make-child1 1 2)) +(f (make-child2 1 2.0)) diff --git a/collects/tests/typed-scheme/succeed/priority-queue.scm b/collects/tests/typed-scheme/succeed/priority-queue.scm index 091a284d..9454a314 100644 --- a/collects/tests/typed-scheme/succeed/priority-queue.scm +++ b/collects/tests/typed-scheme/succeed/priority-queue.scm @@ -65,15 +65,15 @@ ;; "bug" found - handling of empty heaps (pdefine: (a) (find-min [pq : (priority-queue a)]) : a (let ([h (heap pq)]) - (if (heap:heap-node? h) - (elm (heap:find-min h)) - (error "priority queue empty")))) + (if (heap:empty? h) + (error "priority queue empty") + (elm (heap:find-min h))))) (pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number (let ([h (heap pq)]) - (if (heap:heap-node? h) - (pri (heap:find-min h)) - (error "priority queue empty")))) + (if (heap:empty? h) + (error "priority queue empty") + (pri (heap:find-min h))))) (pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a) (make (heap:insert (cons p x) (heap pq)))) @@ -84,9 +84,9 @@ (pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a) (let ([h (heap pq)]) - (if (heap:heap-node? h) - (make (heap:delete-min h)) - (error "priority queue empty")))) + (if (heap:empty? h) + (error "priority queue empty") + (make (heap:delete-min h))))) (pdefine: (a) (size [pq : (priority-queue a)]) : number diff --git a/collects/tests/typed-scheme/xfail/priority-queue.scm b/collects/tests/typed-scheme/xfail/priority-queue.scm new file mode 100644 index 00000000..091a284d --- /dev/null +++ b/collects/tests/typed-scheme/xfail/priority-queue.scm @@ -0,0 +1,101 @@ +#lang typed-scheme +;;; priority-queue.scm -- Jens Axel Søgaard +;;; PURPOSE + +; This file implements priority queues on top of +; a heap library. +(define-type-alias number Number) +(define-type-alias boolean Boolean) +(define-type-alias symbol Symbol) +(define-type-alias top Any) +(define-type-alias list-of Listof) +(require (prefix-in heap: "leftist-heap.ss") + (except-in (lib "67.ss" "srfi") number-compare current-compare =? number) (lib "67.ss" "srfi")) +(require/typed current-compare (-> (top top -> number)) (lib "67.ss" "srfi")) +(require/typed =? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi")) +(require/typed number) top top -> boolean) (lib "67.ss" "srfi")) + +; a priority-queue is a heap of (cons ) + +(define-type-alias (elem a) (cons number a)) + +(define-typed-struct (a) priority-queue ([heap : (heap:Heap (elem a))])) + +(define-type-alias (pqh a) (heap:Heap (elem a))) + +; conveniences +(pdefine: (a) (heap [pq : (priority-queue a)]) : (pqh a) (priority-queue-heap pq)) +(pdefine: (a) (pri [p : (elem a)]) : number (car p)) +(pdefine: (a) (elm [p : (elem a)]) : a (cdr p)) +(pdefine: (a) (make [h : (pqh a)]) : (priority-queue a) (make-priority-queue h)) + +; sort after priority +; TODO: and then element? +(pdefine: (a) (compare [p1 : (elem a)] [p2 : (elem a)]) : number + (number-compare (pri p1) (pri p2))) + +;;; OPERATIONS + +(define: (num-elems [h : (heap:Heap (cons number number))]) : (list-of (cons number number)) + (heap:elements h)) + +(pdefine: (a) (elements [pq : (priority-queue a)]) : (list-of a) + (map #{elm :: ((elem a) -> a)} (heap:elements (heap pq)))) + +(pdefine: (a) (elements+priorities [pq : (priority-queue a)]) : (values (list-of a) (list-of number)) + (let: ([eps : (list-of (elem a)) (heap:elements (heap pq))]) + (values (map #{elm :: ((elem a) -> a)} eps) + (map #{pri :: ((elem a) -> number)} eps)))) + +(pdefine: (a) (empty? [pq : (priority-queue a)]) : boolean + (heap:empty? (heap pq))) + +(define: empty : (All (a) (case-lambda (-> (priority-queue a)) (comparator -> (priority-queue a)))) + (pcase-lambda: (a) + [() (#{empty @ a} (current-compare))] + [([cmp : comparator]) (make (#{heap:empty :: (case-lambda (-> (pqh a)) + (comparator -> (pqh a)))} cmp))])) + +(pdefine: (e r) (fold [f : ((cons number e) r -> r)] [b : r] [a : (priority-queue e)]) : r + (heap:fold f b (#{heap :: ((priority-queue e) -> (pqh e))} a))) + + +;; "bug" found - handling of empty heaps +(pdefine: (a) (find-min [pq : (priority-queue a)]) : a + (let ([h (heap pq)]) + (if (heap:heap-node? h) + (elm (heap:find-min h)) + (error "priority queue empty")))) + +(pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number + (let ([h (heap pq)]) + (if (heap:heap-node? h) + (pri (heap:find-min h)) + (error "priority queue empty")))) + +(pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a) + (make (heap:insert (cons p x) (heap pq)))) + +;; FIXME -- too many annotations needed on cons +(pdefine: (a) (insert* [xs : (list-of a)] [ps : (list-of number)] [pq : (priority-queue a)]) : (priority-queue a) + (make (heap:insert* (map #{cons @ number a} ps xs) (heap pq)))) + +(pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a) + (let ([h (heap pq)]) + (if (heap:heap-node? h) + (make (heap:delete-min h)) + (error "priority queue empty")))) + + +(pdefine: (a) (size [pq : (priority-queue a)]) : number + (heap:size (heap pq))) + +(pdefine: (a) (union [pq1 : (priority-queue a)] [pq2 : (priority-queue a)]) : (priority-queue a) + (make (heap:union (heap pq1) (heap pq2)))) + + +#;(require "signatures/priority-queue-signature.scm") +#;(provide-priority-queue) + diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index 074af5da..64d55e8f 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -24,7 +24,8 @@ [(list (F: _) _) #t] [(list _ (F: _)) #t] [(list (Name: n) (Name: n*)) - (overlap (resolve-once t1) (resolve-once t2))] + (or (free-identifier=? n n*) + (overlap (resolve-once t1) (resolve-once t2)))] [(list (? Mu?) _) (overlap (unfold t1) t2)] [(list _ (? Mu?)) (overlap t1 (unfold t2))] [(list (Union: e) t) @@ -73,8 +74,8 @@ (and t2 (Struct: n* p* flds* _ _ _ _ _))) (let ([p1 (if (Name? p) (resolve-name p) p)] [p2 (if (Name? p*) (resolve-name p*) p*)]) - (or (overlap t1 p2) - (overlap t2 p1) + (or (and p2 (overlap t1 p2)) + (and p1 (overlap t2 p1)) (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (match* (f f*) From 34d7dda8440c77e5cc0cbfe1f760a341b56693c5 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 8 Jul 2010 18:29:02 -0400 Subject: [PATCH 4/4] Added a test for cross-module struct optimization. (cherry picked from commit 4e6fc3154bd286d3edcd36a25bfc672cc6a0659d) original commit: 8f47f0019fae4faf0ea8bb09d7fbd3b3e06254df --- .../optimizer/generic/cross-module-struct.rkt | 5 +++++ .../optimizer/generic/cross-module-struct2.rkt | 5 +++++ collects/tests/typed-scheme/optimizer/run.rkt | 11 ++++++++--- 3 files changed, 18 insertions(+), 3 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt new file mode 100644 index 00000000..7b52b214 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt @@ -0,0 +1,5 @@ +#lang typed/scheme #:optimize + +;; will be imported by cross-module-struct2 +(provide (struct-out x)) +(define-struct: x ((x : Integer))) diff --git a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt new file mode 100644 index 00000000..45a1696e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt @@ -0,0 +1,5 @@ +#lang typed/scheme #:optimize + +(require (file "cross-module-struct.rkt") racket/unsafe/ops) +(define a (make-x 1)) +(x-x a) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index b4139e25..6edd366d 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -15,7 +15,8 @@ (match-lambda [(list 'define-values-for-syntax '() _ ...) #f] [_ #t]) (cadddr (syntax->datum - (parameterize ([current-namespace (make-base-namespace)]) + (parameterize ([current-namespace (make-base-namespace)] + [read-accept-reader #t]) (with-handlers ([exn:fail? (lambda (exn) (printf "~a\n" (exn-message exn)) @@ -25,8 +26,12 @@ (define (test gen) (let-values (((base name _) (split-path gen))) (or (regexp-match ".*~" name) ; we ignore backup files - (equal? (read-and-expand gen) - (read-and-expand (build-path base "../hand-optimized/" name))) + (equal? (parameterize ([current-load-relative-directory + (build-path here "generic")]) + (read-and-expand gen)) + (let ((hand-opt-dir (build-path here "hand-optimized"))) + (parameterize ([current-load-relative-directory hand-opt-dir]) + (read-and-expand (build-path hand-opt-dir name))))) (begin (printf "~a failed\n\n" name) #f))))