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

improve the performance of the way contract-stronger? recurs

Browse Source 
and fix evt/c's contract-stronger
This commit is contained in:
Robby Findler 2016-01-04 17:16:58 -06:00
parent d37ee8c5b1
commit 14b951cf44
12 changed files with 85 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -444,6 +444,9 @@
(ctest #f contract-stronger?
(implementation?/c one-interface<%>)
(implementation?/c another-interface<%>))
(ctest #t contract-stronger? (evt/c integer?) (evt/c integer?))
(ctest #f contract-stronger? (evt/c integer?) (evt/c boolean?))
;; chances are, this predicate will accept "x", but
;; we don't want to consider it stronger, since it

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

@ -1208,18 +1208,18 @@
(= (length (base->-doms that))
(length (base->-doms this)))
(= (base->-min-arity this) (base->-min-arity that))
(andmap contract-stronger? (base->-doms that) (base->-doms this))
(andmap contract-struct-stronger? (base->-doms that) (base->-doms this))
(= (length (base->-kwd-infos this))
(length (base->-kwd-infos that)))
(for/and ([this-kwd-info (base->-kwd-infos this)]
[that-kwd-info (base->-kwd-infos that)])
(and (equal? (kwd-info-kwd this-kwd-info)
(kwd-info-kwd that-kwd-info))
(contract-stronger? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(contract-struct-stronger? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(if (base->-rngs this)
(and (base->-rngs that)
(andmap contract-stronger? (base->-rngs this) (base->-rngs that)))
(andmap contract-struct-stronger? (base->-rngs this) (base->-rngs that)))
(not (base->-rngs that)))
(not (base->-pre? this))
(not (base->-pre? that))

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

@ -662,16 +662,16 @@
(define (->-stronger? this that)
(and (base->? that)
(= (length (base->-doms/c that)) (length (base->-doms/c this)))
(andmap contract-stronger? (base->-doms/c that) (base->-doms/c this))
(andmap contract-struct-stronger? (base->-doms/c that) (base->-doms/c this))
(equal? (base->-mandatory-kwds this) (base->-mandatory-kwds that))
(andmap contract-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this))
(andmap contract-struct-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this))
(equal? (base->-optional-kwds this) (base->-optional-kwds that))
(andmap contract-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this))
(andmap contract-struct-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this))
(= (length (base->-rngs/c that)) (length (base->-rngs/c this)))
(andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that))
(andmap contract-struct-stronger? (base->-rngs/c this) (base->-rngs/c that))
;; these procs might be based on state; only
;; allow stronger to be true when #:pre and

6
racket/collects/racket/contract/private/box.rkt
View File

@ -99,11 +99,11 @@
(cond
[(and (equal? this-immutable #t)
(equal? that-immutable #t))
(contract-stronger? this-content-r that-content-r)]
(contract-struct-stronger? this-content-r that-content-r)]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(and (contract-stronger? this-content-r that-content-r)
(contract-stronger? that-content-w this-content-w))]
(and (contract-struct-stronger? this-content-r that-content-r)
(contract-struct-stronger? that-content-w this-content-w))]
[else #f])]
[else #f]))

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

@ -333,6 +333,6 @@
(= (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)))))
(and (contract-struct-stronger? c fst-c)
(contract-struct-stronger? fst-c c)))))
fst)]))

6
racket/collects/racket/contract/private/ds.rkt
View File

