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

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

@ -154,17 +154,11 @@
[(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
(list
(with-syntax ([rng-len (length rngs)])
(with-syntax ([rng-results
#'(values (rng-late-neg-projs rng-x neg-party)
...)])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
(with-contract-continuation-mark (with-contract-continuation-mark
@ -175,15 +169,31 @@
[args [args
(arrow:bad-number-of-results blame val rng-len args (arrow:bad-number-of-results blame val rng-len args
#:missing-party neg-party)])))) #:missing-party neg-party)]))))
null)]) (define (wrap-call-with-values-and-range-checking stx)
(if rngs
;; with this version, the unsafe-procedure-chaperone
;; wrappers would work only when the number of values
;; the function returns is known to be a match for
;; what the contract wants.
#;
#`(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,15 +311,14 @@
(λ (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
@ -293,65 +328,63 @@
;; 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))
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(arrow:arity-checking-wrapper val
(let ([basic-lambda-name basic-lambda])
(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda-name basic-lambda basic-unsafe-lambda
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...))))] '(opt-kwd ...))]
[(pair? req-keywords) [(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(arrow:arity-checking-wrapper val
(let ([kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
void void #t
kwd-lambda-name kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...))))] '(opt-kwd ...))]
[else [else
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(arrow:arity-checking-wrapper val
(let ([basic-lambda-name basic-lambda]
[kwd-lambda-name kwd-lambda])
(arrow:arity-checking-wrapper val
blame neg-party blame neg-party
basic-lambda-name basic-lambda #t
kwd-lambda-name kwd-lambda
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-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?)
(apply chaperone-constructor
orig-blame val orig-blame val
neg-party blame-party-info neg-party blame-party-info
rngs the-args)) 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))

35
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,7 +1300,7 @@
'(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]
@ -1319,9 +1316,11 @@
(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
#:missing-party neg-party
blame f (length other) 1 1 1)) blame f (length other) 1 1 1))
(values (rng-checker f blame neg-party) (car other))))])))) (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-->))

28
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)))))
(define proc
(if (or (not va) (pair? vr) (pair? va)) (if (or (not va) (pair? vr) (pair? va))
(make-keyword-procedure kwd-checker basic-checker-name) (make-keyword-procedure kwd-checker basic-checker-name)
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