adjust recursive-contract so that it terminates on cyclic values

closes PR 14559

This slows down tight recursive contract loops by about 10%, using
the code below as the micro-benchmark:

(require racket/contract/base)

(define c
  (recursive-contract
   (or/c #f (cons/c c c))
   #:flat))

(define n1
  (let loop ([i 500000])
    (cond
      [(zero? i) #f]
      [else (cons (loop (- i 1)) #f)])))

(define n2
  (let loop ([i 500000])
    (cond
      [(zero? i) n1]
      [else (cons (loop (- i 1)) #f)])))

(collect-garbage) (collect-garbage) (collect-garbage)

(void
 (time (contract c n1 'pos 'neg))
 (time (contract c n2 'pos 'neg)))

(cdr n1)
(cdr n2)

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

@@ -72,4 +72,17 @@
    '(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
+   'recursive-contract12
+   '(let ()
+      (define c
+        (recursive-contract
+         (or/c #f (cons/c c c))
+         #:flat))
+      (define ph (make-placeholder #f))
+      (placeholder-set! ph (cons ph ph))
+      (contract c (make-reader-graph ph) 'pos 'neg)
+      (void)))
+  )

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

@@ -112,7 +112,9 @@
                "type must be one of #:impersonator, #:chaperone, or #:flat"
                stx
                type)]))
-    #`(#,maker '#,name (λ () #,arg) '#,local-name))
+    #`(#,maker '#,name (λ () #,arg) '#,local-name
+               'uninitialized-non-cyclic-first-order
+               'uninitialized-rec-proj-field))
   (syntax-case stx ()
     [(_ arg type)
      (keyword? (syntax-e #'type))
@@ -122,28 +124,56 @@
 
 (define (force-recursive-contract ctc)
   (define current (recursive-contract-ctc ctc))
-  (cond
+  (when (or (symbol? current) (not current))
-    [(or (symbol? current) (not current))
+    (define thunk (recursive-contract-thunk ctc))
-     (define thunk (recursive-contract-thunk ctc))
+    (define old-name (recursive-contract-name ctc))
-     (define old-name (recursive-contract-name ctc))
+    (set-recursive-contract-name! ctc (or current '<recursive-contract>))
-     (set-recursive-contract-name! ctc (or current '<recursive-contract>))
+    (define forced-ctc
-     (define forced-ctc
+      (cond
-       (cond
+        [(flat-recursive-contract? ctc)
-         [(flat-recursive-contract? ctc)
+         (coerce-flat-contract 'recursive-contract (thunk))]
-          (coerce-flat-contract 'recursive-contract (thunk))]
+        [(chaperone-recursive-contract? ctc)
-         [(chaperone-recursive-contract? ctc)
+         (coerce-chaperone-contract 'recursive-contract (thunk))]
-          (coerce-chaperone-contract 'recursive-contract (thunk))]
+        [(impersonator-recursive-contract? ctc)
-         [(impersonator-recursive-contract? ctc)
+         (coerce-contract 'recursive-contract (thunk))]))
-          (coerce-contract 'recursive-contract (thunk))]))
+    (define cm-key (box #f))
-     (set-recursive-contract-ctc! ctc forced-ctc)
+    (define orig-projection (contract-projection forced-ctc))
-     (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
+    (define ((wrapper-projection blame) val)
-                                               (cddr old-name)))
+      (cond
-     forced-ctc]
+        [(continuation-mark-set-first #f cm-key)
-    [else current]))
+         =>
+         (λ (ht)
+           (cond
+             [(hash-ref ht val #f) val]
+             [else
+              (hash-set! ht val #t)
+              ((orig-projection blame) val)]))]
+        [else
+         (with-continuation-mark cm-key (make-hasheq)
+           ((orig-projection blame) val))]))
+    (define orig-first-order (contract-first-order forced-ctc))
+    (define (wrapper-first-order val)
+      (cond
+        [(continuation-mark-set-first #f cm-key)
+         =>
+         (λ (ht)
+           (cond
+             [(hash-ref ht val #f) #t]
+             [else
+              (hash-set! ht val #t)
+              (orig-first-order val)]))]
+        [else
+         (with-continuation-mark cm-key (make-hasheq)
+           (orig-first-order val))]))
+    (set-recursive-contract-ctc! ctc forced-ctc)
+    (set-recursive-contract-non-cyclic-projection! ctc wrapper-projection)
+    (set-recursive-contract-non-cyclic-first-order! ctc wrapper-first-order)
+    (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
+                                              (cddr old-name)))))
 
 (define ((recursive-contract-projection ctc) blame)
-  (define r-ctc (force-recursive-contract ctc))
+  (force-recursive-contract ctc)
-  (define f (contract-projection r-ctc))
+  (define f (recursive-contract-non-cyclic-projection ctc))
   (define blame-known (blame-add-context blame #f))
   (λ (val)
     ((f blame-known) val)))
@@ -154,10 +184,14 @@
                                        (recursive-contract-thunk that))))
 
 (define ((recursive-contract-first-order ctc) val)
-  (contract-first-order-passes? (force-recursive-contract ctc)
+  (force-recursive-contract ctc)
-                                val))
+  ((recursive-contract-non-cyclic-first-order ctc) val))
 
-(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable]))
+(struct recursive-contract ([name #:mutable]
+                            thunk
+                            [ctc #:mutable]
+                            [non-cyclic-first-order #:mutable]
+                            [non-cyclic-projection #:mutable]))
 
 (struct flat-recursive-contract recursive-contract ()
   #:property prop:custom-write custom-write-property-proc