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

use unsafe-{chaperone,impersonate}-procedure in racket/contract

Browse Source 
for contracts where the arity of the given function is exactly
the arity that the contract expects (i.e. no optional arguments
are turned into madatory or dropped)
This commit is contained in:
Robby Findler 2016-01-15 10:41:44 -06:00
parent 41c8d5bc27
commit 308c918a42
3 changed files with 189 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -154,36 +154,46 @@
[(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))] [(opt-kwd-x ...) (generate-temporaries (map car opt-kwds))]
[(rng-late-neg-projs ...) (if rngs rngs '())] [(rng-late-neg-projs ...) (if rngs rngs '())]
[(rng-x ...) (if rngs (generate-temporaries rngs) '())]) [(rng-x ...) (if rngs (generate-temporaries rngs) '())])
(with-syntax ([(rng-checker-name ...)
(if rngs (define rng-checker
(list (gen-id 'rng-checker)) (and rngs
null)] (with-syntax ([rng-len (length rngs)]
[(rng-checker ...) [rng-results #'(values (rng-late-neg-projs rng-x neg-party) ...)])
(if rngs #'(case-lambda
(list [(rng-x ...)
(with-syntax ([rng-len (length rngs)]) (with-contract-continuation-mark
(with-syntax ([rng-results (cons blame neg-party)
#'(values (rng-late-neg-projs rng-x neg-party) (let ()
...)]) post ...
#'(case-lambda rng-results))]
[(rng-x ...) [args
(with-contract-continuation-mark (arrow:bad-number-of-results blame val rng-len args
(cons blame neg-party) #:missing-party neg-party)]))))
(let () (define (wrap-call-with-values-and-range-checking stx)
post ... (if rngs
rng-results))] ;; with this version, the unsafe-procedure-chaperone
[args ;; wrappers would work only when the number of values
(arrow:bad-number-of-results blame val rng-len args ;; the function returns is known to be a match for
#:missing-party neg-party)])))) ;; what the contract wants.
null)]) #;
#`(let-values ([(rng-x ...) #,stx])
(with-contract-continuation-mark
(cons blame neg-party)
(let ()
post ...
(values (rng-late-neg-projs rng-x neg-party) ...))))
#`(call-with-values
(λ () #,stx)
#,rng-checker)
stx))
(let* ([min-method-arity (length doms)] (let* ([min-method-arity (length doms)]
[max-method-arity (+ min-method-arity (length opt-doms))] [max-method-arity (+ min-method-arity (length opt-doms))]
[min-arity (+ (length this-args) min-method-arity)] [min-arity (+ (length this-args) min-method-arity)]
[max-arity (+ min-arity (length opt-doms))] [max-arity (+ min-arity (length opt-doms))]
[req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)] [req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)] [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
[need-apply-values? (or dom-rest (not (null? opt-doms)))] [need-apply? (or dom-rest (not (null? opt-doms)))])
[no-rng-checking? (not rngs)])
(with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)] (with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)]
[basic-params [basic-params
(cond (cond
@ -227,6 +237,7 @@
(for/fold ([s #'null]) (for/fold ([s #'null])
([tx (in-list (map cdr put-in-reverse))]) ([tx (in-list (map cdr put-in-reverse))])
(tx s)))]) (tx s)))])
(with-syntax ([kwd-lam-params (with-syntax ([kwd-lam-params
(if dom-rest (if dom-rest
#'(this-param ... #'(this-param ...
@ -239,7 +250,7 @@
kwd-param ...))] kwd-param ...))]
[basic-return [basic-return
(let ([inner-stx-gen (let ([inner-stx-gen
(if need-apply-values? (if need-apply?
(λ (s) #`(apply values #,@s (λ (s) #`(apply values #,@s
this-param ... this-param ...
dom-projd-args ... dom-projd-args ...
@ -248,16 +259,41 @@
#,@s #,@s
this-param ... this-param ...
dom-projd-args ...)))]) dom-projd-args ...)))])
(if no-rng-checking? (if rngs
(inner-stx-gen #'())
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
#'(rng-checker-name ...) (list rng-checker)
inner-stx-gen)))] inner-stx-gen)
(inner-stx-gen #'())))]
[basic-unsafe-return
(let ([inner-stx-gen
(λ (stuff)
(define the-call/no-marks
(if need-apply?
#`(apply val
this-param ...
dom-projd-args ...
opt+rest-uses)
#`(val this-param ... dom-projd-args ...)))
(define the-call
#`(with-continuation-mark arrow:tail-contract-key
(list* neg-party blame-party-info #,rng-ctcs)
#,the-call/no-marks))
(cond
[(null? (syntax-e stuff)) ;; surely there must a better way
the-call]
[else (wrap-call-with-values-and-range-checking the-call)]))])
(if rngs
(arrow:check-tail-contract rng-ctcs
blame-party-info
neg-party
#'not-a-null
inner-stx-gen)
(inner-stx-gen #'())))]
[kwd-return [kwd-return
(let* ([inner-stx-gen (let* ([inner-stx-gen
(if need-apply-values? (if need-apply?
(λ (s k) #`(apply values (λ (s k) #`(apply values
#,@s #,@k #,@s #,@k
this-param ... this-param ...
@ -275,83 +311,80 @@
(λ (s) (λ (s)
(inner-stx-gen s #'(kwd-results))))]) (inner-stx-gen s #'(kwd-results))))])
#`(let ([kwd-results kwd-stx]) #`(let ([kwd-results kwd-stx])
#,(if no-rng-checking? #,(if rngs
(outer-stx-gen #'())
(arrow:check-tail-contract rng-ctcs (arrow:check-tail-contract rng-ctcs
blame-party-info blame-party-info
neg-party neg-party
#'(rng-checker-name ...) (list rng-checker)
outer-stx-gen))))]) outer-stx-gen)
(with-syntax ([basic-lambda-name (gen-id 'basic-lambda)] (outer-stx-gen #'()))))])
[basic-lambda #'(λ basic-params
;; 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'.
;; We need to instrument here, because sometimes ;; We need to instrument here, because sometimes
;; a-c-w doesn't wrap, and just returns us. ;; a-c-w doesn't wrap, and just returns us.
;; We need to instrument in a-c-w to count arity ;; We need to instrument in a-c-w to count arity
;; checking time. ;; checking time.
;; Overhead of double-wrapping has not been ;; Overhead of double-wrapping has not been
;; noticeable in my measurements so far. ;; noticeable in my measurements so far.
;; - stamourv ;; - stamourv
(with-syntax ([basic-lambda #'(λ basic-params
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... basic-return)))] pre ... basic-return)))]
[basic-unsafe-lambda #'(λ basic-params
(with-contract-continuation-mark
(cons blame neg-party)
(let ()
pre ... basic-unsafe-return)))]
[kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda-name (gen-id 'kwd-lambda)]
[kwd-lambda #`(λ kwd-lam-params [kwd-lambda #`(λ kwd-lam-params
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
(let () (let ()
pre ... kwd-return)))]) pre ... kwd-return)))])
(with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))]) (cond
(cond [(and (null? req-keywords) (null? opt-keywords))
[(and (null? req-keywords) (null? opt-keywords)) #`(arrow:arity-checking-wrapper val
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) blame neg-party
(let ([basic-lambda-name basic-lambda]) basic-lambda basic-unsafe-lambda
(arrow:arity-checking-wrapper val void
blame neg-party #,min-method-arity
basic-lambda-name #,max-method-arity
void #,min-arity
#,min-method-arity #,(if dom-rest #f max-arity)
#,max-method-arity '(req-kwd ...)
#,min-arity '(opt-kwd ...))]
#,(if dom-rest #f max-arity) [(pair? req-keywords)
'(req-kwd ...) #`(arrow:arity-checking-wrapper val
'(opt-kwd ...))))] blame neg-party
[(pair? req-keywords) void #t
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) kwd-lambda
(let ([kwd-lambda-name kwd-lambda]) #,min-method-arity
(arrow:arity-checking-wrapper val #,max-method-arity
blame neg-party #,min-arity
void #,(if dom-rest #f max-arity)
kwd-lambda-name '(req-kwd ...)
#,min-method-arity '(opt-kwd ...))]
#,max-method-arity [else
#,min-arity #`(arrow:arity-checking-wrapper val
#,(if dom-rest #f max-arity) blame neg-party
'(req-kwd ...) basic-lambda #t
'(opt-kwd ...))))] kwd-lambda
[else #,min-method-arity
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #,max-method-arity
(let ([basic-lambda-name basic-lambda] #,min-arity
[kwd-lambda-name kwd-lambda]) #,(if dom-rest #f max-arity)
(arrow:arity-checking-wrapper val '(req-kwd ...)
blame neg-party '(opt-kwd ...))])))))))))
basic-lambda-name
kwd-lambda-name
#,min-method-arity
#,max-method-arity
#,min-arity
#,(if dom-rest #f max-arity)
'(req-kwd ...)
'(opt-kwd ...))))])))))))))))
(define (maybe-cons-kwd c x r neg-party) (define (maybe-cons-kwd c x r neg-party)
(if (eq? arrow:unspecified-dom x) (if (eq? arrow:unspecified-dom x)
r r
(cons (c x neg-party) r))) (cons (c x neg-party) r)))
(define (->-proj chaperone-or-impersonate-procedure ctc (define (->-proj chaperone? 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 plus-one-arity-function chaperone-constructor
@ -414,10 +447,15 @@
(if partial-rest (list partial-rest) '()))) (if partial-rest (list partial-rest) '())))
(define blame-party-info (arrow:get-blame-party-info orig-blame)) (define blame-party-info (arrow:get-blame-party-info orig-blame))
(define (successfully-got-the-right-kind-of-function val neg-party) (define (successfully-got-the-right-kind-of-function val neg-party)
(define chap/imp-func (apply chaperone-constructor (define-values (chap/imp-func use-unsafe-chaperone-procedure?)
orig-blame val (apply chaperone-constructor
neg-party blame-party-info orig-blame val
rngs the-args)) neg-party blame-party-info
rngs the-args))
(define chaperone-or-impersonate-procedure
(if use-unsafe-chaperone-procedure?
(if chaperone? unsafe-chaperone-procedure unsafe-impersonate-procedure)
(if chaperone? chaperone-procedure impersonate-procedure)))
(cond (cond
[chap/imp-func [chap/imp-func
(if (or post? (not rngs)) (if (or post? (not rngs))

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

@ -962,11 +962,12 @@
(cons result-checker args-dealt-with) (cons result-checker args-dealt-with)
args-dealt-with))))) args-dealt-with)))))
(arrow:arity-checking-wrapper f blame neg-party (values (arrow:arity-checking-wrapper f blame neg-party
interposition-proc interposition-proc interposition-proc #f interposition-proc
min-arity max-arity min-arity max-arity
min-arity max-arity min-arity max-arity
mandatory-keywords optional-keywords)))) mandatory-keywords optional-keywords)
#f))))
(build--> 'dynamic->* (build--> 'dynamic->*
mandatory-domain-contracts optional-domain-contracts mandatory-domain-contracts optional-domain-contracts
@ -1159,11 +1160,13 @@
(arrow:keywords-match man-kwds opt-kwds x) (arrow:keywords-match man-kwds opt-kwds x)
#t)) #t))
(define (make-property build-X-property chaperone-or-impersonate-procedure) (define (make-property chaperone?)
(define build-X-property
(if chaperone? build-chaperone-contract-property build-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-or-impersonate-procedure ->stct (->-proj chaperone? ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
(base->-doms ->stct) (base->-doms ->stct)
(base->-kwd-infos ->stct) (base->-kwd-infos ->stct)
@ -1176,7 +1179,7 @@
#f))) #f)))
(define late-neg-proj (define late-neg-proj
(λ (->stct) (λ (->stct)
(->-proj chaperone-or-impersonate-procedure ->stct (->-proj chaperone? ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
(base->-doms ->stct) (base->-doms ->stct)
(base->-kwd-infos ->stct) (base->-kwd-infos ->stct)
@ -1227,19 +1230,13 @@
(not (base->-post? that)))) (not (base->-post? that))))
(define-struct (-> base->) () (define-struct (-> base->) ()
#:property #:property prop:chaperone-contract (make-property #t))
prop:chaperone-contract
(make-property build-chaperone-contract-property chaperone-procedure))
(define-struct (predicate/c base->) () (define-struct (predicate/c base->) ()
#:property #:property prop:chaperone-contract (make-property #t))
prop:chaperone-contract
(make-property build-chaperone-contract-property chaperone-procedure))
(define-struct (impersonator-> base->) () (define-struct (impersonator-> base->) ()
#:property #:property prop:contract (make-property #f))
prop:contract
(make-property build-contract-property impersonate-procedure))
(define ->void-contract (define ->void-contract
(let-syntax ([get-chaperone-constructor (let-syntax ([get-chaperone-constructor
@ -1303,25 +1300,27 @@
'(expected: "a procedure that accepts 1 non-keyword argument" '(expected: "a procedure that accepts 1 non-keyword argument"
given: "~e") given: "~e")
f)) f))
(cond (values (cond
[(and (struct-predicate-procedure? f) [(and (struct-predicate-procedure? f)
(not (impersonator? f))) (not (impersonator? f)))
#f] #f]
[(and (equal? (procedure-arity f) 1) [(and (equal? (procedure-arity f) 1)
(let-values ([(required mandatory) (procedure-keywords f)]) (let-values ([(required mandatory) (procedure-keywords f)])
(and (null? required) (and (null? required)
(null? mandatory)))) (null? mandatory))))
(λ (arg) (λ (arg)
(values (rng-checker f blame neg-party) arg))] (values (rng-checker f blame neg-party) arg))]
[(procedure-arity-includes? f 1) [(procedure-arity-includes? f 1)
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . other) (λ (kwds kwd-args . other)
(unless (null? kwds) (unless (null? kwds)
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds)) (arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds))
(unless (= 1 (length other)) (unless (= 1 (length other))
(arrow:raise-wrong-number-of-args-error #:missing-party neg-party (arrow:raise-wrong-number-of-args-error
blame f (length other) 1 1 1)) #:missing-party neg-party
(values (rng-checker f blame neg-party) (car other))))])))) blame f (length other) 1 1 1))
(values (rng-checker f blame neg-party) (car other))))])
#f))))
(define -predicate/c (mk-any/c->boolean-contract predicate/c)) (define -predicate/c (mk-any/c->boolean-contract predicate/c))
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->)) (define any/c->boolean-contract (mk-any/c->boolean-contract make-->))

32
racket/collects/racket/contract/private/arrow.rkt
View File

@ -398,7 +398,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
basic-lambda-name basic-lambda-name #f
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -410,7 +410,7 @@
#`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
void void #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -423,7 +423,7 @@
(let ([basic-lambda-name basic-lambda] (let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda]) [kwd-lambda-name kwd-lambda])
(arity-checking-wrapper val blame neg-party (arity-checking-wrapper val blame neg-party
basic-lambda-name basic-lambda-name #f
kwd-lambda-name kwd-lambda-name
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
@ -433,15 +433,25 @@
'(opt-kwd ...))))]))))))))))) '(opt-kwd ...))))])))))))))))
;; should we pass both the basic-lambda and the kwd-lambda? ;; should we pass both the basic-lambda and the kwd-lambda?
(define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda ;; if basic-unsafe-lambda is #f, returns only the one value,
;; namely the chaperone wrapper. Otherwise, returns two values,
;; a procedure and a boolean indicating it the procedure is the
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
;; also be #f, but that happens only when we know that basic-lambda
;; can't be chosen (because there are keywords involved)
(define (arity-checking-wrapper val blame neg-party basic-lambda basic-unsafe-lambda kwd-lambda
min-method-arity max-method-arity min-arity max-arity min-method-arity max-method-arity min-arity max-arity
req-kwd opt-kwd) req-kwd opt-kwd)
;; 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
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) [(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))
basic-lambda (if basic-unsafe-lambda
kwd-lambda)] (values basic-unsafe-lambda #t)
basic-lambda)
(if basic-unsafe-lambda
(values kwd-lambda #f)
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))
@ -493,9 +503,13 @@
(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"
(car req-kwd))))) (car req-kwd)))))
(if (or (not va) (pair? vr) (pair? va)) (define proc
(make-keyword-procedure kwd-checker basic-checker-name) (if (or (not va) (pair? vr) (pair? va))
basic-checker-name)])) (make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name))
(if basic-unsafe-lambda
(values proc #f)
proc)]))
(define (raise-wrong-number-of-args-error (define (raise-wrong-number-of-args-error
blame #:missing-party [missing-party #f] val blame #:missing-party [missing-party #f] val