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

Don't copy immutable vectors in vectorof if not needed.

Browse Source 
This happens only if the element contract is a flat contract.
This commit is contained in:
Sam Tobin-Hochstadt 2015-12-06 10:45:13 -05:00
parent b8d4248053
commit 21316e3ebf
2 changed files with 39 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -366,7 +366,12 @@ is a chaperone contract, then the result will be a chaperone contract.
When a higher-order @racket[vectorof] contract is applied to a vector, the result
is not @racket[eq?] to the input. The result will be a copy for immutable vectors
and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors.}
and a @tech{chaperone} or @tech{impersonator} of the input for mutable vectors,
unless the @racket[c] argument is a flat contract and the vector is immutable,
in which case the result is the original vector.
@history[#:changed "6.3.0.5" @list{Changed flat vector contracts to not copy
immutable vectors.}]}
@defproc[(vector-immutableof [c contract?]) contract?]{

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

@ -173,21 +173,39 @@
(with-continuation-mark contract-continuation-mark-key
(cons neg-blame neg-party)
(elem-neg-proj val neg-party)))))
(λ (val neg-party)
(define (raise-blame val . args)
(apply raise-blame-error blame #:missing-party neg-party val args))
(check val raise-blame #f)
(if (and (immutable? val) (not (chaperone? val)))
(vector->immutable-vector
(for/vector #:length (vector-length val) ([e (in-vector val)])
(elem-pos-proj e neg-party)))
(chaperone-or-impersonate-vector
val
(checked-ref neg-party)
(checked-set neg-party)
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))))))
(cond
[(flat-contract? elem-ctc)
(define p? (flat-contract-predicate elem-ctc))
(λ (val neg-party)
(define (raise-blame val . args)
(apply raise-blame-error blame #:missing-party neg-party val args))
(check val raise-blame #f)
(if (and (immutable? val) (not (chaperone? val)))
(begin (for ([e (in-vector val)])
(unless (p? e)
(elem-pos-proj e neg-party)))
val)
(chaperone-or-impersonate-vector
val
(checked-ref neg-party)
(checked-set neg-party)
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party))))]
[else
(λ (val neg-party)
(define (raise-blame val . args)
(apply raise-blame-error blame #:missing-party neg-party val args))
(check val raise-blame #f)
(if (and (immutable? val) (not (chaperone? val)))
(vector->immutable-vector
(for/vector #:length (vector-length val) ([e (in-vector val)])
(elem-pos-proj e neg-party)))
(chaperone-or-impersonate-vector
val
(checked-ref neg-party)
(checked-set neg-party)
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party))))]))))
(define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
(make-impersonator-property 'prop:neg-blame-party))