From d927d04efdb70bfbfc2c24fbdd4c7eefa7089ec1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 25 Dec 2015 22:31:30 -0600 Subject: [PATCH] generalize tail contract checking for function contracts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Specifically, remove reliance on procedure-closure-contents-eq? to tell when a pending check is stronger in favor of usint contract-stronger? Also, tighten up the specification of contract-stronger? to require that any contract is stronger than itself With this commit, this program gets about 10% slower: #lang racket/base (require racket/contract/base) (define f (contract (-> any/c integer?) (λ (x) (if (zero? x) 0 (f (- x 1)))) 'pos 'neg)) (time (f 2000000)) becuase the checking is doing work more explicitly now but because the checking in more general, it identifies the redundant checking in this program #lang racket/base (require racket/contract/base) (define f (contract (-> any/c integer?) (contract (-> any/c integer?) (λ (x) (if (zero? x) 0 (f (- x 1)))) 'pos 'neg) 'pos 'neg)) (time (f 200000)) which makes it run about 13x faster than it did before I'm not sure if this is a win overall, since the checking can be more significant in the case of "near misses". For example, with this program, where neither the new nor the old checking detects the redundancy is about 40% slower after this commit than it was before: #lang racket/base (require racket/contract/base) (define f (contract (-> any/c (<=/c 0)) (contract (-> any/c (>=/c 0)) (λ (x) (if (zero? x) 0 (f (- x 1)))) 'pos 'neg) 'pos 'neg)) (time (f 50000)) (The redundancy isn't detected here because the contract system only looks at the first pending contract check.) Overall, despite the fact that it slows down some programs and speeds up others, my main thought is that it is worth doing because it eliminates a (painful) reliance on procedure-closure-contents-eq? that inhibits other approaches to optimizing these contracts we might try. --- .../scribblings/reference/contracts.scrbl | 11 +- .../tests/racket/contract/arrow.rkt | 15 +++ .../tests/racket/contract/tail.rkt | 23 ++++ .../contract/private/arrow-higher-order.rkt | 35 +++-- .../contract/private/arrow-val-first.rkt | 10 +- .../racket/contract/private/arrow.rkt | 127 +++++++++++------- .../racket/contract/private/case-arrow.rkt | 104 ++++++++------ .../racket/contract/private/opt-guts.rkt | 5 + .../racket/contract/private/opters.rkt | 4 +- .../collects/racket/contract/private/prop.rkt | 76 ++++++----- 10 files changed, 266 insertions(+), 144 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 487a0b3899..fc6313f011 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2024,8 +2024,8 @@ flat contracts do not need to supply an explicit projection. The @racket[stronger] argument is used to implement @racket[contract-stronger?]. The first argument is always the contract itself and the second argument is whatever was passed as the second argument to @racket[contract-stronger?]. If no -@racket[stronger] argument is supplied, then a default that always returns -@racket[#f] is used. +@racket[stronger] argument is supplied, then a default that compares its arguments +with @racket[equal?] is used. The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate to determine if this is a contract that accepts only @racket[list?] values. @@ -2721,6 +2721,9 @@ are below): Returns @racket[#t] if the contract @racket[x] accepts either fewer or the same number of values as @racket[y] does. + Contracts that are the same (i.e., where @racket[x] is @racket[equal?] + to @racket[y]) are considered to always be stronger than each other. + This function is conservative, so it may return @racket[#f] when @racket[x] does, in fact, accept fewer values. @@ -2730,8 +2733,8 @@ are below): (contract-stronger? (between/c 0 100) (between/c 25 75)) (contract-stronger? (between/c -10 0) (between/c 0 10)) - (contract-stronger? (λ (x) (and (real? x) (<= x (random 10)))) - (λ (x) (and (real? x) (<= x (+ 100 (random 10))))))] + (contract-stronger? (λ (x) (and (real? x) (<= x 0))) + (λ (x) (and (real? x) (<= x 100))))] } diff --git a/pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-test/tests/racket/contract/arrow.rkt index 9d436e3bcc..c0de59f415 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -340,6 +340,21 @@ ;; pass; this is fixed in a separate branch that can't (regexp-match #rx"expected:? keyword argument #:the-missing-keyword-arg-b" (exn-message x))))) + + ;; need to preserve the inner contract here + ;; (not the outer one) + ;; when dropping redundant tail contracts + (test/pos-blame + 'tail-wrapping-preserves-blame + '(let ([c (-> number? number?)]) + ((contract + c + (contract + c + (λ (x) #f) + 'pos 'neg) + 'something-else 'yet-another-thing) + 1))) (test/pos-blame 'predicate/c1 diff --git a/pkgs/racket-test/tests/racket/contract/tail.rkt b/pkgs/racket-test/tests/racket/contract/tail.rkt index 708b376ce0..024f0fe544 100644 --- a/pkgs/racket-test/tests/racket/contract/tail.rkt +++ b/pkgs/racket-test/tests/racket/contract/tail.rkt @@ -85,6 +85,29 @@ (c))) (ctest/rewrite '(1) + mut-rec-with-any + (let () + (define f + (contract (-> number? any) + (lambda (x) + (if (zero? x) + (continuation-mark-set->list (current-continuation-marks) + 'tail-test) + (with-continuation-mark 'tail-test x + (g (- x 1))))) + 'something-that-is-not-pos + 'neg)) + + (define g + (contract (-> number? any) + (lambda (x) + (f x)) + 'also-this-is-not-pos + 'neg)) + + (f 3))) + + (ctest/rewrite '(1 2 3) mut-rec-with-any/c (let () (define f diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 7e7ac58481..8c72a5cdde 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -32,15 +32,15 @@ [(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)] [(rng-proj ...) (if rngs (generate-temporaries rngs) '())] [(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())]) - #`(λ (blame f neg-party + #`(λ (blame f neg-party blame-party-info rng-ctcs mandatory-dom-proj ... optional-dom-proj ... rest-proj ... mandatory-dom-kwd-proj ... optional-dom-kwd-proj ... rng-proj ...) - #,(create-chaperone - #'blame #'f + #,(create-chaperone + #'blame #'neg-party #'blame-party-info #'f #'rng-ctcs this-args (syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(optional-dom-proj ...)) @@ -114,7 +114,8 @@ (if pre? "pre" "post") condition-result)])) -(define-for-syntax (create-chaperone blame val +(define-for-syntax (create-chaperone blame neg-party blame-party-info + val rng-ctcs this-args doms opt-doms req-kwds opt-kwds @@ -150,7 +151,7 @@ [(opt-kwd ...) (map car opt-kwds)] [(opt-kwd-ctc ...) (map cadr opt-kwds)] [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))] - [(rng-ctc ...) (if rngs rngs '())] + [(rng-late-neg-projs ...) (if rngs rngs '())] [(rng-x ...) (if rngs (generate-temporaries rngs) '())]) (with-syntax ([(rng-checker-name ...) (if rngs @@ -161,7 +162,7 @@ (list (with-syntax ([rng-len (length rngs)]) (with-syntax ([rng-results - #'(values (rng-ctc rng-x neg-party) + #'(values (rng-late-neg-projs rng-x neg-party) ...)]) #'(case-lambda [(rng-x ...) @@ -248,7 +249,9 @@ dom-projd-args ...)))]) (if no-rng-checking? (inner-stx-gen #'()) - (arrow:check-tail-contract #'(rng-ctc ...) + (arrow:check-tail-contract rng-ctcs + blame-party-info + neg-party #'(rng-checker-name ...) inner-stx-gen)))] [kwd-return @@ -273,7 +276,9 @@ #`(let ([kwd-results kwd-stx]) #,(if no-rng-checking? (outer-stx-gen #'()) - (arrow:check-tail-contract #'(rng-ctc ...) + (arrow:check-tail-contract rng-ctcs + blame-party-info + neg-party #'(rng-checker-name ...) outer-stx-gen))))]) (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] @@ -398,12 +403,15 @@ man-then-opt-partial-kwds partial-ranges (if partial-rest (list partial-rest) '()))) - + (define blame-party-info (arrow:get-blame-party-info orig-blame)) (define (successfully-got-the-right-kind-of-function val neg-party) - (define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args)) + (define chap/imp-func (apply chaperone-constructor + orig-blame val + neg-party blame-party-info + rngs the-args)) (cond [chap/imp-func - (if post? + (if (or post? (not rngs)) (chaperone-or-impersonate-procedure val chap/imp-func @@ -414,9 +422,8 @@ chap/imp-func impersonator-prop:contracted ctc impersonator-prop:blame (blame-add-missing-party orig-blame neg-party) - impersonator-prop:application-mark (cons arrow:contract-key - ;; is this right? - partial-ranges)))] + impersonator-prop:application-mark + (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))] [else val])) (cond diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index a5ae6a5fe3..8e229e3c95 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -895,7 +895,7 @@ optional-keywords (and rest-contract #t) rng-len) - (λ (blame f neg-party . args) + (λ (blame f neg-party blame-party-info rng-ctc-x . args) (define-next next args) (define mandatory-dom-projs (next min-arity)) (define optional-dom-projs (next optionals)) @@ -1242,7 +1242,7 @@ (make--> 0 '() '() #f #f (list (coerce-contract 'whatever void?)) #f - (λ (blame f _ignored-rng-contract) + (λ (blame f _ignored-rng-ctcs _ignored-rng-proj) (λ (neg-party) (call-with-values (λ () (f)) @@ -1276,7 +1276,11 @@ (call-with-values (λ () (f argument)) (rng-checker f blame neg-party)))) - (λ (blame f neg-party _ignored-dom-contract _ignored-rng-contract) + (λ (blame f neg-party + _ignored-blame-party-info + _ignored-rng-ctcs + _ignored-dom-contract + _ignored-rng-contract) (unless (procedure? f) (raise-blame-error blame #:missing-party neg-party f diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index c953a56775..0d9f9dea3a 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -32,8 +32,9 @@ (for-syntax check-tail-contract make-this-parameters parse-leftover->*) - contract-key + tail-contract-key tail-marks-match? + get-blame-party-info values/drop arity-checking-wrapper unspecified-dom @@ -49,34 +50,51 @@ (list id) null)) -(define contract-key (gensym 'contract-key)) +(define tail-contract-key (gensym 'tail-contract-key)) -(define-for-syntax (check-tail-contract rng-ctcs rng-checkers call-gen) +(define-for-syntax (check-tail-contract rng-ctcs blame-party-info neg-party rng-checkers call-gen) + (unless (identifier? rng-ctcs) + (raise-argument-error 'check-tail-contract + "identifier?" + 0 + rng-ctcs rng-checkers call-gen)) #`(call-with-immediate-continuation-mark - contract-key + tail-contract-key (λ (m) - (if (tail-marks-match? m . #,rng-ctcs) + (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party) #,(call-gen #'()) #,(call-gen rng-checkers))))) -(begin-encourage-inline - (define tail-marks-match? - (case-lambda - [(m) (and m (null? m))] - [(m rng-ctc) - (and m - (not (null? m)) - (null? (cdr m)) - (procedure-closure-contents-eq? (car m) rng-ctc))] - [(m rng-ctc1 rng-ctc2) - (and m - (= (length m) 2) - (procedure-closure-contents-eq? (car m) rng-ctc1) - (procedure-closure-contents-eq? (cadr m) rng-ctc1))] - [(m . rng-ctcs) - (and m - (= (length m) (length rng-ctcs)) - (andmap procedure-closure-contents-eq? m rng-ctcs))]))) +;; m : (or/c #f (cons/c neg-party (cons/c (list/c pos-party boolean?[blame-swapped?]) (listof ctc)))) +;; rng-ctc : (or/c #f (listof ctc)) +;; blame-party-info : (list/c pos-party boolean?[blame-swapped?]) +;; neg-party : neg-party +(define (tail-marks-match? m rng-ctcs blame-party-info neg-party) + (and m + rng-ctcs + (eq? (car m) neg-party) + (let ([mark-blame-part-info (cadr m)]) + (and (eq? (car mark-blame-part-info) (car blame-party-info)) + (eq? (cadr mark-blame-part-info) (cadr blame-party-info)))) + (let loop ([m (cddr m)] + [rng-ctcs rng-ctcs]) + (cond + [(null? m) (null? rng-ctcs)] + [(null? rng-ctcs) (null? m)] + [else + (define m1 (car m)) + (define rng-ctc1 (car rng-ctcs)) + (cond + [(eq? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] + [(contract-struct-stronger? m1 rng-ctc1) (loop (cdr m) (cdr rng-ctcs))] + [else #f])])))) + +;; used as part of the information in the continuation mark +;; that records what is to be checked for a pending contract +(define (get-blame-party-info blame) + (define swapped? (blame-swapped? blame)) + (list (if swapped? (blame-negative blame) (blame-positive blame)) + swapped?)) (define-syntax (unconstrained-domain-> stx) (syntax-case stx () @@ -86,9 +104,11 @@ [(p-app-x ...) (generate-temporaries #'(rngs ...))] [(res-x ...) (generate-temporaries #'(rngs ...))]) #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x (get/build-late-neg-projection rngs-x)] ...) + (let ([rngs-list (list rngs-x ...)] + [proj-x (get/build-late-neg-projection rngs-x)] ...) (define (projection wrapper get-ctc) (λ (orig-blame) + (define blame-party-info (get-blame-party-info orig-blame)) (define ctc (get-ctc)) (let ([rng-blame (blame-add-range-context orig-blame)]) (let* ([p-app-x (proj-x rng-blame)] ...) @@ -102,19 +122,23 @@ (with-contract-continuation-mark (cons orig-blame neg-party) #,(check-tail-contract - #'(p-app-x ...) + #'rngs-list + #'blame-party-info + #'neg-party (list #'res-checker) (λ (s) #`(apply values #,@s kwd-vals args))))) (λ args (with-contract-continuation-mark (cons orig-blame neg-party) #,(check-tail-contract - #'(p-app-x ...) + #'rngs-list + #'blame-party-info + #'neg-party (list #'res-checker) (λ (s) #`(apply values #,@s args)))))) impersonator-prop:contracted ctc impersonator-prop:application-mark - (cons contract-key (list p-app-x ...)))))))) + (cons tail-contract-key (list neg-party blame-party-info rngs-x ...)))))))) (make-unconstrained-domain-> (list rngs-x ...) projection))))])) @@ -200,9 +224,9 @@ (loop (cdr accepted) req-kwds (cdr opt-kwds))] [else #f]))]))) -(define-for-syntax (create-chaperone blame neg-party val pre post this-args +(define-for-syntax (create-chaperone blame neg-party blame-party-info val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds - rngs) + rngs rng-ctc-id) (with-syntax ([blame blame] [neg-party neg-party] [val val]) @@ -318,7 +342,9 @@ (dom-ctc dom-x neg-party) ...)))]) (if no-rng-checking? (inner-stx-gen #'()) - (check-tail-contract #'(rng-ctc ...) + (check-tail-contract rng-ctc-id + blame-party-info + #'neg-party #'(rng-checker-name ...) inner-stx-gen)))] [kwd-return @@ -340,7 +366,11 @@ #`(let ([kwd-results kwd-stx]) #,(if no-rng-checking? (outer-stx-gen #'()) - (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) outer-stx-gen))))]) + (check-tail-contract rng-ctc-id + blame-party-info + #'neg-party + #'(rng-checker-name ...) + outer-stx-gen))))]) (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] [basic-lambda #'(λ basic-params ;; Arrow contract domain checking is instrumented @@ -534,7 +564,8 @@ (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc))) (base->-doms/c ctc)))] [doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))] - [rngs-proj (map get/build-late-neg-projection (base->-rngs/c ctc))] + [rngs-ctc (base->-rngs/c ctc)] + [rngs-proj (map get/build-late-neg-projection rngs-ctc)] [mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))] [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))] [mandatory-keywords (base->-mandatory-kwds ctc)] @@ -578,16 +609,18 @@ (kwd-proj (blame-add-context orig-blame (format "the ~a argument of" kwd) #:swap? #t)))) - (define the-args (append partial-doms partial-optional-doms - partial-mandatory-kwds partial-optional-kwds - partial-ranges)) + (define the-args (cons rngs-ctc + (append partial-doms partial-optional-doms + partial-mandatory-kwds partial-optional-kwds + partial-ranges))) + (define blame-party-info (get-blame-party-info orig-blame)) (λ (val neg-party) (if has-rest? (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame neg-party) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame neg-party)) - (define chap/imp-func (apply func orig-blame neg-party val the-args)) + (define chap/imp-func (apply func orig-blame neg-party blame-party-info val the-args)) (if post (wrapper val @@ -597,9 +630,8 @@ val chap/imp-func impersonator-prop:contracted ctc - impersonator-prop:application-mark (cons contract-key - ;; is this right? - partial-ranges))))))) + impersonator-prop:application-mark + (cons tail-contract-key (list* neg-party blame-party-info rngs-ctc)))))))) (define (->-name ctc) (single-arrow-name-maker @@ -811,19 +843,22 @@ [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->)) (syntax->list kwd-ctcs))] [(kwds ...) kwds] + [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))] [use-any? use-any?]) (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [outer-lambda - #`(lambda (blame neg-party val dom-names ... kwd-names ... rng-names ...) + #`(lambda (blame neg-party blame-party-info val rng-ctc-x + dom-names ... kwd-names ... rng-names ...) #,(create-chaperone - #'blame #'neg-party #'val #f #f + #'blame #'neg-party #'blame-party-info #'val #f #f (syntax->list #'(this-params ...)) (syntax->list #'(dom-names ...)) null #f (map list (syntax->list #'(kwds ...)) (syntax->list #'(kwd-names ...))) null - (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...)))))]) + (if (syntax->datum #'use-any?) #f (syntax->list #'(rng-names ...))) + #'rng-ctc-x))]) (syntax-property (syntax/loc stx (build--> '-> @@ -976,6 +1011,7 @@ [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [(rng-proj ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))] + [(rng-ctc-x) (generate-temporaries '(rng-ctc-x))] [(this-parameter ...) (make-this-parameters (car (generate-temporaries '(this))))]) (quasisyntax/loc stx @@ -996,7 +1032,7 @@ #''()) #,(if rng-ctc #f #t) mtd? ->m-ctc? - (λ (blame neg-party f + (λ (blame neg-party blame-party-info f rng-ctc-x mandatory-dom-proj ... #,@(if rest-ctc #'(rest-proj) @@ -1006,7 +1042,7 @@ optional-dom-kwd-proj ... rng-proj ...) #,(create-chaperone - #'blame #'neg-party #'f pre post + #'blame #'neg-party #'blame-party-info #'f pre post (syntax->list #'(this-parameter ...)) (syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(optional-dom-proj ...)) @@ -1015,7 +1051,8 @@ (syntax->list #'(mandatory-dom-kwd-proj ...))) (map list (syntax->list #'(optional-dom-kwd ...)) (syntax->list #'(optional-dom-kwd-proj ...))) - (if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))])) + (if rng-ctc (syntax->list #'(rng-proj ...)) #f) + #'rng-ctc-x))))))))))])) (define (convert-pre-post/desc-to-boolean pre? b) (cond diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index 83eca5e086..f51e1862ef 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -52,27 +52,29 @@ [_ (raise-syntax-error #f "expected ->" stx case)])) -(define-for-syntax (parse-out-case stx case n) - (let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)]) - (with-syntax ([(dom-proj-x ...) (generate-temporaries doms)] +(define-for-syntax (parse-out-case stx neg-party blame-party-info case n) + (let-values ([(dom-ctc-exprs rst-ctc-expr rng-ctc-exprs) (separate-out-doms/rst/rng stx case)]) + (with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)] [(rst-proj-x) (generate-temporaries '(rest-proj-x))] - [(rng-proj-x ...) (generate-temporaries (if rng rng '()))]) - (with-syntax ([(dom-formals ...) (generate-temporaries doms)] + [(rng-proj-x ...) (generate-temporaries (if rng-ctc-exprs rng-ctc-exprs '()))] + [(rng-ctcs-x) (generate-temporaries '(rng-ctc-x))]) + (with-syntax ([(dom-formals ...) (generate-temporaries dom-ctc-exprs)] [(rst-formal) (generate-temporaries '(rest-param))] - [(rng-id ...) (if rng - (generate-temporaries rng) + [(rng-id ...) (if rng-ctc-exprs + (generate-temporaries rng-ctc-exprs) '())] [(this-parameter ...) (make-this-parameters (car (generate-temporaries '(this))))]) - #`(#,doms - #,rst - #,(if rng #`(list #,@rng) #f) - #,(length (syntax->list doms)) ;; spec - (dom-proj-x ... #,@(if rst #'(rst-proj-x) #'())) + #`(#,dom-ctc-exprs + #,rst-ctc-expr + #,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f) + #,(length (syntax->list dom-ctc-exprs)) ;; spec + (dom-proj-x ... #,@(if rst-ctc-expr #'(rst-proj-x) #'())) (rng-proj-x ...) - (this-parameter ... dom-formals ... . #,(if rst #'rst-formal '())) + rng-ctcs-x + (this-parameter ... dom-formals ... . #,(if rst-ctc-expr #'rst-formal '())) #,(cond - [rng + [rng-ctc-exprs (let ([rng-checkers (list #`(case-lambda [(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)] @@ -81,19 +83,21 @@ #,(length (syntax->list #'(rng-id ...))) args #,n)]))] - [rng-length (length (syntax->list rng))]) - (if rst - (check-tail-contract #'(rng-proj-x ...) rng-checkers + [rng-length (length (syntax->list rng-ctc-exprs))]) + (if rst-ctc-expr + (check-tail-contract #'rng-ctcs-x + blame-party-info neg-party + rng-checkers (λ (rng-checks) #`(apply values #,@rng-checks this-parameter ... (dom-proj-x dom-formals neg-party) ... (rst-proj-x rst-formal neg-party)))) (check-tail-contract - #'(rng-proj-x ...) rng-checkers + #'rng-ctcs-x blame-party-info neg-party rng-checkers (λ (rng-checks) #`(values/drop #,@rng-checks this-parameter ... (dom-proj-x dom-formals neg-party) ...)))))] - [rst + [rst-ctc-expr #`(apply values this-parameter ... (dom-proj-x dom-formals neg-party) ... (rst-proj-x rst-formal neg-party))] @@ -106,30 +110,33 @@ [(_ cases ...) (let () (define name (syntax-local-infer-name stx)) - (with-syntax ([(((dom-proj ...) - rst-proj - rng-proj + (with-syntax ([(((dom-ctc-expr ...) + rst-ctc-expr + rng-ctc-exprs spec (dom-proj-x ...) (rng-proj-x ...) + rng-ctcs-x formals body) ...) (for/list ([x (in-list (syntax->list #'(cases ...)))] [n (in-naturals)]) - (parse-out-case stx x n))] + (parse-out-case stx #'neg-party #'blame-party-info x n))] [mctc? (and (syntax-parameter-value #'method-contract?) #t)]) #`(syntax-parameterize ((making-a-method #f)) (build-case-> - (list (list dom-proj ...) ...) - (list rst-proj ...) - (list rng-proj ...) + (list (list dom-ctc-expr ...) ...) + (list rst-ctc-expr ...) + (list rng-ctc-exprs ...) '(spec ...) mctc? (λ (chk wrapper blame + blame-party-info ctc + rng-ctcs-x ... #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) (λ (f neg-party) @@ -139,12 +146,12 @@ (if name #`(let ([#,name #,case-lam]) #,name) case-lam)) - (list (list rng-proj-x ...) ...) - f blame neg-party wrapper ctc + f blame neg-party blame-party-info wrapper ctc chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))])) -(define (put-it-together the-case-lam range-projections f blame neg-party wrapper ctc chk mtd?) +(define (put-it-together the-case-lam f blame neg-party blame-party-info wrapper ctc chk mtd?) (chk f mtd?) + (define rng-ctcs (base-case->-rng-ctcs ctc)) (define checker (make-keyword-procedure (raise-no-keywords-error f blame neg-party) @@ -152,14 +159,15 @@ (with-contract-continuation-mark (cons blame neg-party) (apply the-case-lam args))))) - (define same-rngs (same-range-projections range-projections)) + (define same-rngs (same-range-contracts rng-ctcs)) (if same-rngs (wrapper f checker impersonator-prop:contracted ctc impersonator-prop:blame (blame-add-missing-party blame neg-party) - impersonator-prop:application-mark (cons contract-key same-rngs)) + impersonator-prop:application-mark + (cons tail-contract-key (list* neg-party blame-party-info same-rngs))) (wrapper f checker @@ -184,13 +192,17 @@ (define (case->-proj wrapper) (λ (ctc) (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc)) - (define rng-late-neg-ctcs (map get/build-late-neg-projection (get-case->-rng-ctcs ctc))) + (define rng-ctcs (get-case->-rng-ctcs ctc)) + (define rng-lol-ctcs (base-case->-rng-ctcs ctc)) + (define rng-late-neg-ctcs (map get/build-late-neg-projection rng-ctcs)) (define rst-ctcs (base-case->-rst-ctcs ctc)) (define specs (base-case->-specs ctc)) (λ (blame) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) (define rng-blame (blame-add-context blame "the range of")) - (define projs (append (map (λ (f) ((cdr f) + (define blame-party-info (get-blame-party-info blame)) + (define projs (append rng-lol-ctcs + (map (λ (f) ((cdr f) (blame-add-context (blame-add-context blame @@ -231,6 +243,7 @@ chk wrapper blame + blame-party-info ctc projs)))) @@ -303,18 +316,23 @@ (define (get-case->-rng-ctcs ctc) (for/fold ([acc '()]) - ([x (in-list (base-case->-rng-ctcs ctc))] - #:when x) + ([x (in-list (base-case->-rng-ctcs ctc))] + #:when x) (append acc x))) ;; Takes a list of (listof projection), and returns one of the ;; lists if all the lists contain the same projections. If the list is ;; null, it returns #f. -(define (same-range-projections rng-ctcss) - (if (null? rng-ctcss) - #f - (let* ([fst (car rng-ctcss)] - [all-same? (for/and ([ps (in-list (cdr rng-ctcss))]) - (and (= (length fst) (length ps)) - (andmap procedure-closure-contents-eq? fst ps)))]) - (and all-same? fst)))) +(define (same-range-contracts rng-ctcss) + (cond + [(null? rng-ctcss) #f] + [else + (define fst (car rng-ctcss)) + (and (for/and ([ps (in-list (cdr rng-ctcss))]) + (and ps + (= (length fst) (length ps)) + (for/and ([c (in-list ps)] + [fst-c (in-list fst)]) + (and (contract-stronger? c fst-c) + (contract-stronger? fst-c c))))) + fst)])) diff --git a/racket/collects/racket/contract/private/opt-guts.rkt b/racket/collects/racket/contract/private/opt-guts.rkt index aca87b6150..9ac523fe3a 100644 --- a/racket/collects/racket/contract/private/opt-guts.rkt +++ b/racket/collects/racket/contract/private/opt-guts.rkt @@ -23,6 +23,7 @@ opt/info-add-blame-context opt/info-change-val opt/info-positive-blame + opt/info-negative-blame opt/unknown opt-error-name @@ -164,6 +165,10 @@ (if (opt/info-swap-blame? oi) #`(blame-positive #,(opt/info-blame-original-id oi)) #`(blame-negative #,(opt/info-blame-original-id oi)))) +(define (opt/info-negative-blame oi) + (if (opt/info-swap-blame? oi) + #`(blame-negative #,(opt/info-blame-original-id oi)) + #`(blame-positive #,(opt/info-blame-original-id oi)))) ;; opt/info-swap-blame : opt/info -> opt/info ;; swaps pos and neg diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index d1e0104929..64c4e97b25 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -576,7 +576,9 @@ (syntax-case stx () [(x) #'x] [(x ...) #'(values x ...)])) - #`(let* ([cont-mark-value (cons #,(opt/info-positive-blame opt/info) '#,rngs)] + #`(let* ([cont-mark-value (list* #,(opt/info-positive-blame opt/info) + #,(opt/info-negative-blame opt/info) + '#,rngs)] [exact-proc (case-lambda [(dom-arg ...) (let-values ([(rng-checker dom-vars ...) diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index 4964594e3e..89b2ad36b0 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -115,42 +115,50 @@ (define trail (make-parameter #f)) (define (contract-struct-stronger? a b) - (define prop (contract-struct-property a)) - (define stronger? (contract-property-stronger prop)) (cond - [(let ([th (trail)]) - (and th - (for/or ([(a2 bs-h) (in-hash th)]) - (and (eq? a a2) - (for/or ([(b2 _) (in-hash bs-h)]) - (eq? b b2)))))) - #t] - [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) - (parameterize ([trail (or (trail) (make-hasheq))]) - (define trail-h (trail)) - (let ([a-h (hash-ref trail-h a #f)]) - (cond - [a-h - (hash-set! a-h b #t)] - [else - (define a-h (make-hasheq)) - (hash-set! trail-h a a-h) - (hash-set! a-h b #t)])) - (contract-struct-stronger? (if (prop:recursive-contract? a) - ((prop:recursive-contract-unroll a) a) - a) - (if (prop:recursive-contract? b) - ((prop:recursive-contract-unroll b) b) - b)))] + [(equal? a b) #t] [else - (let loop ([b b]) - (cond - [(stronger? a b) #t] - [(prop:orc-contract? b) - (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) - (for/or ([sub-contract (in-list sub-contracts)]) - (loop sub-contract))] - [else #f]))])) + (define prop (contract-struct-property a)) + (define stronger? (contract-property-stronger prop)) + (cond + [(stronger? a b) + ;; optimistically try skip some of the more complex work below + #t] + [(let ([th (trail)]) + (and th + (for/or ([(a2 bs-h) (in-hash th)]) + (and (eq? a a2) + (for/or ([(b2 _) (in-hash bs-h)]) + (eq? b b2)))))) + #t] + [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) + (parameterize ([trail (or (trail) (make-hasheq))]) + (define trail-h (trail)) + (let ([a-h (hash-ref trail-h a #f)]) + (cond + [a-h + (hash-set! a-h b #t)] + [else + (define a-h (make-hasheq)) + (hash-set! trail-h a a-h) + (hash-set! a-h b #t)])) + (contract-struct-stronger? (if (prop:recursive-contract? a) + ((prop:recursive-contract-unroll a) a) + a) + (if (prop:recursive-contract? b) + ((prop:recursive-contract-unroll b) b) + b)))] + [else + (let loop ([b b]) + (cond + [(stronger? a b) + #t] + [(prop:orc-contract? b) + (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) + (for/or ([sub-contract (in-list sub-contracts)]) + (loop sub-contract))] + [else + #f]))])])) (define (contract-struct-generate c) (define prop (contract-struct-property c))