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

generalize tail contract checking for function contracts

Browse Source 
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.
This commit is contained in:
Robby Findler 2015-12-25 22:31:30 -06:00
parent f0f85549ce
commit d927d04efd
10 changed files with 266 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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 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 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 was passed as the second argument to @racket[contract-stronger?]. If no
@racket[stronger] argument is supplied, then a default that always returns @racket[stronger] argument is supplied, then a default that compares its arguments
@racket[#f] is used. with @racket[equal?] is used.
The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate 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. 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 Returns @racket[#t] if the contract @racket[x] accepts either fewer
or the same number of values as @racket[y] does. 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 This function is conservative, so it may return @racket[#f] when
@racket[x] does, in fact, accept fewer values. @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 0 100) (between/c 25 75))
(contract-stronger? (between/c -10 0) (between/c 0 10)) (contract-stronger? (between/c -10 0) (between/c 0 10))
(contract-stronger? (λ (x) (and (real? x) (<= x (random 10)))) (contract-stronger? (λ (x) (and (real? x) (<= x 0)))
(λ (x) (and (real? x) (<= x (+ 100 (random 10))))))] (λ (x) (and (real? x) (<= x 100))))]
} }

15
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -340,6 +340,21 @@
;; pass; this is fixed in a separate branch that can't ;; pass; this is fixed in a separate branch that can't
(regexp-match #rx"expected:? keyword argument #:the-missing-keyword-arg-b" (regexp-match #rx"expected:? keyword argument #:the-missing-keyword-arg-b"
(exn-message x))))) (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 (test/pos-blame
'predicate/c1 'predicate/c1

23
pkgs/racket-test/tests/racket/contract/tail.rkt
View File

@ -85,6 +85,29 @@
(c))) (c)))
(ctest/rewrite '(1) (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 mut-rec-with-any/c
(let () (let ()
(define f (define f

35
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -32,15 +32,15 @@
[(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)] [(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)]
[(rng-proj ...) (if rngs (generate-temporaries rngs) '())] [(rng-proj ...) (if rngs (generate-temporaries rngs) '())]
[(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())]) [(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())])
#`(λ (blame f neg-party #`(λ (blame f neg-party blame-party-info rng-ctcs
mandatory-dom-proj ... mandatory-dom-proj ...
optional-dom-proj ... optional-dom-proj ...
rest-proj ... rest-proj ...
mandatory-dom-kwd-proj ... mandatory-dom-kwd-proj ...
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
#,(create-chaperone #,(create-chaperone
#'blame #'f #'blame #'neg-party #'blame-party-info #'f #'rng-ctcs
this-args this-args
(syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(mandatory-dom-proj ...))
(syntax->list #'(optional-dom-proj ...)) (syntax->list #'(optional-dom-proj ...))
@ -114,7 +114,8 @@
(if pre? "pre" "post") (if pre? "pre" "post")
condition-result)])) 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 this-args
doms opt-doms doms opt-doms
req-kwds opt-kwds req-kwds opt-kwds
@ -150,7 +151,7 @@
[(opt-kwd ...) (map car opt-kwds)] [(opt-kwd ...) (map car opt-kwds)]
[(opt-kwd-ctc ...) (map cadr opt-kwds)] [(opt-kwd-ctc ...) (map cadr opt-kwds)]
[(opt-kwd-x ...) (generate-temporaries (map car 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) '())]) [(rng-x ...) (if rngs (generate-temporaries rngs) '())])
(with-syntax ([(rng-checker-name ...) (with-syntax ([(rng-checker-name ...)
(if rngs (if rngs
@ -161,7 +162,7 @@
(list (list
(with-syntax ([rng-len (length rngs)]) (with-syntax ([rng-len (length rngs)])
(with-syntax ([rng-results (with-syntax ([rng-results
#'(values (rng-ctc rng-x neg-party) #'(values (rng-late-neg-projs rng-x neg-party)
...)]) ...)])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
@ -248,7 +249,9 @@
dom-projd-args ...)))]) dom-projd-args ...)))])
(if no-rng-checking? (if no-rng-checking?
(inner-stx-gen #'()) (inner-stx-gen #'())
(arrow:check-tail-contract #'(rng-ctc ...) (arrow:check-tail-contract rng-ctcs
blame-party-info
neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
inner-stx-gen)))] inner-stx-gen)))]
[kwd-return [kwd-return
@ -273,7 +276,9 @@
#`(let ([kwd-results kwd-stx]) #`(let ([kwd-results kwd-stx])
#,(if no-rng-checking? #,(if no-rng-checking?
(outer-stx-gen #'()) (outer-stx-gen #'())
(arrow:check-tail-contract #'(rng-ctc ...) (arrow:check-tail-contract rng-ctcs
blame-party-info
neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
outer-stx-gen))))]) outer-stx-gen))))])
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
@ -398,12 +403,15 @@
man-then-opt-partial-kwds man-then-opt-partial-kwds
partial-ranges partial-ranges
(if partial-rest (list partial-rest) '()))) (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 (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 (cond
[chap/imp-func [chap/imp-func
(if post? (if (or post? (not rngs))
(chaperone-or-impersonate-procedure (chaperone-or-impersonate-procedure
val val
chap/imp-func chap/imp-func
@ -414,9 +422,8 @@
chap/imp-func chap/imp-func
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party) impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:application-mark (cons arrow:contract-key impersonator-prop:application-mark
;; is this right? (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))]
partial-ranges)))]
[else val])) [else val]))
(cond (cond

10
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -895,7 +895,7 @@
optional-keywords optional-keywords
(and rest-contract #t) (and rest-contract #t)
rng-len) rng-len)
(λ (blame f neg-party . args) (λ (blame f neg-party blame-party-info rng-ctc-x . args)
(define-next next args) (define-next next args)
(define mandatory-dom-projs (next min-arity)) (define mandatory-dom-projs (next min-arity))
(define optional-dom-projs (next optionals)) (define optional-dom-projs (next optionals))
@ -1242,7 +1242,7 @@
(make--> 0 '() '() #f #f (make--> 0 '() '() #f #f
(list (coerce-contract 'whatever void?)) (list (coerce-contract 'whatever void?))
#f #f
(λ (blame f _ignored-rng-contract) (λ (blame f _ignored-rng-ctcs _ignored-rng-proj)
(λ (neg-party) (λ (neg-party)
(call-with-values (call-with-values
(λ () (f)) (λ () (f))
@ -1276,7 +1276,11 @@
(call-with-values (call-with-values
(λ () (f argument)) (λ () (f argument))
(rng-checker f blame neg-party)))) (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) (unless (procedure? f)
(raise-blame-error (raise-blame-error
blame #:missing-party neg-party f blame #:missing-party neg-party f

127
racket/collects/racket/contract/private/arrow.rkt
View File

@ -32,8 +32,9 @@
(for-syntax check-tail-contract (for-syntax check-tail-contract
make-this-parameters make-this-parameters
parse-leftover->*) parse-leftover->*)
contract-key tail-contract-key
tail-marks-match? tail-marks-match?
get-blame-party-info
values/drop values/drop
arity-checking-wrapper arity-checking-wrapper
unspecified-dom unspecified-dom
@ -49,34 +50,51 @@
(list id) (list id)
null)) 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 #`(call-with-immediate-continuation-mark
contract-key tail-contract-key
(λ (m) (λ (m)
(if (tail-marks-match? m . #,rng-ctcs) (if (tail-marks-match? m #,rng-ctcs #,blame-party-info #,neg-party)
#,(call-gen #'()) #,(call-gen #'())
#,(call-gen rng-checkers))))) #,(call-gen rng-checkers)))))
(begin-encourage-inline ;; m : (or/c #f (cons/c neg-party (cons/c (list/c pos-party boolean?[blame-swapped?]) (listof ctc))))
(define tail-marks-match? ;; rng-ctc : (or/c #f (listof ctc))
(case-lambda ;; blame-party-info : (list/c pos-party boolean?[blame-swapped?])
[(m) (and m (null? m))] ;; neg-party : neg-party
[(m rng-ctc) (define (tail-marks-match? m rng-ctcs blame-party-info neg-party)
(and m (and m
(not (null? m)) rng-ctcs
(null? (cdr m)) (eq? (car m) neg-party)
(procedure-closure-contents-eq? (car m) rng-ctc))] (let ([mark-blame-part-info (cadr m)])
[(m rng-ctc1 rng-ctc2) (and (eq? (car mark-blame-part-info) (car blame-party-info))
(and m (eq? (cadr mark-blame-part-info) (cadr blame-party-info))))
(= (length m) 2) (let loop ([m (cddr m)]
(procedure-closure-contents-eq? (car m) rng-ctc1) [rng-ctcs rng-ctcs])
(procedure-closure-contents-eq? (cadr m) rng-ctc1))] (cond
[(m . rng-ctcs) [(null? m) (null? rng-ctcs)]
(and m [(null? rng-ctcs) (null? m)]
(= (length m) (length rng-ctcs)) [else
(andmap procedure-closure-contents-eq? m rng-ctcs))]))) (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) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
@ -86,9 +104,11 @@
[(p-app-x ...) (generate-temporaries #'(rngs ...))] [(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#`(let ([rngs-x (coerce-contract 'unconstrained-domain-> 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) (define (projection wrapper get-ctc)
(λ (orig-blame) (λ (orig-blame)
(define blame-party-info (get-blame-party-info orig-blame))
(define ctc (get-ctc)) (define ctc (get-ctc))
(let ([rng-blame (blame-add-range-context orig-blame)]) (let ([rng-blame (blame-add-range-context orig-blame)])
(let* ([p-app-x (proj-x rng-blame)] ...) (let* ([p-app-x (proj-x rng-blame)] ...)
@ -102,19 +122,23 @@
(with-contract-continuation-mark (with-contract-continuation-mark
(cons orig-blame neg-party) (cons orig-blame neg-party)
#,(check-tail-contract #,(check-tail-contract
#'(p-app-x ...) #'rngs-list
#'blame-party-info
#'neg-party
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s kwd-vals args))))) (λ (s) #`(apply values #,@s kwd-vals args)))))
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
(cons orig-blame neg-party) (cons orig-blame neg-party)
#,(check-tail-contract #,(check-tail-contract
#'(p-app-x ...) #'rngs-list
#'blame-party-info
#'neg-party
(list #'res-checker) (list #'res-checker)
(λ (s) #`(apply values #,@s args)))))) (λ (s) #`(apply values #,@s args))))))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:application-mark 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 ...) (make-unconstrained-domain-> (list rngs-x ...)
projection))))])) projection))))]))
@ -200,9 +224,9 @@
(loop (cdr accepted) req-kwds (cdr opt-kwds))] (loop (cdr accepted) req-kwds (cdr opt-kwds))]
[else #f]))]))) [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 doms opt-doms dom-rest req-kwds opt-kwds
rngs) rngs rng-ctc-id)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[neg-party neg-party] [neg-party neg-party]
[val val]) [val val])
@ -318,7 +342,9 @@
(dom-ctc dom-x neg-party) ...)))]) (dom-ctc dom-x neg-party) ...)))])
(if no-rng-checking? (if no-rng-checking?
(inner-stx-gen #'()) (inner-stx-gen #'())
(check-tail-contract #'(rng-ctc ...) (check-tail-contract rng-ctc-id
blame-party-info
#'neg-party
#'(rng-checker-name ...) #'(rng-checker-name ...)
inner-stx-gen)))] inner-stx-gen)))]
[kwd-return [kwd-return
@ -340,7 +366,11 @@
#`(let ([kwd-results kwd-stx]) #`(let ([kwd-results kwd-stx])
#,(if no-rng-checking? #,(if no-rng-checking?
(outer-stx-gen #'()) (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)] (with-syntax ([basic-lambda-name (gen-id 'basic-lambda)]
[basic-lambda #'(λ basic-params [basic-lambda #'(λ basic-params
;; Arrow contract domain checking is instrumented ;; Arrow contract domain checking is instrumented
@ -534,7 +564,8 @@
(append (base->-doms/c ctc) (list (base->-dom-rest/c ctc))) (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc)))
(base->-doms/c ctc)))] (base->-doms/c ctc)))]
[doms-optional-proj (map get/build-late-neg-projection (base->-optional-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))] [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))] [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))]
[mandatory-keywords (base->-mandatory-kwds ctc)] [mandatory-keywords (base->-mandatory-kwds ctc)]
@ -578,16 +609,18 @@
(kwd-proj (blame-add-context orig-blame (kwd-proj (blame-add-context orig-blame
(format "the ~a argument of" kwd) (format "the ~a argument of" kwd)
#:swap? #t)))) #:swap? #t))))
(define the-args (append partial-doms partial-optional-doms (define the-args (cons rngs-ctc
partial-mandatory-kwds partial-optional-kwds (append partial-doms partial-optional-doms
partial-ranges)) partial-mandatory-kwds partial-optional-kwds
partial-ranges)))
(define blame-party-info (get-blame-party-info orig-blame))
(λ (val neg-party) (λ (val neg-party)
(if has-rest? (if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords
orig-blame neg-party) orig-blame neg-party)
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords
orig-blame neg-party)) 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 (if post
(wrapper (wrapper
val val
@ -597,9 +630,8 @@
val val
chap/imp-func chap/imp-func
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:application-mark (cons contract-key impersonator-prop:application-mark
;; is this right? (cons tail-contract-key (list* neg-party blame-party-info rngs-ctc))))))))
partial-ranges)))))))
(define (->-name ctc) (define (->-name ctc)
(single-arrow-name-maker (single-arrow-name-maker
@ -811,19 +843,22 @@
[(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->)) [(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->))
(syntax->list kwd-ctcs))] (syntax->list kwd-ctcs))]
[(kwds ...) kwds] [(kwds ...) kwds]
[(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
[outer-lambda [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 #,(create-chaperone
#'blame #'neg-party #'val #f #f #'blame #'neg-party #'blame-party-info #'val #f #f
(syntax->list #'(this-params ...)) (syntax->list #'(this-params ...))
(syntax->list #'(dom-names ...)) null #f (syntax->list #'(dom-names ...)) null #f
(map list (syntax->list #'(kwds ...)) (map list (syntax->list #'(kwds ...))
(syntax->list #'(kwd-names ...))) (syntax->list #'(kwd-names ...)))
null 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-property
(syntax/loc stx (syntax/loc stx
(build--> '-> (build--> '->
@ -976,6 +1011,7 @@
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
[(rng-proj ...) (generate-temporaries (or rng-ctc '()))] [(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
[(rng ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))]
[(rng-ctc-x) (generate-temporaries '(rng-ctc-x))]
[(this-parameter ...) [(this-parameter ...)
(make-this-parameters (car (generate-temporaries '(this))))]) (make-this-parameters (car (generate-temporaries '(this))))])
(quasisyntax/loc stx (quasisyntax/loc stx
@ -996,7 +1032,7 @@
#''()) #''())
#,(if rng-ctc #f #t) #,(if rng-ctc #f #t)
mtd? ->m-ctc? mtd? ->m-ctc?
(λ (blame neg-party f (λ (blame neg-party blame-party-info f rng-ctc-x
mandatory-dom-proj ... mandatory-dom-proj ...
#,@(if rest-ctc #,@(if rest-ctc
#'(rest-proj) #'(rest-proj)
@ -1006,7 +1042,7 @@
optional-dom-kwd-proj ... optional-dom-kwd-proj ...
rng-proj ...) rng-proj ...)
#,(create-chaperone #,(create-chaperone
#'blame #'neg-party #'f pre post #'blame #'neg-party #'blame-party-info #'f pre post
(syntax->list #'(this-parameter ...)) (syntax->list #'(this-parameter ...))
(syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(mandatory-dom-proj ...))
(syntax->list #'(optional-dom-proj ...)) (syntax->list #'(optional-dom-proj ...))
@ -1015,7 +1051,8 @@
(syntax->list #'(mandatory-dom-kwd-proj ...))) (syntax->list #'(mandatory-dom-kwd-proj ...)))
(map list (syntax->list #'(optional-dom-kwd ...)) (map list (syntax->list #'(optional-dom-kwd ...))
(syntax->list #'(optional-dom-kwd-proj ...))) (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) (define (convert-pre-post/desc-to-boolean pre? b)
(cond (cond

104
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -52,27 +52,29 @@
[_ [_
(raise-syntax-error #f "expected ->" stx case)])) (raise-syntax-error #f "expected ->" stx case)]))
(define-for-syntax (parse-out-case stx case n) (define-for-syntax (parse-out-case stx neg-party blame-party-info case n)
(let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)]) (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 doms)] (with-syntax ([(dom-proj-x ...) (generate-temporaries dom-ctc-exprs)]
[(rst-proj-x) (generate-temporaries '(rest-proj-x))] [(rst-proj-x) (generate-temporaries '(rest-proj-x))]
[(rng-proj-x ...) (generate-temporaries (if rng rng '()))]) [(rng-proj-x ...) (generate-temporaries (if rng-ctc-exprs rng-ctc-exprs '()))]
(with-syntax ([(dom-formals ...) (generate-temporaries doms)] [(rng-ctcs-x) (generate-temporaries '(rng-ctc-x))])
(with-syntax ([(dom-formals ...) (generate-temporaries dom-ctc-exprs)]
[(rst-formal) (generate-temporaries '(rest-param))] [(rst-formal) (generate-temporaries '(rest-param))]
[(rng-id ...) (if rng [(rng-id ...) (if rng-ctc-exprs
(generate-temporaries rng) (generate-temporaries rng-ctc-exprs)
'())] '())]
[(this-parameter ...) [(this-parameter ...)
(make-this-parameters (car (generate-temporaries '(this))))]) (make-this-parameters (car (generate-temporaries '(this))))])
#`(#,doms #`(#,dom-ctc-exprs
#,rst #,rst-ctc-expr
#,(if rng #`(list #,@rng) #f) #,(if rng-ctc-exprs #`(list #,@rng-ctc-exprs) #f)
#,(length (syntax->list doms)) ;; spec #,(length (syntax->list dom-ctc-exprs)) ;; spec
(dom-proj-x ... #,@(if rst #'(rst-proj-x) #'())) (dom-proj-x ... #,@(if rst-ctc-expr #'(rst-proj-x) #'()))
(rng-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 #,(cond
[rng [rng-ctc-exprs
(let ([rng-checkers (let ([rng-checkers
(list #`(case-lambda (list #`(case-lambda
[(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)] [(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)]
@ -81,19 +83,21 @@
#,(length (syntax->list #'(rng-id ...))) #,(length (syntax->list #'(rng-id ...)))
args args
#,n)]))] #,n)]))]
[rng-length (length (syntax->list rng))]) [rng-length (length (syntax->list rng-ctc-exprs))])
(if rst (if rst-ctc-expr
(check-tail-contract #'(rng-proj-x ...) rng-checkers (check-tail-contract #'rng-ctcs-x
blame-party-info neg-party
rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(apply values #,@rng-checks this-parameter ... #`(apply values #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ... (dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal neg-party)))) (rst-proj-x rst-formal neg-party))))
(check-tail-contract (check-tail-contract
#'(rng-proj-x ...) rng-checkers #'rng-ctcs-x blame-party-info neg-party rng-checkers
(λ (rng-checks) (λ (rng-checks)
#`(values/drop #,@rng-checks this-parameter ... #`(values/drop #,@rng-checks this-parameter ...
(dom-proj-x dom-formals neg-party) ...)))))] (dom-proj-x dom-formals neg-party) ...)))))]
[rst [rst-ctc-expr
#`(apply values this-parameter ... #`(apply values this-parameter ...
(dom-proj-x dom-formals neg-party) ... (dom-proj-x dom-formals neg-party) ...
(rst-proj-x rst-formal neg-party))] (rst-proj-x rst-formal neg-party))]
@ -106,30 +110,33 @@
[(_ cases ...) [(_ cases ...)
(let () (let ()
(define name (syntax-local-infer-name stx)) (define name (syntax-local-infer-name stx))
(with-syntax ([(((dom-proj ...) (with-syntax ([(((dom-ctc-expr ...)
rst-proj rst-ctc-expr
rng-proj rng-ctc-exprs
spec spec
(dom-proj-x ...) (dom-proj-x ...)
(rng-proj-x ...) (rng-proj-x ...)
rng-ctcs-x
formals formals
body) ...) body) ...)
(for/list ([x (in-list (syntax->list #'(cases ...)))] (for/list ([x (in-list (syntax->list #'(cases ...)))]
[n (in-naturals)]) [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)]) [mctc? (and (syntax-parameter-value #'method-contract?) #t)])
#`(syntax-parameterize #`(syntax-parameterize
((making-a-method #f)) ((making-a-method #f))
(build-case-> (build-case->
(list (list dom-proj ...) ...) (list (list dom-ctc-expr ...) ...)
(list rst-proj ...) (list rst-ctc-expr ...)
(list rng-proj ...) (list rng-ctc-exprs ...)
'(spec ...) '(spec ...)
mctc? mctc?
(λ (chk (λ (chk
wrapper wrapper
blame blame
blame-party-info
ctc ctc
rng-ctcs-x ...
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f neg-party) (λ (f neg-party)
@ -139,12 +146,12 @@
(if name (if name
#`(let ([#,name #,case-lam]) #,name) #`(let ([#,name #,case-lam]) #,name)
case-lam)) case-lam))
(list (list rng-proj-x ...) ...) f blame neg-party blame-party-info wrapper ctc
f blame neg-party wrapper ctc
chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))])) 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?) (chk f mtd?)
(define rng-ctcs (base-case->-rng-ctcs ctc))
(define checker (define checker
(make-keyword-procedure (make-keyword-procedure
(raise-no-keywords-error f blame neg-party) (raise-no-keywords-error f blame neg-party)
@ -152,14 +159,15 @@
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(apply the-case-lam args))))) (apply the-case-lam args)))))
(define same-rngs (same-range-projections range-projections)) (define same-rngs (same-range-contracts rng-ctcs))
(if same-rngs (if same-rngs
(wrapper (wrapper
f f
checker checker
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party) 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 (wrapper
f f
checker checker
@ -184,13 +192,17 @@
(define (case->-proj wrapper) (define (case->-proj wrapper)
(λ (ctc) (λ (ctc)
(define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums 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 rst-ctcs (base-case->-rst-ctcs ctc))
(define specs (base-case->-specs ctc)) (define specs (base-case->-specs ctc))
(λ (blame) (λ (blame)
(define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(define rng-blame (blame-add-context blame "the range of")) (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-add-context (blame-add-context
blame blame
@ -231,6 +243,7 @@
chk chk
wrapper wrapper
blame blame
blame-party-info
ctc ctc
projs)))) projs))))
@ -303,18 +316,23 @@
(define (get-case->-rng-ctcs ctc) (define (get-case->-rng-ctcs ctc)
(for/fold ([acc '()]) (for/fold ([acc '()])
([x (in-list (base-case->-rng-ctcs ctc))] ([x (in-list (base-case->-rng-ctcs ctc))]
#:when x) #:when x)
(append acc x))) (append acc x)))
;; Takes a list of (listof projection), and returns one of the ;; Takes a list of (listof projection), and returns one of the
;; lists if all the lists contain the same projections. If the list is ;; lists if all the lists contain the same projections. If the list is
;; null, it returns #f. ;; null, it returns #f.
(define (same-range-projections rng-ctcss) (define (same-range-contracts rng-ctcss)
(if (null? rng-ctcss) (cond
#f [(null? rng-ctcss) #f]
(let* ([fst (car rng-ctcss)] [else
[all-same? (for/and ([ps (in-list (cdr rng-ctcss))]) (define fst (car rng-ctcss))
(and (= (length fst) (length ps)) (and (for/and ([ps (in-list (cdr rng-ctcss))])
(andmap procedure-closure-contents-eq? fst ps)))]) (and ps
(and all-same? fst)))) (= (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)]))

5
racket/collects/racket/contract/private/opt-guts.rkt
View File

@ -23,6 +23,7 @@
opt/info-add-blame-context opt/info-add-blame-context
opt/info-change-val opt/info-change-val
opt/info-positive-blame opt/info-positive-blame
opt/info-negative-blame
opt/unknown opt/unknown
opt-error-name opt-error-name
@ -164,6 +165,10 @@
(if (opt/info-swap-blame? oi) (if (opt/info-swap-blame? oi)
#`(blame-positive #,(opt/info-blame-original-id oi)) #`(blame-positive #,(opt/info-blame-original-id oi))
#`(blame-negative #,(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 ;; opt/info-swap-blame : opt/info -> opt/info
;; swaps pos and neg ;; swaps pos and neg

4
racket/collects/racket/contract/private/opters.rkt
View File

@ -576,7 +576,9 @@
(syntax-case stx () (syntax-case stx ()
[(x) #'x] [(x) #'x]
[(x ...) #'(values 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 [exact-proc (case-lambda
[(dom-arg ...) [(dom-arg ...)
(let-values ([(rng-checker dom-vars ...) (let-values ([(rng-checker dom-vars ...)

76
racket/collects/racket/contract/private/prop.rkt
View File

@ -115,42 +115,50 @@
(define trail (make-parameter #f)) (define trail (make-parameter #f))
(define (contract-struct-stronger? a b) (define (contract-struct-stronger? a b)
(define prop (contract-struct-property a))
(define stronger? (contract-property-stronger prop))
(cond (cond
[(let ([th (trail)]) [(equal? a b) #t]
(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 [else
(let loop ([b b]) (define prop (contract-struct-property a))
(cond (define stronger? (contract-property-stronger prop))
[(stronger? a b) #t] (cond
[(prop:orc-contract? b) [(stronger? a b)
(define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) ;; optimistically try skip some of the more complex work below
(for/or ([sub-contract (in-list sub-contracts)]) #t]
(loop sub-contract))] [(let ([th (trail)])
[else #f]))])) (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 (contract-struct-generate c)
(define prop (contract-struct-property c)) (define prop (contract-struct-property c))