From 8cee5a09da806c3869754f28af7f36d371f6064b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 20 Nov 2018 21:28:15 -0600 Subject: [PATCH] improve the redundancy checking for class contracts 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 --- .../tests/racket/contract/object.rkt | 120 +++++++++++++++++- .../collects/racket/private/class-c-old.rkt | 25 ++-- 2 files changed, 136 insertions(+), 9 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/object.rkt b/pkgs/racket-test/tests/racket/contract/object.rkt index d24164816e..e5464acdc6 100644 --- a/pkgs/racket-test/tests/racket/contract/object.rkt +++ b/pkgs/racket-test/tests/racket/contract/object.rkt @@ -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) ) diff --git a/racket/collects/racket/private/class-c-old.rkt b/racket/collects/racket/private/class-c-old.rkt index e1257d2828..62f45c5541 100644 --- a/racket/collects/racket/private/class-c-old.rkt +++ b/racket/collects/racket/private/class-c-old.rkt @@ -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