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

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

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -1978,9 +1978,11 @@ The first-order predicate @racket[test] can be used to determine which values
 the contract applies to; this must be the set of values for which the
 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
+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.
+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?])

pkgs/racket-test/tests/racket/contract/recursive-contract.rkt

@@ -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))

racket/collects/racket/contract/private/base.rkt

@@ -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)

racket/collects/racket/contract/private/guts.rkt

@@ -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

racket/collects/racket/contract/private/orc.rkt

@@ -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
+                    (values candidate-contract (car contracts))
-                                     '("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)
                     (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