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

have a better strategy for or/c to determine which clause to commit to

Browse Source 
in particular, when there is a recursive contract, then we check only
some part of the first-order checks and see if that was enough to
distinguish the branches. if it was, we don't continue and otherwise we do
This commit is contained in:
Robby Findler 2015-12-22 15:40:31 -06:00
parent 31cf0bdbc3
commit 8a9408306b
5 changed files with 131 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1980,7 +1980,9 @@ contract fails immediately without any higher-order wrapping. This test is used
by @racket[contract-first-order-passes?], and indirectly by @racket[or/c]
and @racket[from-or/c] to determine which higher-order contract to wrap a
value with when there are multiple higher-order contracts to choose from.
The default test accepts any value.
The default test accepts any value. The predicate should be influenced by
the value of @racket[(contract-first-order-okay-to-give-up?)] (see it's documentation
for more explanation).
The @racket[late-neg-proj] defines the behavior of applying the contract. If it is
supplied, it accepts a blame object that does not have a value for
@ -2745,7 +2747,11 @@ If it returns @racket[#f], the contract is guaranteed not to
hold for that value; if it returns @racket[#t], the contract
may or may not hold. If the contract is a first-order
contract, a result of @racket[#t] guarantees that the
contract holds.}
contract holds.
See also @racket[contract-first-order-okay-to-give-up?] and
@racket[contract-first-order-try-less-hard].
}
@defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{
Produces the first-order test used by @racket[or/c] to match values to
@ -2943,6 +2949,35 @@ currently being checked.
@history[#:added "6.3"]
}
@defform[(contract-first-order-okay-to-give-up?)]{
This form returns a boolean that controls the result
of first-order contact checks. More specifically, if
it returns @racket[#t], then a first-order check may
return @racket[#t] even when the entire first-order
checks have not happened. If it returns @racket[#f]
then the first order checks must continue until a
definitive answer is returned.
This will only return @racket[#t] in the dynamic
extent of @racket[or/c] or @racket[first-or/c]'s
checking to determine which branch to use.
@history[#:added "6.3.0.9"]
}
@defform[(contract-first-order-try-less-hard e)]{
Encourages first-order checks that happen in the
dynamic-extent of @racket[e] to be more likely to
give up. That is, makes it more likely that
@racket[contract-first-order-okay-to-give-up?] might
return @racket[#t].
If not in the dynamic-extent of @racket[or/c]'s or
@racket[first-or/c]'s checking to determine the branch,
then this form has no effect.
@history[#:added "6.3.0.9"]
}
@defproc[(if/c [predicate (-> any/c any/c)]
[then-contract contract?]
[else-contract contract?])

21
pkgs/racket-test/tests/racket/contract/recursive-contract.rkt
View File

@ -72,4 +72,23 @@
'(let ()
(struct doll (contents))
(letrec ([doll-ctc2 (or/c 'center (struct/c doll (recursive-contract doll-ctc2 #:flat)))])
(contract doll-ctc2 (doll 4) 'pos 'neg)))))
(contract doll-ctc2 (doll 4) 'pos 'neg))))
(test/spec-passed/result
'recursive-contract-not-too-slow
'(let ()
(define c
(recursive-contract
(or/c null?
(cons/c (-> integer? integer? integer?) c)
(cons/c (-> integer? integer?) (cons/c (-> integer? integer?) c)))))
(define l (build-list 10000 (λ (x) (λ (x) x))))
(define-values (_ cpu real gc)
(time-apply (λ () (contract c l 'pos 'neg)) '()))
;; should be substantially less than 5 seconds.
;; with the old implementation it is more like 20 seconds
;; on my laptop and about .3 seconds with the new one
(< (- cpu gc) 5000))
#t))

5
racket/collects/racket/contract/private/base.rkt
View File

@ -165,8 +165,11 @@
(define (recursive-contract-stronger this that) (equal? this that))
(define ((recursive-contract-first-order ctc) val)
(cond
[(contract-first-order-okay-to-give-up?) #t]
[else (contract-first-order-try-less-hard
(contract-first-order-passes? (force-recursive-contract ctc)
val))
val))]))
(define (recursive-contract-generate ctc)
(λ (fuel)

24
racket/collects/racket/contract/private/guts.rkt
View File

@ -70,7 +70,11 @@
contract-name
maybe-warn-about-val-first
set-some-basic-contracts!)
set-some-basic-contracts!
contract-first-order-okay-to-give-up?
contract-first-order-try-less-hard
contract-first-order-only-try-so-hard)
(define (contract-custom-write-property-proc stct port mode)
(define (write-prefix)
@ -730,6 +734,24 @@
(val+np-acceptor x #f))))
(define contract-first-order-okay-to-give-up-key (gensym 'contract-first-order-okay-to-give-up-key))
(define (contract-first-order-okay-to-give-up?)
(zero? (continuation-mark-set-first #f
contract-first-order-okay-to-give-up-key
1)))
(define-syntax-rule
(contract-first-order-try-less-hard e)
(contract-first-order-try-less-hard/proc (λ () e)))
(define (contract-first-order-try-less-hard/proc th)
(define cv (continuation-mark-set-first #f contract-first-order-okay-to-give-up-key))
(if cv
(with-continuation-mark contract-first-order-okay-to-give-up-key (if (= cv 0) 0 (- cv 1))
(th))
(th)))
(define-syntax-rule
(contract-first-order-only-try-so-hard n e)
(with-continuation-mark contract-first-order-okay-to-give-up-key n e))
;; Key used by the continuation mark that holds blame information for the current contract.
;; That information is consumed by the contract profiler.
(define contract-continuation-mark-key

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

@ -243,6 +243,7 @@
(pred val))
val]
[else
(define (try)
(let loop ([checks first-order-checks]
[c-projs c-projs+blame]
[contracts ho-contracts]
@ -252,18 +253,12 @@
[(null? checks)
(cond
[candidate-c-proj
(candidate-c-proj val neg-party)]
(values candidate-c-proj #f)]
[else
(raise-none-or-matched blame val neg-party)])]
[((car checks) val)
(if candidate-c-proj
(raise-blame-error blame val #:missing-party neg-party
'("two of the clauses in the or/c might both match: ~s and ~s"
given:
"~e")
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(values candidate-contract (car contracts))
(loop (cdr checks)
(cdr c-projs)
(cdr contracts)
@ -274,7 +269,26 @@
(cdr c-projs)
(cdr contracts)
candidate-c-proj
candidate-contract)]))]))))
candidate-contract)])))
(let loop ([how-hard '(10 100)])
(cond
[(null? how-hard)
(define-values (last-try-first-one last-try-second-one) (try))
(when (and last-try-first-one last-try-second-one)
(raise-blame-error blame val #:missing-party neg-party
'("two of the clauses in the or/c might both match: ~s and ~s"
given:
"~e")
(contract-name last-try-first-one)
(contract-name last-try-second-one)
val))]
[else
(define-values (this-try-first-one this-try-second-one)
(contract-first-order-only-try-so-hard (car how-hard) (try)))
(cond
[(not this-try-second-one) (this-try-first-one val neg-party)]
[else (loop (cdr how-hard))])]))]))))
(define (raise-none-or-matched blame val neg-party)
(raise-blame-error blame val #:missing-party neg-party