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

only do the in-tail-position contract elimination with chaperone (or flat)

Browse Source 
contracts

closes #1829
This commit is contained in:
Robby Findler 2017-10-06 13:26:39 -05:00
parent ce30687ec6
commit 404539c894
4 changed files with 180 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-test/tests/racket/contract/prof.rkt
View File

@ -577,10 +577,11 @@
'(let () '(let ()
(define marked? #f) ; check that we measure the cost of contract-stronger? (define marked? #f) ; check that we measure the cost of contract-stronger?
(define (make/c) ; the two have to not be eq?, otherwise contract-stronger? is not called (define (make/c) ; the two have to not be eq?, otherwise contract-stronger? is not called
(make-contract #:late-neg-projection (make-chaperone-contract
#:late-neg-projection
(lambda (b) (lambda (b)
(lambda (val neg-party) (lambda (val neg-party)
(pos-blame? 'dummy))) val))
#:stronger #:stronger
(lambda (c1 c2) (lambda (c1 c2)
(when (pos-blame? 'dummy) (when (pos-blame? 'dummy)

71
pkgs/racket-test/tests/racket/contract/tail.rkt
View File

@ -2,7 +2,8 @@
(require "test-util.rkt") (require "test-util.rkt")
(parameterize ([current-contract-namespace (parameterize ([current-contract-namespace
(make-basic-contract-namespace)]) (make-basic-contract-namespace
'racket/contract/parametric)])
(contract-eval (contract-eval
`(define (counter) `(define (counter)
@ -165,4 +166,70 @@
[else (f 0)])) [else (f 0)]))
'pos 'pos
'neg)) 'neg))
(f 10)))) (f 10)))
(test/spec-passed/result
'double-wrapped-impersonators-dont-collapse.1
'(let ([α (new-∀/c 'α)])
((contract
(-> α α)
(contract
(-> α α)
(λ args (car args))
'p 'n)
'p 'n)
1))
1)
(test/spec-passed/result
'double-wrapped-impersonators-dont-collapse.2
'(let ([α (new-∀/c 'α)])
((contract
(-> α α)
(contract
(-> α α)
(λ (x) x)
'p 'n)
'p 'n)
1))
1)
(test/spec-passed/result
'double-wrapped-impersonators-dont-collapse.3
'(let ([α (new-∀/c 'α)])
((contract
(-> #:x α α)
(contract
(-> #:x α α)
(λ (#:x x) x)
'p 'n)
'p 'n)
#:x 1))
1)
(test/spec-passed/result
'double-wrapped-impersonators-dont-collapse.4
'(let ([α (new-∀/c 'α)])
((contract
(-> α any)
(contract
(-> α any)
(λ (x) 1234)
'p 'n)
'p 'n)
1))
1234)
(test/spec-passed/result
'double-wrapped-impersonators-dont-collapse.5
'(let ([α (new-∀/c 'α)])
((contract
(-> #:x α any)
(contract
(-> #:x α any)
(λ (#:x x) 1234)
'p 'n)
'p 'n)
#:x 1))
1234))

98
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -39,7 +39,7 @@
[(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)] [(optional-dom-kwd-proj ...) (nvars (length optional-dom-kwds) 'optional-dom-proj)]
[(rng-proj ...) (if rngs (generate-temporaries rngs) '())] [(rng-proj ...) (if rngs (generate-temporaries rngs) '())]
[(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())]) [(rest-proj ...) (if rest (generate-temporaries '(rest-proj)) '())])
#`(λ (blame f neg-party blame-party-info rng-ctcs #`(λ (blame f neg-party blame-party-info is-impersonator? rng-ctcs
mandatory-dom-proj ... mandatory-dom-proj ...
optional-dom-proj ... optional-dom-proj ...
rest-proj ... rest-proj ...
@ -48,7 +48,7 @@
rng-proj ...) rng-proj ...)
(define blame+neg-party (cons blame neg-party)) (define blame+neg-party (cons blame neg-party))
#,(create-chaperone #,(create-chaperone
#'blame #'neg-party #'blame+neg-party #'blame-party-info #'f #'rng-ctcs #'blame #'neg-party #'blame+neg-party #'blame-party-info #'is-impersonator? #'f #'rng-ctcs
(for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))] (for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))]
[mandatory-dom-proj (in-list mandatory-dom-projs)]) [mandatory-dom-proj (in-list mandatory-dom-projs)])
(and mandatory-dom-proj id)) (and mandatory-dom-proj id))
@ -98,7 +98,7 @@
#:missing-party neg-party #:missing-party neg-party
val "~a" msg)])) val "~a" msg)]))
(define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info (define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info is-impersonator?
val rng-ctcs val rng-ctcs
doms opt-doms doms opt-doms
req-kwds opt-kwds req-kwds opt-kwds
@ -109,7 +109,8 @@
method?) method?)
(with-syntax ([blame blame] (with-syntax ([blame blame]
[blame+neg-party blame+neg-party] [blame+neg-party blame+neg-party]
[val val]) [val val]
[is-impersonator? is-impersonator?])
(with-syntax ([(pre ...) (with-syntax ([(pre ...)
(cond (cond
[pre [pre
@ -226,23 +227,27 @@
#'(dom-x ... #'(dom-x ...
[opt-dom-x arrow:unspecified-dom] ... [opt-dom-x arrow:unspecified-dom] ...
kwd-param ...))] kwd-param ...))]
[basic-return [(basic-return basic-return/no-tail)
(let ([inner-stx-gen (let ()
(define inner-stx-gen
(if need-apply? (if need-apply?
(λ (s) #`(apply values #,@s (λ (s) #`(apply values #,@s
dom-projd-args ... dom-projd-args ...
opt+rest-uses)) opt+rest-uses))
(λ (s) #`(values (λ (s) #`(values
#,@s #,@s
dom-projd-args ...)))]) dom-projd-args ...))))
(if rngs (list (if rngs
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
(list rng-checker) (list rng-checker)
inner-stx-gen inner-stx-gen
#'(cons blame neg-party)) #'(cons blame neg-party))
(inner-stx-gen #'())))] (inner-stx-gen #'()))
(if rngs
(inner-stx-gen (list rng-checker))
(inner-stx-gen #'()))))]
[(basic-unsafe-return [(basic-unsafe-return
basic-unsafe-return/result-values-assumed basic-unsafe-return/result-values-assumed
basic-unsafe-return/result-values-assumed/no-tail) basic-unsafe-return/result-values-assumed/no-tail)
@ -297,7 +302,7 @@
(inner-stx-gen #'not-a-null assume-result-values? (inner-stx-gen #'not-a-null assume-result-values?
do-tail-check?))) do-tail-check?)))
(list (mk-return #f #t) (mk-return #t #t) (mk-return #t #f)))] (list (mk-return #f #t) (mk-return #t #t) (mk-return #t #f)))]
[kwd-return [(kwd-return kwd-return/no-tail)
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply? (if need-apply?
(λ (s k) #`(apply values (λ (s k) #`(apply values
@ -314,7 +319,7 @@
#,(inner-stx-gen s #'(kwd-results)))) #,(inner-stx-gen s #'(kwd-results))))
(λ (s) (λ (s)
(inner-stx-gen s #'(kwd-results))))]) (inner-stx-gen s #'(kwd-results))))])
#`(let ([kwd-results kwd-stx]) (list #`(let ([kwd-results kwd-stx])
#,(if rngs #,(if rngs
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract rng-ctcs
blame-party-info blame-party-info
@ -322,7 +327,11 @@
(list rng-checker) (list rng-checker)
outer-stx-gen outer-stx-gen
#'(cons blame neg-party)) #'(cons blame neg-party))
(outer-stx-gen #'()))))]) (outer-stx-gen #'())))
#`(let ([kwd-results kwd-stx])
#,(if rngs
(outer-stx-gen (list rng-checker))
(outer-stx-gen #'())))))])
;; Arrow contract domain checking is instrumented ;; Arrow contract domain checking is instrumented
;; both here, and in `arity-checking-wrapper'. ;; both here, and in `arity-checking-wrapper'.
@ -338,6 +347,12 @@
blame+neg-party blame+neg-party
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[basic-lambda/no-tail
#'(λ basic-params
(with-contract-continuation-mark
blame+neg-party
(let ()
pre ... basic-return/no-tail)))]
[basic-unsafe-lambda [basic-unsafe-lambda
#'(λ basic-params #'(λ basic-params
(let () (let ()
@ -355,42 +370,50 @@
(with-contract-continuation-mark (with-contract-continuation-mark
blame+neg-party blame+neg-party
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))]
[kwd-lambda/no-tail #`(λ kwd-lam-params
(with-contract-continuation-mark
blame+neg-party
(let ()
pre ... kwd-return/no-tail)))])
(cond (cond
[(and (null? req-keywords) (null? opt-keywords)) [(and (null? req-keywords) (null? opt-keywords))
#`(arity-checking-wrapper val #`(arity-checking-wrapper val
blame neg-party blame+neg-party blame neg-party blame+neg-party
basic-lambda basic-lambda basic-lambda/no-tail
basic-unsafe-lambda basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed basic-unsafe-lambda/result-values-assumed
basic-unsafe-lambda/result-values-assumed/no-tail basic-unsafe-lambda/result-values-assumed/no-tail
#,(and rngs (length rngs)) #,(and rngs (length rngs))
void void void
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...) '(opt-kwd ...)
#,method?)] #,method?
is-impersonator?)]
[(pair? req-keywords) [(pair? req-keywords)
#`(arity-checking-wrapper val #`(arity-checking-wrapper val
blame neg-party blame+neg-party blame neg-party blame+neg-party
void #t #f #f #f void void #t #f #f #f
kwd-lambda kwd-lambda kwd-lambda/no-tail
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...) '(opt-kwd ...)
#,method?)] #,method?
is-impersonator?)]
[else [else
#`(arity-checking-wrapper val #`(arity-checking-wrapper val
blame neg-party blame+neg-party blame neg-party blame+neg-party
basic-lambda #t #f #f #f basic-lambda basic-lambda/no-tail #t #f #f #f
kwd-lambda kwd-lambda kwd-lambda/no-tail
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...) '(opt-kwd ...)
#,method?)]))))))))) #,method?
is-impersonator?)])))))))))
;; should we pass both the basic-lambda and the kwd-lambda? ;; should we pass both the basic-lambda and the kwd-lambda?
;; if basic-unsafe-lambda is #f, returns only the one value, ;; if basic-unsafe-lambda is #f, returns only the one value,
@ -399,20 +422,25 @@
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might ;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
;; also be #t, but that happens only when we know that basic-lambda ;; also be #t, but that happens only when we know that basic-lambda
;; can't be chosen (because there are keywords involved) ;; can't be chosen (because there are keywords involved)
(define (arity-checking-wrapper val blame neg-party blame+neg-party basic-lambda (define (arity-checking-wrapper val blame neg-party blame+neg-party basic-lambda basic-lambda/no-tail
basic-unsafe-lambda basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed basic-unsafe-lambda/result-values-assumed
basic-unsafe-lambda/result-values-assumed/no-tail basic-unsafe-lambda/result-values-assumed/no-tail
contract-result-val-count contract-result-val-count
kwd-lambda kwd-lambda kwd-lambda/no-tail
min-arity max-arity min-arity max-arity
req-kwd opt-kwd req-kwd opt-kwd
method?) method?
is-impersonator?)
;; should not build this unless we are in the 'else' case (and maybe not at all) ;; should not build this unless we are in the 'else' case (and maybe not at all)
(cond (cond
[(arrow:matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) [(arrow:matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd)) (if (and (null? req-kwd) (null? opt-kwd))
(cond (cond
[is-impersonator?
(if basic-unsafe-lambda
(values basic-lambda/no-tail #f)
basic-lambda/no-tail)]
[(impersonator? val) [(impersonator? val)
(if basic-unsafe-lambda (if basic-unsafe-lambda
(values basic-lambda #f) (values basic-lambda #f)
@ -427,9 +455,15 @@
[basic-unsafe-lambda [basic-unsafe-lambda
(values basic-unsafe-lambda #t)] (values basic-unsafe-lambda #t)]
[else basic-lambda]) [else basic-lambda])
(cond
[is-impersonator?
(if basic-unsafe-lambda
(values kwd-lambda/no-tail #f)
kwd-lambda/no-tail)]
[else
(if basic-unsafe-lambda (if basic-unsafe-lambda
(values kwd-lambda #f) (values kwd-lambda #f)
kwd-lambda))] kwd-lambda)]))]
[else [else
(define-values (vr va) (procedure-keywords val)) (define-values (vr va) (procedure-keywords val))
(define all-kwds (append req-kwd opt-kwd)) (define all-kwds (append req-kwd opt-kwd))
@ -476,7 +510,9 @@
(arrow:raise-wrong-number-of-args-error (arrow:raise-wrong-number-of-args-error
blame #:missing-party neg-party val blame #:missing-party neg-party val
args-len min-arity max-arity method?)) args-len min-arity max-arity method?))
(apply basic-lambda args)))) (if is-impersonator?
(apply basic-lambda/no-tail args)
(apply basic-lambda args)))))
(λ args (λ args
(raise-blame-error (blame-swap blame) #:missing-party neg-party val (raise-blame-error (blame-swap blame) #:missing-party neg-party val
"expected required keyword ~a" "expected required keyword ~a"
@ -500,7 +536,7 @@
r r
(cons (c x neg-party) r))) (cons (c x neg-party) r)))
(define (->-proj chaperone? ctc (define (->-proj is-impersonator? ctc
;; fields of the 'ctc' struct ;; fields of the 'ctc' struct
min-arity doms kwd-infos rest pre? rngs post? min-arity doms kwd-infos rest pre? rngs post?
plus-one-arity-function chaperone-constructor method? plus-one-arity-function chaperone-constructor method?
@ -571,11 +607,11 @@
(apply chaperone-constructor (apply chaperone-constructor
orig-blame val orig-blame val
neg-party blame-party-info neg-party blame-party-info
rngs the-args)) is-impersonator? rngs the-args))
(define chaperone-or-impersonate-procedure (define chaperone-or-impersonate-procedure
(if use-unsafe-chaperone-procedure? (if use-unsafe-chaperone-procedure?
(if chaperone? unsafe-chaperone-procedure unsafe-impersonate-procedure) (if is-impersonator? unsafe-impersonate-procedure unsafe-chaperone-procedure)
(if chaperone? chaperone-procedure impersonate-procedure))) (if is-impersonator? impersonate-procedure chaperone-procedure)))
(cond (cond
[chap/imp-func [chap/imp-func
(if (or post? (not rngs)) (if (or post? (not rngs))

23
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -1203,7 +1203,7 @@
optional-keywords optional-keywords
(and rest-contract #t) (and rest-contract #t)
rng-len) rng-len)
(λ (blame f neg-party blame-party-info rng-ctc-x . args) (λ (blame f neg-party blame-party-info is-impersonator? rng-ctc-x . args)
(define-next next args) (define-next next args)
(define mandatory-dom-projs (next min-arity)) (define mandatory-dom-projs (next min-arity))
(define optional-dom-projs (next optionals)) (define optional-dom-projs (next optionals))
@ -1262,10 +1262,12 @@
args-dealt-with))))) args-dealt-with)))))
(values (arity-checking-wrapper f blame neg-party blame+neg-party (values (arity-checking-wrapper f blame neg-party blame+neg-party
interposition-proc #f interposition-proc #f #f #f interposition-proc interposition-proc
#f interposition-proc interposition-proc #f #f #f
min-arity max-arity min-arity max-arity
mandatory-keywords optional-keywords mandatory-keywords optional-keywords
#f) ; not a method contract #f ; not a method contract
is-impersonator?)
#f)))) #f))))
(build--> 'dynamic->* (build--> 'dynamic->*
@ -1473,13 +1475,13 @@
(keywords-match man-kwds opt-kwds x) (keywords-match man-kwds opt-kwds x)
#t)) #t))
(define (make-property chaperone?) (define (make-property is-impersonator?)
(define build-X-property (define build-X-property
(if chaperone? build-chaperone-contract-property build-contract-property)) (if is-impersonator? build-contract-property build-chaperone-contract-property))
(define val-first-proj (define val-first-proj
(λ (->stct) (λ (->stct)
(maybe-warn-about-val-first ->stct) (maybe-warn-about-val-first ->stct)
(->-proj chaperone? ->stct (->-proj is-impersonator? ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
(base->-doms ->stct) (base->-doms ->stct)
(base->-kwd-infos ->stct) (base->-kwd-infos ->stct)
@ -1493,7 +1495,7 @@
#f))) #f)))
(define late-neg-proj (define late-neg-proj
(λ (->stct) (λ (->stct)
(->-proj chaperone? ->stct (->-proj is-impersonator? ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
(base->-doms ->stct) (base->-doms ->stct)
(base->-kwd-infos ->stct) (base->-kwd-infos ->stct)
@ -1545,13 +1547,13 @@
(not (base->-post? that)))) (not (base->-post? that))))
(define-struct (-> base->) () (define-struct (-> base->) ()
#:property prop:chaperone-contract (make-property #t)) #:property prop:chaperone-contract (make-property #f))
(define-struct (predicate/c base->) () (define-struct (predicate/c base->) ()
#:property prop:chaperone-contract (make-property #t)) #:property prop:chaperone-contract (make-property #f))
(define-struct (impersonator-> base->) () (define-struct (impersonator-> base->) ()
#:property prop:contract (make-property #f)) #:property prop:contract (make-property #t))
(define ->void-contract (define ->void-contract
(let-syntax ([get-chaperone-constructor (let-syntax ([get-chaperone-constructor
@ -1621,6 +1623,7 @@
1)) 1))
(λ (blame f neg-party (λ (blame f neg-party
_ignored-blame-party-info _ignored-blame-party-info
_ignored-is-impersonator?
_ignored-rng-ctcs _ignored-rng-ctcs
_ignored-dom-contract _ignored-dom-contract
_ignored-rng-contract) _ignored-rng-contract)