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

change the strategy for recursive-contract's knot tying

Browse Source 
this change speeds up this microbenchmark by about 10x:
This commit is contained in:
Robby Findler 2018-04-26 14:06:17 -05:00
parent 026d368a38
commit 2a1c8a78a5
3 changed files with 23 additions and 27 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)
2) 3)
(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,6 +156,7 @@
#`(#,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))
@ -204,32 +205,27 @@
[else current])) [else current]))
(define (recursive-contract-late-neg-projection ctc) (define (recursive-contract-late-neg-projection ctc)
(cond (define p (recursive-contract-param ctc))
[(recursive-contract-list-contract? ctc)
(λ (blame) (λ (blame)
(cond
[(p) => (λ (b) (λ (val neg-party) ((unbox b) val neg-party)))]
[else
(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 f-blame-known (make-thread-cell #f)) (define b (box 'uninitialized-recursive-contract))
(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))
(unless (thread-cell-ref f-blame-known) (func val neg-party))]
(thread-cell-set! f-blame-known (f blame-known))) [else func])])))
((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
@ -273,7 +269,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] list-contract?) (struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] param 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)) (make-wrapper-object blame mtds mtd-ctcs flds fld-ctcs))
(λ (val neg-party) (λ (val neg-party)
(p-app ctc val neg-party flds fld-ctcs)))) (p-app ctc val neg-party))))
#: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)