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

Revert "change the strategy for recursive-contract's knot tying"

Browse Source 
This reverts commit 2a1c8a78a5.

something goes wrong with large recursive nests with this commit
This commit is contained in:
Robby Findler 2018-04-27 14:43:38 -05:00
parent 53ffd28e0f
commit ef8101bde3
3 changed files with 27 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -111,7 +111,7 @@
(for ([i (in-range 100)]) (for ([i (in-range 100)])
(void (vector-ref v 0))) (void (vector-ref v 0)))
counter) counter)
3) 2)
(test/spec-passed/result (test/spec-passed/result
'recursive-contract-not-too-slow 'recursive-contract-not-too-slow

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

@ -156,7 +156,6 @@
#`(#,maker '#,stx #`(#,maker '#,stx
(λ () #,arg) (λ () #,arg)
'#,(syntax-local-infer-name stx) '#,(syntax-local-infer-name stx)
(make-parameter #f)
#,(if list-contract? #'#t #'#f) #,(if list-contract? #'#t #'#f)
#,@(if (equal? (syntax-e type) '#:flat) #,@(if (equal? (syntax-e type) '#:flat)
(list (if extra-delay? #'#t #'#f)) (list (if extra-delay? #'#t #'#f))
@ -205,27 +204,32 @@
[else current])) [else current]))
(define (recursive-contract-late-neg-projection ctc) (define (recursive-contract-late-neg-projection ctc)
(define p (recursive-contract-param ctc))
(λ (blame)
(cond (cond
[(p) => (λ (b) (λ (val neg-party) ((unbox b) val neg-party)))] [(recursive-contract-list-contract? ctc)
[else (λ (blame)
(define r-ctc (force-recursive-contract ctc)) (define r-ctc (force-recursive-contract ctc))
(define f (get/build-late-neg-projection r-ctc)) (define f (get/build-late-neg-projection r-ctc))
(define blame-known (blame-add-context blame #f)) (define blame-known (blame-add-context blame #f))
(define b (box 'uninitialized-recursive-contract)) (define f-blame-known (make-thread-cell #f))
(define func (parameterize ([p b]) (f blame-known)))
(set-box! b func)
(cond
[(recursive-contract-list-contract? ctc)
(λ (val neg-party) (λ (val neg-party)
(unless (list? val) (unless (list? val)
(raise-blame-error blame-known #:missing-party neg-party (raise-blame-error blame-known #:missing-party neg-party
val val
'(expected: "list?" given: "~e") '(expected: "list?" given: "~e")
val)) val))
(func val neg-party))] (unless (thread-cell-ref f-blame-known)
[else func])]))) (thread-cell-set! f-blame-known (f blame-known)))
((thread-cell-ref f-blame-known) val neg-party)))]
[else
(λ (blame)
(define r-ctc (force-recursive-contract ctc))
(define f (get/build-late-neg-projection r-ctc))
(define blame-known (blame-add-context blame #f))
(define f-blame-known (make-thread-cell #f))
(λ (val neg-party)
(unless (thread-cell-ref f-blame-known)
(thread-cell-set! f-blame-known (f blame-known)))
((thread-cell-ref f-blame-known) val neg-party)))]))
(define (flat-recursive-contract-late-neg-projection ctc) (define (flat-recursive-contract-late-neg-projection ctc)
(cond (cond
@ -269,7 +273,7 @@
(force-recursive-contract ctc) (force-recursive-contract ctc)
(contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))]))) (contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))])))
(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] param list-contract?) (struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?)
#:property prop:recursive-contract (λ (this) #:property prop:recursive-contract (λ (this)
(force-recursive-contract this) (force-recursive-contract this)
(recursive-contract-ctc this))) (recursive-contract-ctc this)))

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

@ -65,9 +65,9 @@
(define mtd-ctcs (object-contract-method-ctcs ctc)) (define mtd-ctcs (object-contract-method-ctcs ctc))
(λ (blame) (λ (blame)
(define p-app (define p-app
(make-wrapper-object blame mtds mtd-ctcs flds fld-ctcs)) (make-wrapper-object blame mtds mtd-ctcs))
(λ (val neg-party) (λ (val neg-party)
(p-app ctc val neg-party)))) (p-app ctc val neg-party flds fld-ctcs))))
#:name #:name
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc) (object-contract-fields ctc)