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

avoid evaluating the dependent contract expressions multiple times in ->i

Browse Source
This commit is contained in:
Robby Findler 2016-12-15 10:27:40 -06:00
parent f1d6e8bfe8
commit 003e8c7870
2 changed files with 76 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -949,6 +949,38 @@
#:one 1 #:two 2 #:three 3) #:one 1 #:two 2 #:three 3)
'(1 2 3)) '(1 2 3))
(test/spec-passed/result
'->i55
'(let ([b '()])
((contract (->i ([y () (begin (set! b (cons 1 b)) any/c)]
[z (y) (begin (set! b (cons 2 b)) any/c)])
any)
(λ args (set! b (cons 3 b)) 0)
'pos 'neg)
1 2)
b)
'(3 2 1)
;; this is probably right (but not what we really really want, of course)
'(3 2 1 2 1))
(test/spec-passed/result
'->i56
'(let ([b '()])
((contract (->i ([y () (begin (set! b (cons 1 b)) any/c)]
[z (y) (begin (set! b (cons 2 b)) any/c)])
(values
[a () (begin (set! b (cons 4 b)) any/c)]
[b (a) (begin (set! b (cons 5 b)) any/c)]))
(λ args (set! b (cons 3 b)) (values 0 0))
'pos 'neg)
1 2)
b)
'(5 4 3 2 1)
;; this is probably right (but not what we really really want, of course)
'(5 4 5 4 3 2 1 2 1))
(test/pos-blame (test/pos-blame
'->i-arity1 '->i-arity1
'(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg)) '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))

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

@ -692,7 +692,11 @@ evaluted left-to-right.)
[arg/res-proj-var (vector-ref arg/res-proj-vars index)] [arg/res-proj-var (vector-ref arg/res-proj-vars index)]
[indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)]) [indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)])
(let ([indy-binding ;; bound to the result of calling the dependent function
;; (so 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
;; if indy-arg/res-proj-var is #f, that means that we don't need that binding, so skip it ;; if indy-arg/res-proj-var is #f, that means that we don't need that binding, so skip it
(if indy-arg/res-proj-var (if indy-arg/res-proj-var
(list (list
@ -701,21 +705,25 @@ evaluted left-to-right.)
an-arg/res an-arg/res
wrapper-arg wrapper-arg
(if (arg/res-vars an-arg/res) (if (arg/res-vars an-arg/res)
#`(#,arg/res-proj-var #`(#,contract-identifier
#,wrapper-arg
#,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res))
neg-party)
#`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))])
(list)))
#`(let (#,@(if (and (arg/res-vars an-arg/res) (not (eres? an-arg/res)))
(list #`[#,contract-identifier
(#,arg/res-proj-var
#,@(map (λ (var) #,@(map (λ (var)
(arg/res-to-indy-var indy-arg-vars (arg/res-to-indy-var indy-arg-vars
ordered-args ordered-args
indy-res-vars indy-res-vars
ordered-ress ordered-ress
var)) var))
(arg/res-vars an-arg/res)) (arg/res-vars an-arg/res)))])
#,wrapper-arg (list)))
#,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res)) (let ([#,wrapper-arg
neg-party)
#`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))])
(list))])
#`(let (#,@indy-binding
[#,wrapper-arg
#,(add-unsupplied-check #,(add-unsupplied-check
an-arg/res an-arg/res
wrapper-arg wrapper-arg
@ -729,18 +737,13 @@ evaluted left-to-right.)
(arg/res-var an-arg/res)) (arg/res-var an-arg/res))
neg-party)] neg-party)]
[(arg/res-vars an-arg/res) [(arg/res-vars an-arg/res)
#`(#,arg/res-proj-var #`(#,contract-identifier
#,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars
ordered-args
indy-res-vars
ordered-ress
var))
(arg/res-vars an-arg/res))
#,wrapper-arg #,wrapper-arg
#,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)) #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res))
neg-party)] neg-party)]
[else [else
#`(#,arg/res-proj-var #,wrapper-arg neg-party)]))]) #`(#,arg/res-proj-var #,wrapper-arg neg-party)]))]
#,@indy-binding)
#,body))))) #,body)))))
@ -1232,12 +1235,13 @@ evaluted left-to-right.)
this->i) this->i)
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary))) (gensym '->i-indy-boundary)))
#`(λ (#,@orig-vars val blame neg-party) #`(λ (#,@orig-vars)
#,@(arg/res-vars arg) (define the-contract #,ctc-stx)
(λ (val blame neg-party)
;; this used to use opt/direct, but ;; this used to use opt/direct, but
;; opt/direct duplicates code (bad!) ;; opt/direct duplicates code (bad!)
(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
#,ctc-stx val blame neg-party)))) the-contract val blame neg-party)))))
;; then the non-dependent argument contracts that are themselves dependend on ;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values (list #,@(filter values
(map (λ (arg/res indy-id) (map (λ (arg/res indy-id)
@ -1270,12 +1274,13 @@ evaluted left-to-right.)
#`(λ #,orig-vars #`(λ #,orig-vars
#,@(arg/res-vars arg) #,@(arg/res-vars arg)
(opt/c #,arg-stx)) (opt/c #,arg-stx))
#`(λ (#,@orig-vars val blame neg-party) #`(λ (#,@orig-vars)
(define the-contract #,arg-stx)
(λ (val blame neg-party)
;; this used to use opt/direct, but ;; this used to use opt/direct, but
;; opt/direct duplicates code (bad!) ;; opt/direct duplicates code (bad!)
#,@(arg/res-vars arg)
(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
#,arg-stx val blame neg-party))))) the-contract val blame neg-party))))))
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values #`(list #,@(filter values