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

convert stream/c to late-neg-projection

Browse Source 
Also, tune the projection to get a few modest performance gains.

This program gets about 20% faster:

  #lang racket
  (define s (contract (stream/c exact-nonnegative-integer?)
                      (in-naturals) 'pos 'neg))
  (time
   (for ([x (in-range 1000)])
     (for/fold ([s s])
               ([x (in-range 100)])
       (stream-rest s))))

and this program gets about 15% faster:

  #lang racket
  (define f (contract (-> (stream/c exact-nonnegative-integer?)
                          any)
                      (λ (x) 1)
                      'pos 'neg))
  (define l (make-list 10000 0))
  (time (for ([x (in-range 1000)])
          (f l) (f l) (f l) (f l) (f l)))
This commit is contained in:
Robby Findler 2015-12-28 21:52:56 -06:00
parent ff31b01505
commit f7465f81f1
1 changed files with 31 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
racket/collects/racket/stream.rkt
View File

@ -240,45 +240,46 @@
(define (add-stream-context blame)
(blame-add-context blame "a value generated by"))
(define (check-stream/c ctc val blame)
(unless (stream? val)
(raise-blame-error blame val '(expected "a stream" given: "~e") val)))
(define (stream/c-stronger? a b)
(contract-stronger? (base-stream/c-content a) (base-stream/c-content b)))
; streams are lazy, so we need to contract the rest of the stream lazily (which can be a list)
(define (contract-stream-rest v ctc blame)
(define ((late-neg-projection impersonate/chaperone-stream) ctc)
(define elem-ctc (base-stream/c-content ctc))
(define new-ctc (if (list? v) (listof elem-ctc) ctc))
(((contract-projection new-ctc) blame) v))
(define ((ho-projection impersonate/chaperone-stream) ctc)
(let ([elem-ctc (base-stream/c-content ctc)])
(define listof-elem-ctc (listof elem-ctc))
(define elem-ctc-late-neg (get/build-late-neg-projection elem-ctc))
(define listof-elem-ctc-late-neg (get/build-late-neg-projection listof-elem-ctc))
(λ (blame)
(define stream-blame (add-stream-context blame))
(define pos-elem-proj ((contract-projection elem-ctc) stream-blame))
(λ (val)
(check-stream/c ctc val stream-blame)
(define elem-ctc-late-neg-acceptor (elem-ctc-late-neg stream-blame))
(define listof-elem-ctc-neg-acceptor (listof-elem-ctc-late-neg stream-blame))
(define (stream/c-late-neg-proj-val-acceptor val neg-party)
(unless (stream? val)
(raise-blame-error blame #:missing-party neg-party
val '(expected "a stream" given: "~e") val))
(if (list? val)
(contract-stream-rest val ctc stream-blame)
(listof-elem-ctc-neg-acceptor val neg-party)
(impersonate/chaperone-stream
val
(λ (v) (pos-elem-proj v))
(λ (v) (contract-stream-rest v ctc stream-blame))
(λ (v) (elem-ctc-late-neg-acceptor v neg-party))
(λ (v)
(if (list? v)
(listof-elem-ctc-neg-acceptor v neg-party)
(stream/c-late-neg-proj-val-acceptor v neg-party)))
impersonator-prop:contracted ctc
impersonator-prop:blame stream-blame))))))
impersonator-prop:blame stream-blame)))
stream/c-late-neg-proj-val-acceptor))
(struct base-stream/c (content))
(struct chaperone-stream/c base-stream/c ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#:name stream/c-name
#:first-order stream?
#:stronger stream/c-stronger?
#:projection (ho-projection chaperone-stream)))
#:late-neg-projection (late-neg-projection chaperone-stream))))
(struct impersonator-stream/c base-stream/c ()
#:property prop:custom-write custom-write-property-proc
@ -287,7 +288,7 @@
#:name stream/c-name
#:first-order stream?
#:stronger stream/c-stronger?
#:projection (ho-projection impersonate-stream)))
#:late-neg-projection (late-neg-projection impersonate-stream)))
(define (stream/c elem)
(define ctc (coerce-contract 'stream/c elem))