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

improve the redundancy checking for class contracts

Browse Source 
In particular, when there isn't any redundancy detected, then
just make a single call into the projection and create just a single
class.

This seems to help on at least one of the configurations of
dungeon, which completes in about 6 minutes with this commit
and I gave up waiting after 15 minutes for the version of
racket that didn't have it
This commit is contained in:
Robby Findler 2018-11-20 21:28:15 -06:00
parent b4e3030a0d
commit 8cee5a09da
2 changed files with 136 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

120
pkgs/racket-test/tests/racket/contract/object.rkt
View File

@ -2,7 +2,8 @@
(require "test-util.rkt")
(parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/class)])
(make-basic-contract-namespace 'racket/class
'racket/contract/combinator)])
(test/pos-blame
'object/c-first-order-object-1
'(contract (object/c)
@ -379,4 +380,121 @@
'p 'n)
foo))
0)
;; this test makes sure that we don't rewrap
;; contracts when we are just putting three
;; different contracts on
(test/spec-passed/result
'object/c-avoid-redundancy
'(let ()
(define log '())
(define (printing/c l)
(make-contract
#:late-neg-projection
(λ (blame)
(λ (val missing-party)
(set! log (cons l log))
val))))
(define foo%
(class object%
(super-new)
(define/public (m) #f)))
(define (printing-foo/c l)
(object/c [m (printing/c l)]))
(define oa
(contract (printing-foo/c 'a)
(new foo%)
'pos 'neg))
(define ob
(contract (printing-foo/c 'b)
oa
'pos 'neg))
(define oc
(contract (printing-foo/c 'c)
ob
'pos 'neg))
log)
'(c b a) '(c c b b a a))
;; this tests the situation where the double-wrapping avoidance
;; kicks in. The second part of the result, '(a b b a a), indicates
;; that there are still too many calls to the projection
;; (namely there is an extra `a` coming from the creation of
;; `new-cls` (in class-c-old.rkt, currently line 1368))
(test/spec-passed/result
'object/c-avoid-redundancy.2
'(let ()
(define log '())
(struct logging/c (name)
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:late-neg-projection
(λ (this)
(λ (blame)
(λ (val missing-party)
(set! log (cons (logging/c-name this) log))
val)))
#:name (λ (x) `(logging/c ,(logging/c-name x)))
#:first-order (λ (x) #t)
#:stronger
(λ (this that)
(and (logging/c? that)
(equal? (logging/c-name this) (logging/c-name that))))
#:equivalent
(λ (this that)
(and (logging/c? that)
(equal? (logging/c-name this) (logging/c-name that))))))
(define foo%
(class object%
(super-new)
(define/public (m) #f)))
(define printing-a
(object/c [m (logging/c 'a)]))
(define printing-b
(object/c [m (logging/c 'b)]))
(define oa
(contract printing-a
(new foo%)
'pos 'neg))
(define ob
(contract printing-b
oa
'pos 'neg))
(define oc
(contract printing-a
ob
'pos 'neg))
(define od
(contract printing-b
oc
'pos 'neg))
(define log1 log)
(set! log '())
(define oe
(contract printing-a
od
'pos 'neg))
(list log1 log))
'((b a b a) (a b b a a))
do-not-double-wrap)
)

25
racket/collects/racket/private/class-c-old.rkt
View File

@ -1419,32 +1419,41 @@
(contract? y)
(contract-stronger? x y)))
(define-values (reverse-without-redundant-ctcs reverse-without-redundant-projs)
(define-values (reverse-without-redundant-ctcs
reverse-without-redundant-projs
dropped-something?)
(let loop ([prior-ctcs '()]
[prior-projs '()]
[this-ctc (car all-new-ctcs)]
[next-ctcs (cdr all-new-ctcs)]
[this-proj (car all-new-projs)]
[next-projs (cdr all-new-projs)])
[next-projs (cdr all-new-projs)]
[dropped-something? #f])
(cond
[(null? next-ctcs) (values (cons this-ctc prior-ctcs)
(cons this-proj prior-projs))]
(cons this-proj prior-projs)
dropped-something?)]
[else
(if (and (ormap (λ (x) (stronger? x this-ctc)) prior-ctcs)
(ormap (λ (x) (stronger? this-ctc x)) next-ctcs))
(loop prior-ctcs prior-projs
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs))
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)
#t)
(loop (cons this-ctc prior-ctcs) (cons this-proj prior-projs)
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)))])))
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)
dropped-something?))])))
(define unwrapped-class
(if (has-impersonator-prop:instanceof/c-unwrapped-class? val)
(get-impersonator-prop:instanceof/c-unwrapped-class val)
(object-ref val)))
(define wrapped-class
(for/fold ([class unwrapped-class])
([proj (in-list reverse-without-redundant-projs)])
(proj class)))
(if dropped-something?
(for/fold ([class unwrapped-class])
([proj (in-list reverse-without-redundant-projs)])
(proj class))
new-cls))
(impersonate-struct
interposed-val object-ref