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

adjust recursive-contract so that it terminates on cyclic values

Browse Source 
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)
This commit is contained in:
Robby Findler 2014-06-12 07:45:50 -05:00
parent cdeb4b6343
commit 7728e062f4
2 changed files with 72 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

@ -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,8 +124,7 @@
(define (force-recursive-contract ctc)
(define current (recursive-contract-ctc ctc))
(cond
[(or (symbol? current) (not current))
(when (or (symbol? current) (not current))
(define thunk (recursive-contract-thunk ctc))
(define old-name (recursive-contract-name ctc))
(set-recursive-contract-name! ctc (or current '<recursive-contract>))
@ -135,15 +136,44 @@
(coerce-chaperone-contract 'recursive-contract (thunk))]
[(impersonator-recursive-contract? ctc)
(coerce-contract 'recursive-contract (thunk))]))
(define cm-key (box #f))
(define orig-projection (contract-projection forced-ctc))
(define ((wrapper-projection blame) val)
(cond
[(continuation-mark-set-first #f cm-key)
=>
(λ (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)))
forced-ctc]
[else current]))
(cddr old-name)))))
(define ((recursive-contract-projection ctc) blame)
(define r-ctc (force-recursive-contract ctc))
(define f (contract-projection r-ctc))
(force-recursive-contract 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)
val))
(force-recursive-contract ctc)
((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