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