From 21316e3ebfc5f9109483e23de38d29379bb13e2c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 6 Dec 2015 10:45:13 -0500 Subject: [PATCH] Don't copy immutable vectors in `vectorof` if not needed. This happens only if the element contract is a flat contract. --- .../scribblings/reference/contracts.scrbl | 7 ++- .../racket/contract/private/vector.rkt | 48 +++++++++++++------ 2 files changed, 39 insertions(+), 16 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 547a55de35..6339c80ddd 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -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?]{ diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index 45ffd86973..4adadcab78 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -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))