From 34fdd2863a1a3efccee06dbb1ba25eca594e0f01 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 20 Nov 2016 16:36:32 -0500 Subject: [PATCH] Avoid traversing immutable vectors when specified. This adds #:eager as an option for controlling this behavior. Using `#:eager 10` is a 2x improvement in performance for configuration 010001 of the suffixtree benchmark from Takikawa et al, POPL 2016. The default behavior is unchanged. This is configurable because some programs are much faster when eager checking is performed. For example: (require racket/contract) (collect-garbage) (time (for/sum ([_ 100000]) (vector-ref (contract (vectorof integer? #:eager #t) #(1) 'pos 'neg) 0))) (collect-garbage) (time (for/sum ([_ 100000]) (vector-ref (contract (vectorof integer? #:eager #f) #(1) 'pos 'neg) 0))) The second loop is 3-4 times slower than the first. However, making the vector much larger will make the difference go the other way. --- .../scribblings/reference/contracts.scrbl | 15 ++++++-- .../tests/racket/contract/vector.rkt | 21 +++++++++++- .../racket/contract/private/vector.rkt | 34 +++++++++++++++---- 3 files changed, 59 insertions(+), 11 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 199bb43e62..b9496d6813 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -420,7 +420,8 @@ passes its arguments to @racket[or/c]. @defproc[(vectorof [c contract?] [#:immutable immutable (or/c #t #f 'dont-care) 'dont-care] - [#:flat? flat? boolean? #f]) + [#:flat? flat? boolean? #f] + [#:eager eager (or/c #t #f exact-nonnegative-integer?) #t]) contract?]{ Returns a @tech{contract} that recognizes vectors. The elements of the vector must match @racket[c]. @@ -431,9 +432,16 @@ a @tech{flat contract}, and the @racket[c] argument must also be a @tech{flat co check future operations on the vector. If the @racket[immutable] argument is @racket[#t] and the @racket[c] argument is -a @tech{flat contract}, the result will be a @tech{flat contract}. If the @racket[c] argument +a @tech{flat contract} and the @racket[eager] argument is @racket[#t], +the result will be a @tech{flat contract}. If the @racket[c] argument is a @tech{chaperone contract}, then the result will be a @tech{chaperone contract}. +If the @racket[eager] argument is @racket[#t], then immutable vectors are +checked eagerly when @racket[c] is a @tech{flat contract}. If the +@racket[eager] argument is a number @racket[n], then immutable vectors are checked +eagerly when @racket[c] is a @tech{flat contract} and the length of the vector +is less than or equal to @racket[n].}. + 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, @@ -441,7 +449,8 @@ unless the @racket[c] argument is a @tech{flat contract} and the vector is immut 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.}]} + immutable vectors.} + #:changed "6.7.0.3" @list{Added the @racket[#:eager] option.}]} @defproc[(vector-immutableof [c contract?]) contract?]{ diff --git a/pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-test/tests/racket/contract/vector.rkt index e060273d86..6b29c564fc 100644 --- a/pkgs/racket-test/tests/racket/contract/vector.rkt +++ b/pkgs/racket-test/tests/racket/contract/vector.rkt @@ -148,5 +148,24 @@ 0) 1 2) - + + (test/spec-passed/result + 'vectorof-eager + '(vector-ref (contract (vectorof integer? #:eager #f) (vector-immutable 0 "") 'pos 'neg) 0) + 0) + + (test/spec-passed/result + 'vectorof-eager-1 + '(vector-ref (contract (vectorof integer? #:eager 1) (vector-immutable 0 "") 'pos 'neg) 0) + 0) + + + (test/pos-blame + 'vectorof-eager-1-fail + '(vector-ref (contract (vectorof integer? #:eager 2) (vector-immutable 0 "") 'pos 'neg) 1)) + + (test/pos-blame + 'vectorof-eager-fail + '(contract (vectorof integer? #:eager 5) (vector-immutable 0 "") 'pos 'neg)) + ) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index f1dfb0c962..11d0dee160 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -10,7 +10,11 @@ [wrap-vector/c vector/c]) vector-immutable/c vector-immutableof) -(define-struct base-vectorof (elem immutable)) +;; eager is one of: +;; - #t: always perform an eager check of the elements of an immutable vector +;; - #f: never perform an eager check of the elements of an immutable vector +;; - N (for N>=0): perform an eager check of immutable vectors size <= N +(define-struct base-vectorof (elem immutable eager)) (define-for-syntax (convert-args args this-one) (let loop ([args args] @@ -148,6 +152,7 @@ (λ (ctc) (define elem-ctc (base-vectorof-elem ctc)) (define immutable (base-vectorof-immutable ctc)) + (define eager (base-vectorof-eager ctc)) (define check (check-vectorof ctc)) (λ (blame) (define pos-blame (blame-add-element-of-context blame)) @@ -174,7 +179,12 @@ (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))) + ;; avoid traversing large vectors + ;; unless `eager` is specified + (if (and (or (equal? eager #t) + (and eager (<= (vector-length val) eager))) + (immutable? val) + (not (chaperone? val))) (begin (for ([e (in-vector val)]) (unless (p? e) (elem-pos-proj e neg-party))) @@ -240,20 +250,30 @@ 'racket/contract:contract (vector this-one (list #'vecof) null))))])) -(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f]) +(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f] #:eager [eager #t]) (define ctc (if flat? (coerce-flat-contract 'vectorof c) (coerce-contract 'vectorof c))) + (unless (or (boolean? eager) + (exact-nonnegative-integer? eager)) + (raise-argument-error 'vectorof + "(or/c #t #f exact-nonnegative-integer?)" + eager)) (cond - [(or flat? + [(and flat? (not (equal? eager #t))) + (raise-arguments-error 'vectorof "flat? cannot be true unless eager is true" + "flat?" flat? + "eager" eager)] + [(or (and flat? (equal? eager #t)) (and (equal? immutable #t) + (equal? eager #t) (flat-contract? ctc))) - (make-flat-vectorof ctc immutable)] + (make-flat-vectorof ctc immutable eager)] [(chaperone-contract? ctc) - (make-chaperone-vectorof ctc immutable)] + (make-chaperone-vectorof ctc immutable eager)] [else - (make-impersonator-vectorof ctc immutable)])) + (make-impersonator-vectorof ctc immutable eager)])) (define/subexpression-pos-prop (vector-immutableof c) (vectorof c #:immutable #t))