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

take advantage of the new impersonator support to hack in something that

Browse Source 
avoids piling up redundant instanceof/c contracts

This is not a general purpose solution, but instead a hack that covers
certain hopefully likely patterns of redundant contracts for objects.

This commit looks for redundant contracts according in a slightly more
general pattern than just "is the most recently attached contract
stronger than the one I'm about to put on here and does it have the
same blame labels?", because that predicate isn't good enough to cover
the example below. In the example below, we repeatedly get the same
contract put on an object, but with different blame labels. So we need
to drop "inner" contracts. That is, when we have two contracts on
there and we go to add the third, we can tell that the second one
would no longer ever signal blame, so we can keep just the first in
the third.

More concretely, if we had these two contracts on 'v' with the given
blame labels (higher lines means the contract is "outside" or applied
later and the blame labels are in positive/negative order):

  (-> x y)  <c,d>
  (-> x y)  <a,b>

then the two possible blames we get here are blaming d for a non-x
argument and blaming a for a non-y result. And now lets say we add a
third contract to the stack that's a copy of the first, but possibly
with different blame labels:

  (-> x y)  <e,f>
  (-> x y)  <c,d>
  (-> x y)  <a,b>

Now we can blame f for non-x argument and a for a non-y result, both
of which are things covered by the first and third contract, so we can
safely drop the middle one and use this stack:

  (-> x y)  <e,f>
  (-> x y)  <a,b>

The example above is couched in terms of arrow contracts, but this
commit doesn't do this for arrow contracts, it does it for
instanceof/c contracts.

And also the way that we tell that the inner contract is redundant
isn't that it is equal; instead we use contract-stronger?. In
particular, the above reasoning works, I believe, when we have that
the inner contract is stronger than the one we're removing and when
the outer contract is also stronger than the one we're
removing. That's the check that actually happens in the code.

-------

The code below is the example below is an example Asumu sent me (but
with the TR parts stripped out). Before this commit, the contract
wrapping grows without bound, but with this commit it stays constant.

In the example below we get only two different sets of blame labels
(and equal contracts) and thus are actually more contracts that could
be eliminated, but this commit does limit it to just two contracts. (I
think it could be alternating between one and two contracts instead of
always two if the code that dropped the contracts were more clever.)

 #lang racket/base
(module State racket/base
  (require racket/contract racket/class)

  (define state/c
    (recursive-contract
     (class/c
      [m (-> any/c (instanceof/c state/c))]
      [n (-> any/c (instanceof/c state/c))])))

  (define state%
    (class object%
      (super-new)
      (define/public (m) (send this n))
      (define/public (n) (new state%))))

  (define (tree-next o) (send o m))
  (define (make-tree) (new state%))
  make-tree
  (provide
   (contract-out
    [tree-next (-> (instanceof/c state/c) (instanceof/c state/c))]
    [make-tree (-> (instanceof/c state/c))])))

(require (submod "." State))
(require racket/sandbox)
(with-limits #f
             100
             (let loop ([o1 (make-tree)] [n 0])
               (printf "~a\n" n)
               (define o2 (tree-next o1))
               (loop o2 (add1 n))))