@ -235,7 +235,7 @@ it around flattened out.
[b-sel (contract-get b selector-indices)])
(if (contract-struct? a-sel)
(if (contract-struct? b-sel)
(contract-stronger? a-sel b-sel)
(contract-struct-stronger? a-sel b-sel)
#f)
(if (contract-struct? b-sel)
#f
@ -275,8 +275,8 @@ it around flattened out.
(let ([old-contract/info (wrap-get val 1)])
(if (and (equal? (contract/info-blame new-contract/info)
(contract/info-blame old-contract/info))
(contract-stronger? (contract/info-contract old-contract/info)
(contract/info-contract new-contract/info)))
(contract-struct-stronger? (contract/info-contract old-contract/info)
(contract/info-contract new-contract/info)))
#t
(already-there? new-contract/info (wrap-get val 0) (- depth 1)))))]
[else

12
racket/collects/racket/contract/private/hash.rkt
View File

@ -168,14 +168,14 @@
(cond
[(and (equal? this-immutable #t)
(equal? that-immutable #t))
(and (contract-stronger? this-dom that-dom)
(contract-stronger? this-rng that-rng))]
(and (contract-struct-stronger? this-dom that-dom)
(contract-struct-stronger? this-rng that-rng))]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(and (contract-stronger? this-dom that-dom)
(contract-stronger? that-dom this-dom)
(contract-stronger? this-rng that-rng)
(contract-stronger? that-rng this-rng))]
(and (contract-struct-stronger? this-dom that-dom)
(contract-struct-stronger? that-dom this-dom)
(contract-struct-stronger? this-rng that-rng)
(contract-struct-stronger? that-rng this-rng))]
[else #f])]
[else #f]))

77
racket/collects/racket/contract/private/misc.rkt
View File

@ -56,7 +56,9 @@
random-any/c
rename-contract
if/c)
if/c
pairwise-stronger-contracts?)
(define-syntax (flat-murec-contract stx)
(syntax-case stx ()
@ -132,12 +134,8 @@
(define (and-stronger? this that)
(and (base-and/c? that)
(let ([this-ctcs (base-and/c-ctcs this)]
[that-ctcs (base-and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))
(pairwise-stronger-contracts? (base-and/c-ctcs this)
(base-and/c-ctcs that))))
(define (and/c-generate? ctc)
(cond
@ -206,21 +204,21 @@
(define (and/c-check-nonneg ctc pred)
(define sub-contracts (base-and/c-ctcs ctc))
(cond
[(are-stronger-contracts? (list pred (not/c negative?))
sub-contracts)
[(pairwise-stronger-contracts? (list pred (not/c negative?))
sub-contracts)
(define go (hash-ref predicate-generator-table pred))
(λ (fuel)
(λ ()
(abs (go fuel))))]
[else #f]))
(define (are-stronger-contracts? c1s c2s)
(define (pairwise-stronger-contracts? c1s c2s)
(let loop ([c1s c1s]
[c2s c2s])
(cond
[(and (null? c1s) (null? c2s)) #t]
[(and (pair? c1s) (pair? c2s))
(and (contract-stronger? (car c1s) (car c2s))
(and (contract-struct-stronger? (car c1s) (car c2s))
(loop (cdr c1s) (cdr c2s)))]
[else #f])))
@ -576,13 +574,13 @@
[(pe-listof-ctc? this) (pe-listof-ctc? that)]
[(im-listof-ctc? this) (im-listof-ctc? that)]
[else #t])
(contract-stronger? this-elem that-elem))]
(contract-struct-stronger? this-elem that-elem))]
[(the-cons/c? that)
(define hd-ctc (the-cons/c-hd-ctc that))
(define tl-ctc (the-cons/c-tl-ctc that))
(and (ne-listof-ctc? this)
(contract-stronger? this-elem hd-ctc)
(contract-stronger? (ne->pe-ctc this) tl-ctc))]
(contract-struct-stronger? this-elem hd-ctc)
(contract-struct-stronger? (ne->pe-ctc this) tl-ctc))]
[else #f]))
(define (raise-listof-blame-error blame val empty-ok? neg-party)
@ -828,16 +826,16 @@
[(the-cons/c? that)
(define that-hd (the-cons/c-hd-ctc that))
(define that-tl (the-cons/c-tl-ctc that))
(and (contract-stronger? this-hd that-hd)
(contract-stronger? this-tl that-tl))]
(and (contract-struct-stronger? this-hd that-hd)
(contract-struct-stronger? this-tl that-tl))]
[(ne-listof-ctc? that)
(define elem-ctc (listof-ctc-elem-c that))
(and (contract-stronger? this-hd elem-ctc)
(contract-stronger? this-tl (ne->pe-ctc that)))]
(and (contract-struct-stronger? this-hd elem-ctc)
(contract-struct-stronger? this-tl (ne->pe-ctc that)))]
[(pe-listof-ctc? that)
(define elem-ctc (listof-ctc-elem-c that))
(and (contract-stronger? this-hd elem-ctc)
(contract-stronger? this-tl that))]
(and (contract-struct-stronger? this-hd elem-ctc)
(contract-struct-stronger? this-tl that))]
[else #f]))
@ -1109,18 +1107,15 @@
(define (list/c-stronger this that)
(cond
[(generic-list/c? that)
(and (= (length (generic-list/c-args this))
(length (generic-list/c-args that)))
(for/and ([this-s (in-list (generic-list/c-args this))]
[that-s (in-list (generic-list/c-args this))])
(contract-stronger? this-s that-s)))]
(pairwise-stronger-contracts? (generic-list/c-args this)
(generic-list/c-args that))]
[(listof-ctc? that)
(define that-elem-ctc (listof-ctc-elem-c that))
(define this-elem-ctcs (generic-list/c-args this))
(and (or (pair? this-elem-ctcs)
(pe-listof-ctc? that))
(for/and ([this-s (in-list this-elem-ctcs)])
(contract-stronger? this-s that-elem-ctc)))]
(contract-struct-stronger? this-s that-elem-ctc)))]
[else #f]))
(struct generic-list/c (args))
@ -1250,8 +1245,8 @@
#:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc)))
#:stronger (λ (this that)
(and (syntax-ctc? that)
(contract-stronger? (syntax-ctc-ctc this)
(syntax-ctc-ctc that))))
(contract-struct-stronger? (syntax-ctc-ctc this)
(syntax-ctc-ctc that))))
#:first-order (λ (ctc)
(define ? (flat-contract-predicate (syntax-ctc-ctc ctc)))
(λ (v)
@ -1299,8 +1294,8 @@
(define (promise-ctc-stronger? this that)
(and (promise-base-ctc? that)
(contract-stronger? (promise-base-ctc-ctc this)
(promise-base-ctc-ctc that))))
(contract-struct-stronger? (promise-base-ctc-ctc this)
(promise-base-ctc-ctc that))))
(struct promise-base-ctc (ctc))
(struct chaperone-promise-ctc promise-base-ctc ()
@ -1380,10 +1375,10 @@
#:stronger
(λ (this that)
(and (parameter/c? that)
(and (contract-stronger? (parameter/c-out this)
(parameter/c-out that))
(contract-stronger? (parameter/c-in that)
(parameter/c-in this)))))))
(and (contract-struct-stronger? (parameter/c-out this)
(parameter/c-out that))
(contract-struct-stronger? (parameter/c-in that)
(parameter/c-in this)))))))
(define-struct procedure-arity-includes/c (n)
#:property prop:custom-write custom-write-property-proc
@ -1558,10 +1553,10 @@
(define (prompt-tag/c-stronger? this that)
(and (base-prompt-tag/c? that)
(andmap (λ (this that) (contract-stronger? this that))
(andmap (λ (this that) (contract-struct-stronger? this that))
(base-prompt-tag/c-ctcs this)
(base-prompt-tag/c-ctcs that))
(andmap (λ (this that) (contract-stronger? this that))
(andmap (λ (this that) (contract-struct-stronger? this that))
(base-prompt-tag/c-call/ccs this)
(base-prompt-tag/c-call/ccs that))))
@ -1626,7 +1621,7 @@
(define (continuation-mark-key/c-stronger? this that)
(and (base-continuation-mark-key/c? that)
(contract-stronger?
(contract-struct-stronger?
(base-continuation-mark-key/c-ctc this)
(base-continuation-mark-key/c-ctc that))))
@ -1707,9 +1702,7 @@
(define (evt/c-stronger? this that)
(define this-ctcs (chaperone-evt/c-ctcs this))
(define that-ctcs (chaperone-evt/c-ctcs that))
(and (= (length this-ctcs) (that-ctcs))
(for/and ([this this-ctcs] [that that-ctcs])
(contract-stronger? this that))))
(pairwise-stronger-contracts? this-ctcs that-ctcs))
;; ctcs - Listof<Contract>
(define-struct chaperone-evt/c (ctcs)
@ -1760,7 +1753,7 @@
(define (channel/c-stronger? this that)
(and (base-channel/c? that)
(contract-stronger?
(contract-struct-stronger?
(base-channel/c-ctc this)
(base-channel/c-ctc that))))
@ -1869,7 +1862,7 @@
(flat-named-contract name (flat-contract-predicate ctc))
(let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)])
(define (stronger? this other)
(contract-stronger? ctc other))
(contract-struct-stronger? ctc other))
(make-contract #:name name
#:late-neg-projection (get/build-late-neg-projection ctc)
#:first-order (contract-first-order ctc)

30
racket/collects/racket/contract/private/orc.rkt
View File

@ -94,14 +94,10 @@
(define (single-or/c-stronger? this that)
(or (and (single-or/c? that)
(contract-stronger? (single-or/c-ho-ctc this)
(single-or/c-ho-ctc that))
(let ([this-ctcs (single-or/c-flat-ctcs this)]
[that-ctcs (single-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))
(contract-struct-stronger? (single-or/c-ho-ctc this)
(single-or/c-ho-ctc that))
(pairwise-stronger-contracts? (single-or/c-flat-ctcs this)
(single-or/c-flat-ctcs that)))
(generic-or/c-stronger? this that)))
(define (generic-or/c-stronger? this that)
@ -111,7 +107,7 @@
that-sub-ctcs
(for/and ([this-sub-ctc (in-list this-sub-ctcs)])
(for/or ([that-sub-ctc (in-list that-sub-ctcs)])
(contract-stronger? this-sub-ctc that-sub-ctc)))))
(contract-struct-stronger? this-sub-ctc that-sub-ctc)))))
(define (or/c-sub-contracts ctc)
(cond
@ -304,14 +300,10 @@
(define (multi-or/c-stronger? this that)
(or (and (multi-or/c? that)
(let ([this-ctcs (multi-or/c-ho-ctcs this)]
[that-ctcs (multi-or/c-ho-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? this-ctcs that-ctcs)))
(let ([this-ctcs (multi-or/c-flat-ctcs this)]
[that-ctcs (multi-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? this-ctcs that-ctcs))))
(pairwise-stronger-contracts? (multi-or/c-ho-ctcs this)
(multi-or/c-ho-ctcs that))
(pairwise-stronger-contracts? (multi-or/c-flat-ctcs this)
(multi-or/c-flat-ctcs that)))
(generic-or/c-stronger? this that)))
(define (mult-or/c-list-contract? c)
@ -373,7 +365,7 @@
[(and (<= (length this-ctcs) (length that-ctcs))
(for/and ([this-ctc (in-list this-ctcs)]
[that-ctc (in-list that-ctcs)])
(contract-stronger? this-ctc that-ctc)))
(contract-struct-stronger? this-ctc that-ctc)))
#t]
[(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs)
(andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs))
@ -522,7 +514,7 @@
[(equal? this that) #t]
[(recur?)
(parameterize ([recur? #f])
(contract-stronger? (get-flat-rec-me this) that))]
(contract-struct-stronger? (get-flat-rec-me this) that))]
[else #f])))
#:first-order
(λ (ctc)

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

@ -49,8 +49,8 @@
(define instances
(for/list ([var (in-list this-vars)])
(this-barrier/c #t var)))
(contract-stronger? (apply (polymorphic-contract-body this) instances)
(apply (polymorphic-contract-body that) instances))]
(contract-struct-stronger? (apply (polymorphic-contract-body this) instances)
(apply (polymorphic-contract-body that) instances))]
[else #f])]
[else #f]))
#:late-neg-projection

6
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -289,7 +289,7 @@
(λ (v neg-party)
(cond
[(and (struct/c-imp-prop-pred? v)
(contract-stronger? (struct/c-imp-prop-get v) ctc))
(contract-struct-stronger? (struct/c-imp-prop-get v) ctc))
v]
[else
(unless (pred? v)
@ -653,8 +653,8 @@
(immutable? that-subcontract))
(and (lazy-immutable? this-subcontract)
(lazy-immutable? that-subcontract)))
(contract-stronger? (indep-ctc this-subcontract)
(indep-ctc that-subcontract)))]
(contract-struct-stronger? (indep-ctc this-subcontract)
(indep-ctc that-subcontract)))]
[(and (dep? this-subcontract)
(dep? that-subcontract))
(and (or (dep-mutable? this-subcontract)

18
racket/collects/racket/contract/private/vector.rkt
View File

@ -114,12 +114,12 @@
(cond
[(and (equal? this-immutable #t)
(equal? that-immutable #t))
(contract-stronger? this-elem that-elem)]
(contract-struct-stronger? this-elem that-elem)]
[else
(and (or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(contract-stronger? this-elem that-elem)
(contract-stronger? that-elem this-elem))])]
(contract-struct-stronger? this-elem that-elem)
(contract-struct-stronger? that-elem this-elem))])]
[else #f]))
(define-struct (flat-vectorof base-vectorof) ()
@ -325,14 +325,14 @@
(and (= (length this-elems) (length that-elems))
(for/and ([this-elem (in-list this-elems)]
[that-elem (in-list that-elems)])
(contract-stronger? this-elem that-elem)))]
(contract-struct-stronger? this-elem that-elem)))]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(and (= (length this-elems) (length that-elems))
(for/and ([this-elem (in-list this-elems)]
[that-elem (in-list that-elems)])
(and (contract-stronger? this-elem that-elem)
(contract-stronger? that-elem this-elem))))]
(and (contract-struct-stronger? this-elem that-elem)
(contract-struct-stronger? that-elem this-elem))))]
[else #f])]
[(base-vectorof? that)
(define that-elem (base-vectorof-elem that))
@ -341,12 +341,12 @@
[(and (equal? this-immutable #t)
(equal? that-immutable #t))
(for/and ([this-elem (in-list this-elems)])
(contract-stronger? this-elem that-elem))]
(contract-struct-stronger? this-elem that-elem))]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(for/and ([this-elem (in-list this-elems)])
(and (contract-stronger? this-elem that-elem)
(contract-stronger? that-elem this-elem)))]
(and (contract-struct-stronger? this-elem that-elem)
(contract-struct-stronger? that-elem this-elem)))]
[else #f])]
[else #f]))