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

adjust ->i so that when it sees that it got a flat contract,

Browse Source 
it doesn't apply it the second time (since we know that the
only difference for indy blame is in the negative position
and we know that flat contracts never assign negative blame)

This commit combined with the two previous (2b9d855 and 003e8c7) do
not seem to have a significant effect on the performance of ->i
contract checking. In particular, I see a 50% slowdown between the
version before and the version after these commits on the third `time`
expression below, but no significant difference on the first two.

(without the improvement to flat-contract?, these commits are
a significant slowdown to `g`)

 #lang racket
 (require profile)
 (define f
   (contract (->i ([y () integer?]
                   [x (y) integer?])
                  (values [a () integer?]
                          [b (a) integer?]))
             values
             'pos 'neg))

 (define g
   (contract (->i ([y () (<=/c 10)]
                   [x (y) (>=/c y)])
                  (values [a () (<=/c 10)]
                          [b (a) (>=/c a)]))
             values
             'pos 'neg))

 (define (slow-predicate n)
   (cond
     [(zero? n) #t]
     [else (slow-predicate (- n 1))]))

 (define h
   (contract (->i ([y () slow-predicate]
                   [x (y) slow-predicate])
                  (values [a () slow-predicate]
                          [b (a) slow-predicate]))
             values
             'pos 'neg))

 (time
  (for ([x (in-range 100000)])
    (f 1 2) (f 1 2) (f 1 2)
    (f 1 2) (f 1 2) (f 1 2)
    (f 1 2) (f 1 2) (f 1 2)))

 (time
  (for ([x (in-range 100000)])
    (g 1 2) (g 1 2) (g 1 2)
    (g 1 2) (g 1 2) (g 1 2)
    (g 1 2) (g 1 2) (g 1 2)))

 (time
  (for ([x (in-range 10000)])
    (h 50000 50000)))
This commit is contained in:
Robby Findler 2016-12-15 11:44:23 -06:00
parent 2b9d855231
commit 8918279b21
2 changed files with 46 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-test/tests/racket/contract/arrow-i.rkt
View File

@ -980,6 +980,27 @@
;; this is probably right (but not what we really really want, of course)
'(5 4 5 4 3 2 1 2 1))
(test/spec-passed/result
'->i57
'(let ([b '()])
((contract (->i ([y () (begin (set! b (cons 1 b))
(λ (y) (set! b (cons 2 b)) #t))]
[z (y) (begin (set! b (cons 3 b))
(λ (y) (set! b (cons 4 b)) #t))])
(values
[a () (begin (set! b (cons 6 b))
(λ (a) (set! b (cons 7 b)) #t))]
[b (a) (begin (set! b (cons 8 b))
(λ (a) (set! b (cons 9 b)) #t))]))
(λ args (set! b (cons 5 b)) (values 0 0))
'pos 'neg)
1 2)
b)
'(9 8 7 6 5 4 3 2 1)
;; this is probably right (but not what we really really want, of course)
'(9 8 7 6 9 8 7 6 5 4 3 2 1 4 3 2 1))
(test/pos-blame
'->i-arity1

41
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -693,7 +693,9 @@ evaluted left-to-right.)
[indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)])
;; bound to the result of calling the dependent function
;; (so computes what the contract will be for the given argument/res value)
;; (which isn't a contract directly, but is a function that returns
;; the projection for a contract)
;; the result computes what the contract will be for the given argument/res value.
(define contract-identifier (car (generate-temporaries (list indy-arg/res-var))))
(define indy-binding
@ -708,7 +710,8 @@ evaluted left-to-right.)
#`(#,contract-identifier
#,wrapper-arg
#,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res))
neg-party)
neg-party
#t)
#`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))])
(list)))
@ -735,12 +738,14 @@ evaluted left-to-right.)
#,(build-blame-identifier #f
swapped-blame?
(arg/res-var an-arg/res))
neg-party)]
neg-party
#f)]
[(arg/res-vars an-arg/res)
#`(#,contract-identifier
#,wrapper-arg
#,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res))
neg-party)]
neg-party
#f)]
[else
#`(#,arg/res-proj-var #,wrapper-arg neg-party)]))]
#,@indy-binding)
@ -1085,24 +1090,26 @@ evaluted left-to-right.)
#`(f #,@argument-list)))
(begin-encourage-inline
(define (un-dep/maybe-chaperone orig-ctc obj blame neg-party chaperone?)
(define (un-dep/maybe-chaperone orig-ctc obj blame neg-party chaperone? indy-blame?)
(cond
[(and (procedure? orig-ctc)
(procedure-arity-includes? orig-ctc 1))
(if (orig-ctc obj)
(if (or indy-blame? (orig-ctc obj))
obj
(raise-predicate-blame-error-failure blame obj neg-party
(contract-name orig-ctc)))]
[(and indy-blame? (flat-contract? orig-ctc))
obj]
[else
(define ctc (if chaperone?
(coerce-chaperone-contract '->i orig-ctc)
(coerce-contract '->i orig-ctc)))
(((get/build-late-neg-projection ctc) blame) obj neg-party)]))
(define (un-dep/chaperone orig-ctc obj blame neg-party)
(un-dep/maybe-chaperone orig-ctc obj blame neg-party #t))
(define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?)
(un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?))
(define (un-dep orig-ctc obj blame neg-party)
(un-dep/maybe-chaperone orig-ctc obj blame neg-party #f)))
(define (un-dep orig-ctc obj blame neg-party indy-blame?)
(un-dep/maybe-chaperone orig-ctc obj blame neg-party #f indy-blame?)))
(define-for-syntax (mk-used-indy-vars an-istx)
(let ([vars (make-free-identifier-mapping)])
@ -1237,11 +1244,11 @@ evaluted left-to-right.)
(gensym '->i-indy-boundary)))
#`(λ (#,@orig-vars)
(define the-contract #,ctc-stx)
(λ (val blame neg-party)
(λ (val blame neg-party indy-blame?)
;; this used to use opt/direct, but
;; opt/direct duplicates code (bad!)
(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
the-contract val blame neg-party)))))
the-contract val blame neg-party indy-blame?)))))
;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values
(map (λ (arg/res indy-id)
@ -1272,15 +1279,17 @@ evaluted left-to-right.)
(gensym '->i-indy-boundary)))
(if (eres? arg)
#`(λ #,orig-vars
#,@(arg/res-vars arg)
(opt/c #,arg-stx))
#`(λ (#,@orig-vars)
(define the-contract #,arg-stx)
(λ (val blame neg-party)
(λ (val blame neg-party indy-blame?)
;; this used to use opt/direct, but
;; opt/direct duplicates code (bad!)
(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
the-contract val blame neg-party))))))
(#,(if is-chaperone-contract?
#'un-dep/chaperone
#'un-dep)
the-contract val blame neg-party
indy-blame?))))))
#''())
#,(if (istx-ress an-istx)
#`(list #,@(filter values