This commit is contained in:
Robby Findler 2014-10-21 16:51:20 -05:00
parent 74efd8394a
commit e589f591fb
1 changed files with 123 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1291,9 +1291,129 @@
(wrapped-class-info-neg-field-projs the-info)
neg-party)]
[else
(impersonate-struct val object-ref (λ (o c) new-cls)
impersonator-prop:contracted ctc
impersonator-prop:original-object original-obj)]))))
(define interposed-val
(if (has-impersonator-prop:instanceof/c-original-object? val)
(get-impersonator-prop:instanceof/c-original-object val)
(impersonate-struct
val object-ref
(λ (o c) (car (get-impersonator-prop:instanceof/c-wrapped-classes o))))))
;; this code is doing a fairly complicated dance to
;; accomplish a fairly simple purpose. In particular,
;; instanceof/c contracts keep all of the contracts
;; that they've put on a value in a property on the
;; value and then, when a new contract comes along,
;; try to avoid growing the list of contracts, in the
;; case that there is already checking that subsumes
;; some of the contracts. It does this by building up
;; the new list of contracts (the old one, plus this one)
;; and then looking for a sublist of that list like this:
;; c1, ..., ci, ..., cj, ..., ck, ... cn
;; such that ci <: cj and ck <: cj. When that's the case,
;; case then we know that cj is redundant (regardless of
;; the blame it might assign). So this code is looking
;; for such things, but the complication of the code comes
;; from trying to avoid re-creating too many contracts
(define all-new-ctcs
(cons ctc
(if (has-impersonator-prop:instanceof/c-ctcs? val)
(get-impersonator-prop:instanceof/c-ctcs val)
'())))
(define all-new-projs
(cons p
(if (has-impersonator-prop:instanceof/c-projs? val)
(get-impersonator-prop:instanceof/c-projs val)
'())))
(define old-classes
(if (has-impersonator-prop:instanceof/c-wrapped-classes? val)
(get-impersonator-prop:instanceof/c-wrapped-classes val)
'()))
(define-values (reverse-without-redundant-ctcs reverse-without-redundant-projs)
(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)])
(cond
[(null? next-ctcs) (values (cons this-ctc prior-ctcs)
(cons this-proj prior-projs))]
[else
(if (and (ormap (λ (x) (contract-stronger? x this-ctc)) prior-ctcs)
(ormap (λ (x) (contract-stronger? this-ctc x)) next-ctcs))
(loop prior-ctcs prior-projs
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs))
(loop (cons this-ctc prior-ctcs) (cons this-proj prior-projs)
(car next-ctcs) (cdr next-ctcs) (car next-projs) (cdr next-projs)))])))
(define wrapped-classes
(reverse
(let loop ([class (if (has-impersonator-prop:instanceof/c-wrapped-classes? val)
(car (reverse
(get-impersonator-prop:instanceof/c-wrapped-classes val)))
(object-ref val))]
[ctcs reverse-without-redundant-ctcs]
[projs reverse-without-redundant-projs]
[old-ctcs (reverse (cdr all-new-ctcs))]
[old-classes (reverse old-classes)])
(cond
[(null? projs) (list class)]
[else
(cons class
(cond
[(and (pair? old-ctcs) (eq? (car old-ctcs) (car ctcs)))
(loop (car old-classes)
(cdr ctcs)
(cdr projs)
(cdr old-ctcs)
(cdr old-classes))]
[else
(loop ((car projs) class) (cdr ctcs) (cdr projs) '() '())]))]))))
(impersonate-struct
interposed-val object-ref
;FIXME: this should be #f, but right now that triggers
;; a bug in the impersonator implementation
(λ (x y) y)
impersonator-prop:instanceof/c-original-object interposed-val
impersonator-prop:instanceof/c-ctcs (reverse reverse-without-redundant-ctcs)
impersonator-prop:instanceof/c-projs (reverse reverse-without-redundant-projs)
impersonator-prop:instanceof/c-wrapped-classes wrapped-classes
impersonator-prop:contracted ctc
impersonator-prop:original-object original-obj)]))))
(define-values (impersonator-prop:instanceof/c-ctcs
has-impersonator-prop:instanceof/c-ctcs?
get-impersonator-prop:instanceof/c-ctcs)
(make-impersonator-property 'impersonator-prop:instanceof/c-ctcs))
(define-values (impersonator-prop:instanceof/c-projs
has-impersonator-prop:instanceof/c-projs?
get-impersonator-prop:instanceof/c-projs)
(make-impersonator-property 'impersonator-prop:instanceof/c-projs))
(define-values (impersonator-prop:instanceof/c-wrapped-classes
has-impersonator-prop:instanceof/c-wrapped-classes?
get-impersonator-prop:instanceof/c-wrapped-classes)
(make-impersonator-property 'impersonator-prop:instanceof/c-wrapped-classes))
;; when an object has the original-object property,
;; then we also know that value of this property is
;; an object whose object-ref has been redirected to
;; use impersonator-prop:instanceof/c-wrapped-classes
(define-values (impersonator-prop:instanceof/c-original-object
has-impersonator-prop:instanceof/c-original-object?
get-impersonator-prop:instanceof/c-original-object)
(make-impersonator-property 'impersonator-prop:instanceof/c-has-object-ref-interposition))
(define (instanceof/c-first-order ctc)
(let ([cls-ctc (base-instanceof/c-class-ctc ctc)])