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

streamline `vectorof' contact implementation

Browse Source 
Saves about 10% in a benchmark that applies a
`vectorof' contract frequently.
This commit is contained in:
Matthew Flatt 2012-04-03 16:30:44 -06:00
parent 5dad811a5d
commit e05e549021
1 changed files with 18 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/racket/contract/private/vector.rkt
View File

@ -47,22 +47,22 @@
(let ([elem-ctc (base-vectorof-elem c)] (let ([elem-ctc (base-vectorof-elem c)]
[immutable (base-vectorof-immutable c)] [immutable (base-vectorof-immutable c)]
[flat? (flat-vectorof? c)]) [flat? (flat-vectorof? c)])
(λ (val fail [first-order? #f]) (λ (val fail first-order?)
(unless (vector? val) (unless (vector? val)
(fail "expected a vector, got ~a" val)) (fail val "expected a vector, got ~a" val))
(cond (cond
[(eq? immutable #t) [(eq? immutable #t)
(unless (immutable? val) (unless (immutable? val)
(fail "expected an immutable vector, got ~a" val))] (fail val "expected an immutable vector, got ~a" val))]
[(eq? immutable #f) [(eq? immutable #f)
(when (immutable? val) (when (immutable? val)
(fail "expected an mutable vector, got ~a" val))] (fail val "expected an mutable vector, got ~a" val))]
[else (void)]) [else (void)])
(when first-order? (when first-order?
(for ([e (in-vector val)] (for ([e (in-vector val)]
[n (in-naturals)]) [n (in-naturals)])
(unless (contract-first-order-passes? elem-ctc e) (unless (contract-first-order-passes? elem-ctc e)
(fail "expected: ~s for element ~v, got ~v" (contract-name elem-ctc) n e)))) (fail val "expected: ~s for element ~v, got ~v" (contract-name elem-ctc) n e))))
#t))) #t)))
(define (vectorof-first-order ctc) (define (vectorof-first-order ctc)
@ -78,9 +78,12 @@
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:projection #:projection
(λ (ctc) (λ (ctc)
(define check (check-vectorof ctc))
(λ (blame) (λ (blame)
(define raise-blame (λ (val . args)
(apply raise-blame-error blame val args)))
(λ (val) (λ (val)
((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args))) (check val raise-blame #f)
(let* ([elem-ctc (base-vectorof-elem ctc)] (let* ([elem-ctc (base-vectorof-elem ctc)]
[p ((contract-projection elem-ctc) blame)]) [p ((contract-projection elem-ctc) blame)])
(for ([e (in-vector val)]) (for ([e (in-vector val)])
@ -90,22 +93,25 @@
(define (vectorof-ho-projection vector-wrapper) (define (vectorof-ho-projection vector-wrapper)
(λ (ctc) (λ (ctc)
(let ([elem-ctc (base-vectorof-elem ctc)] (let ([elem-ctc (base-vectorof-elem ctc)]
[immutable (base-vectorof-immutable ctc)]) [immutable (base-vectorof-immutable ctc)]
[check (check-vectorof ctc)])
(λ (blame) (λ (blame)
(let ([elem-pos-proj ((contract-projection elem-ctc) blame)] (let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
[elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))]) [elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
(define checked-ref (λ (vec i val) (elem-pos-proj val)))
(define checked-set (λ (vec i val) (elem-neg-proj val)))
(define raise-blame (λ (val . args)
(apply raise-blame-error blame val args)))
(λ (val) (λ (val)
((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args))) (check val raise-blame #f)
(if (immutable? val) (if (immutable? val)
(apply vector-immutable (apply vector-immutable
(for/list ([e (in-vector val)]) (for/list ([e (in-vector val)])
(elem-pos-proj e))) (elem-pos-proj e)))
(vector-wrapper (vector-wrapper
val val
(λ (vec i val) checked-ref
(elem-pos-proj val)) checked-set
(λ (vec i val)
(elem-neg-proj val))
impersonator-prop:contracted ctc)))))))) impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-vectorof base-vectorof) () (define-struct (chaperone-vectorof base-vectorof) ()