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

wrap-expr/c: improve performance, add #:arg?, fix pos/neg args

Browse Source 
- Improve performance by using make-apply-contract, lifting,
  fast path for dependent flat contracts.
- The positive blame party now consistently means the *macro def*
  and the negative party means the *macro use*. The #:arg? argument
  controls blame swapping.
This commit is contained in:
Ryan Culpepper 2018-12-30 18:06:11 -06:00
parent 5f77da9f5d
commit 5ada142ee9
10 changed files with 376 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/racket-doc/syntax/scribblings/contract.scrbl
View File

@ -14,14 +14,15 @@ contracts to macro subexpressions.
@defproc[(wrap-expr/c [contract-expr syntax?]
[expr syntax?]
[#:arg? arg? any/c #t]
[#:positive pos-blame
(or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
'use-site]
'from-macro]
[#:negative neg-blame
(or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
'from-macro]
'use-site]
[#:name expr-name
(or/c identifier? symbol? string? #f) #f]
[#:macro macro-name
@ -68,7 +69,9 @@ The other arguments have the same meaning as for @racket[expr/c].
(app (lambda (x) 'pear) 5)
]
@history[#:added "6.3"]{}
}
@history[#:added "6.3" #:changed "7.2.0.3" @elem{Added the
@racket[#:arg?] keyword argument and changed the default values and
interpretation of the @racket[#:positive] and @racket[#:negative]
arguments.}]}
@close-eval[the-eval]

21
pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl
View File

@ -40,4 +40,25 @@ expressions. The @racket[expr/c] syntax class does not change how
pattern variables are bound; it only computes an attribute that
represents the checked expression.
The previous example shows a macro applying a contract on an argument,
but a macro can also apply a contract to an expression that it
produces. In that case, it should use @racket[#:arg? #f] to indicate
that the macro, not the calling context, is responsible for expression
produced.
@interaction[#:eval the-eval
(code:comment "BUG: rationals not closed under inversion")
(define-syntax (invert stx)
(syntax-parse stx
[(_ e)
#:declare e (expr/c #'rational?)
#:with result #'(/ 1 e.c)
#:declare result (expr/c #'rational? #:arg? #f)
#'result.c]))
(invert 4)
(invert 'abc)
(invert 0.0)
]
@(close-eval the-eval)

37
pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl
View File

@ -84,28 +84,36 @@ using @racket[#:literals] or @racket[~literal].
state under the key @racket['literals].}]}
@defstxclass[(expr/c [contract-expr syntax?]
[#:arg? arg? any/c #t]
[#:positive pos-blame
(or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown)
'use-site]
'from-macro]
[#:negative neg-blame
(or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown)
'from-macro]
'use-site]
[#:name expr-name (or/c identifier? string? symbol?) #f]
[#:macro macro-name (or/c identifier? string? symbol?) #f]
[#:context ctx (or/c syntax? #f) #, @elem{determined automatically}])]{
[#:context context (or/c syntax? #f) #, @elem{determined automatically}])]{
Accepts an expression (@racket[expr]) and computes an attribute
@racket[c] that represents the expression wrapped with the contract
represented by @racket[contract-expr].
represented by @racket[contract-expr]. Note that
@racket[contract-expr] is potentially evaluated each time the code
generated by the macro is run; for the best performance,
@racket[contract-expr] should be a variable reference.
The contract's positive blame represents the obligations of the
expression being wrapped. The negative blame represents the
obligations of the macro imposing the contract---the ultimate user
of @racket[expr/c]. By default, the positive blame is taken as
the module currently being expanded, and the negative blame is
inferred from the definition site of the macro (itself inferred from
the @racket[context] argument), but both blame locations can be
overridden.
The positive blame represents the obligations of the macro imposing
the contract---the ultimate user of @racket[expr/c]. The contract's
negative blame represents the obligations of the expression being
wrapped. By default, the positive blame is inferred from the
definition site of the macro (itself inferred from the
@racket[context] argument), and the negative blame is taken as the
module currently being expanded, but both blame locations can be
overridden. When @racket[arg?] is @racket[#t], the term being matched
is interpreted as an argument (that is, coming from the negative
party); when @racket[arg?] is @racket[#f], the term being matched is
interpreted as a result of the macro (that is, coming from the
positive party).
The @racket[pos-blame] and @racket[neg-blame] arguments are turned
into blame locations as follows:
@ -151,7 +159,10 @@ See @secref{exprc} for an example.
@racket[c] attribute. The @racket[expr/c] syntax class does not change how
pattern variables are bound; it only computes an attribute that
represents the checked expression.
}
@history[#:changed "7.2.0.3" @elem{Added the @racket[#:arg?] keyword
argument and changed the default values and interpretation of the
@racket[#:positive] and @racket[#:negative] arguments.}]}
@section{Literal Sets}

70
pkgs/racket-test/tests/stxparse/test-exprc.rkt Normal file
View File

@ -0,0 +1,70 @@
#lang racket/base
(require (for-syntax racket/base syntax/parse)
racket/contract
rackunit)
;; See also tests/syntax/contract/test-errors.rkt.
(define-syntax (m-str stx)
(syntax-parse stx
[(_ e)
#:declare e (expr/c #'string?)
#'e.c]))
(check-equal? (m-str "string") "string")
(check-exn #rx"m-str: contract violation.*expected: string?"
(lambda () (m-str 'not-a-string)))
(define-syntax (m-arr stx)
(syntax-parse stx
[(_ f arg)
#:declare f (expr/c #'(-> string? any))
#'(f.c arg)]))
(check-equal? (m-arr string->symbol "a") 'a)
(check-exn #rx"m-arr: broke its own contract.*promised: string?"
(lambda () (m-arr string->symbol 'a)))
(define-syntax (m-app stx)
(syntax-parse stx
[(_ ctc f arg)
#:declare f (expr/c #'ctc)
#'(f.c arg)]))
(check-equal? (m-app (-> string? symbol?) string->symbol "A") 'A)
(check-equal? ((m-app (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t)))
"abc")
"def")
"abcdef")
(check-exn #rx"m-app: broke its own contract.*promised: string?"
;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments.
(lambda ()
((m-app (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t)))
"abc")
'def)))
(define-syntax (m-res stx)
(syntax-parse stx
[(_ ctc v)
#:declare v (expr/c #'ctc #:arg? #f)
#'v.c]))
(check-equal? (m-res string? "hello") "hello")
(check-equal? (((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
"abc") "def")
"abcdef")
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
'abc) "def")))
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (-> string? (-> string? string?))
(lambda (s) (lambda (t) (string-append s t))))
"abc") 'def)))

18
pkgs/racket-test/tests/syntax/contract/perf-liftable.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket/base
;; Microbenchmark for expr/c with liftable contract.
(module helper racket/base
(require (for-syntax racket/base syntax/parse))
(struct point (x y))
(define origin (point 0 0))
(define-syntax foo
(syntax-parser
[(_ (~var e (expr/c #'point?)))
#'e.c]))
(provide foo origin))
(require 'helper)
(time
(for ([i (in-range #e1e6)])
(foo origin)))

19
pkgs/racket-test/tests/syntax/contract/perf-nolift-result.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang racket/base
(require (for-syntax racket/base syntax/parse))
;; Microbenchmark for expr/c with non-liftable *result* contract.
;; See perf-nolift.rkt. The corresponding dependent contract is
;;
;; (->i ([c contract?] [v any/c]) [_ (c) c])
(struct point (x y))
(define origin (point 0 0))
(define-syntax foo
(syntax-parser
[(_ (~var e (expr/c #'point? #:arg? #f)))
#'e.c]))
(time
(for ([i (in-range #e1e6)])
(foo origin)))

24
pkgs/racket-test/tests/syntax/contract/perf-nolift.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket/base
(require (for-syntax racket/base syntax/parse))
;; Microbenchmark for expr/c with non-liftable contract.
;; The contract expression cannot be lifted because point? is defined
;; in the same module, and expr/c cannot be sure that the contract
;; would be lifted to a point before the definition.
;; On the other hand, this should be no worse than a dependent contract like
;;
;; (->i ([c contract?] [v (c) c]) any)
(struct point (x y))
(define origin (point 0 0))
(define-syntax foo
(syntax-parser
[(_ (~var e (expr/c #'point?)))
#'e.c]))
(time
(for ([i (in-range #e1e6)])
(foo origin)))

81
pkgs/racket-test/tests/syntax/contract/test-errors.rkt Normal file
View File

@ -0,0 +1,81 @@
#lang racket/base
(require (for-syntax racket/base syntax/contract)
racket/contract
rackunit)
(define-syntax (m-str stx)
(syntax-case stx ()
[(_ e)
(wrap-expr/c #'string? #'e #:context stx)]))
(check-equal? (m-str "string") "string")
(check-exn #rx"m-str: contract violation.*expected: string?"
(lambda () (m-str 'not-a-string)))
(define-syntax (m-arr stx)
(syntax-case stx ()
[(_ f arg)
(with-syntax ([f* (wrap-expr/c #'(-> string? any) #'f #:context stx)])
#'(f* arg))]))
(check-equal? (m-arr string->symbol "a") 'a)
(check-exn #rx"m-arr: broke its own contract.*promised: string?"
(lambda () (m-arr string->symbol 'a)))
(define-syntax (m-app stx)
(syntax-case stx ()
[(_ f ctc arg)
(with-syntax ([f* (wrap-expr/c #'ctc #'f #:context stx)])
#'(f* arg))]))
(check-equal? (m-app string->symbol (-> string? symbol?) "A") 'A)
(check-equal? ((m-app (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?))
"abc")
"def")
"abcdef")
(check-exn #rx"m-app: broke its own contract.*promised: string?"
;; Yes, it's m-app's fault, because it didn't protect
;; f from bad arguments.
(lambda ()
((m-app (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?))
"abc")
'def)))
(define-syntax (m-res stx)
(syntax-case stx ()
[(_ v ctc)
(wrap-expr/c #'ctc #'v #:arg? #f #:context stx)]))
(check-equal? (m-res "hello" string?) "hello")
(check-equal? (((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
"abc") "def")
"abcdef")
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
'abc) "def")))
(check-exn #rx"m-res: contract violation.*expected: string?"
(lambda ()
(((m-res (lambda (s) (lambda (t) (string-append s t)))
(-> string? (-> string? string?)))
"abc") 'def)))
(let ()
(define fruit/c (and/c string? (or/c "orange" "peach" "strawberry")))
(define-syntax (smoothie stx)
(syntax-case stx ()
[(_ ing)
(with-syntax ([ing.c (wrap-expr/c #'fruit/c #'ing #:context stx)])
#'(format "icy blended ~s" ing.c))]))
(check-exn
(regexp
(string-append
"^smoothie: contract violation.*"
"given: \"kale\".*"
"in:.*\\(and/c string[?] \\(or/c \"orange\" \"peach\" \"strawberry\"\\)\\).*"))
(lambda () (smoothie "kale"))))

167
racket/collects/syntax/contract.rkt
View File

@ -1,7 +1,6 @@
#lang racket/base
(require racket/contract/base
(for-template racket/base
racket/contract/base
syntax/location)
syntax/srcloc
syntax/modcollapse
@ -10,7 +9,8 @@
(provide/contract
[wrap-expr/c
(->* (syntax? syntax?)
(#:positive (or/c syntax? string? module-path-index?
(#:arg? any/c
#:positive (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
#:negative (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
@ -19,30 +19,107 @@
#:context (or/c syntax? #f))
syntax?)])
(module macro-arg/c racket/base
(require racket/contract/base
racket/contract/combinator)
(module runtime racket/base
(require (for-syntax racket/base
syntax/free-vars)
racket/contract/base
racket/contract/combinator
(only-in racket/contract/private/base
make-apply-contract))
(provide expr/contract
relative-source)
(provide macro-arg/c)
(define (macro-expr/c arg? expr-name ctc0)
(define ctc (coerce-contract 'wrap-expr/c ctc0))
(define proj (get/build-late-neg-projection ctc))
(make-contract
#:name (unquoted-printing-string
(format "macro ~a contract~a~a"
(if arg? "argument" "result")
(if expr-name " on " "")
(if expr-name expr-name "")))
#:first-order (contract-first-order ctc)
#:late-neg-projection
(λ (blame)
(define blame* (blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?))
(proj (blame-swap blame)))
#:list-contract? (list-contract? ctc)))
(define (macro-arg/c macro-name ctc)
(let ([ctc-project (get/build-late-neg-projection (coerce-contract 'wrap-expr/c ctc))])
((cond [(flat-contract? ctc) make-flat-contract]
[(chaperone-contract? ctc) make-chaperone-contract]
[else make-contract])
#:name (contract-name ctc)
#:first-order (contract-first-order ctc)
#:late-neg-projection
(λ (blame)
(let ([blame* (if macro-name (blame-add-context blame #f #:important macro-name) blame)])
(ctc-project (blame-swap blame*))))
#:list-contract? (list-contract? ctc)))))
(define (macro-dep-expr/c arg? expr-name)
(make-contract
#:name (unquoted-printing-string
(format "macro ~a contract~a~a"
(if arg? "argument" "result")
(if expr-name " on " "")
(if expr-name expr-name "")))
#:late-neg-projection
(lambda (blame)
(lambda (_f neg)
;; Note: specialized to _f = return-second-arg.
(lambda (c v)
(define (slow-path)
(define ctc (coerce-contract 'wrap-expr/c c))
(define proj (get/build-late-neg-projection ctc))
(define blame*
(blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?))
((proj blame*) v neg))
(cond [(flat-contract? c)
(let ([c (if (procedure? c) c (coerce-contract 'wrap-expr/c c))])
(if (c v) v (slow-path)))]
[else (slow-path)]))))))
(require (for-template 'macro-arg/c))
(define (return-second-arg c v) v)
(begin-for-syntax
(define (okay-to-lift? ee)
(and (identifier? ee) (not (local-free-vars? ee))))
(define (self-module-path-index? mpi)
(define-values (rel base) (module-path-index-split mpi))
(and (eq? rel #f) (eq? (module-path-index-submodule mpi) #f)))
(define (local-free-vars? ee)
(for/or ([fv (in-list (free-vars ee #:module-bound? #t))])
(define b (identifier-binding fv))
(cond [(list? b) (self-module-path-index? (car b))]
[else #t]))))
(define-syntax (expr/contract stx)
(cond
[(eq? (syntax-local-context) 'expression)
(syntax-case stx ()
[(_ val-expr ctc-expr arg? expr-name [mac-arg ...])
(let ([ctc-ee (local-expand #'ctc-expr 'expression null)])
(cond [(okay-to-lift? ctc-ee)
#`(#,(syntax-local-lift-expression
#`(make-apply-contract
(macro-expr/c arg? expr-name #,ctc-ee)
mac-arg ...))
val-expr)]
[else
#`(#,(syntax-local-lift-expression
#`((make-apply-contract
(macro-dep-expr/c arg? expr-name)
mac-arg ...)
return-second-arg))
#,ctc-ee
val-expr)]))])]
[else #`(#%expression #,stx)]))
(define (relative-source base-mpi rel-mod-path)
(define r
(resolved-module-path-name
(module-path-index-resolve
(module-path-index-join rel-mod-path base-mpi))))
(cond [(pair? r)
(cons 'submod r)]
[(symbol? r)
(list 'quote r)]
[else r])))
(require (for-template (submod "." runtime)))
(define (wrap-expr/c ctc-expr expr
#:positive [pos-source 'use-site]
#:negative [neg-source 'from-macro]
#:arg? [arg? #t]
#:positive [pos-source 'from-macro]
#:negative [neg-source 'use-site]
#:name [expr-name #f]
#:macro [macro-name #f]
#:context [ctx (current-syntax-context)])
@ -63,32 +140,14 @@
(syntax-case ctx ()
[(x . _) (identifier? #'x) (syntax-e #'x)]
[x (identifier? #'x) (syntax-e #'x)]
[_ #f])]
[else #f])])
(base-wrap-expr/c expr #`(macro-arg/c '#,macro-name #,ctc-expr)
#:positive pos-source-expr
#:negative neg-source-expr
#:expr-name (cond [(and macro-name expr-name)
(format "~a of ~a" expr-name macro-name)]
[(or macro-name expr-name)
=> (λ (name) (format "~a" name))]
[else #f])
#:source #`(quote-syntax #,expr))))
(define (base-wrap-expr/c expr ctc-expr
#:positive positive
#:negative negative
#:expr-name expr-name
#:source source)
(let ([expr-name (or expr-name #'#f)]
[source (or source #'#f)])
(quasisyntax/loc expr
(contract #,ctc-expr
#,expr
#,negative
#,positive
#,expr-name
#,source))))
[_ '?])]
[else '?])])
#`(expr/contract #,expr #,ctc-expr #,arg? '#,expr-name
[#,pos-source-expr
#,neg-source-expr
'#,macro-name
(quote-syntax #,expr)
#f])))
(define (get-source-expr source ctx)
(cond [(eq? source 'use-site)
@ -128,17 +187,3 @@
(cond [(list? b) (car b)] ;; module-path-index
[else 'use-site]))
'unknown)))
(module source racket/base
(provide relative-source)
(define (relative-source base-mpi rel-mod-path)
(define r
(resolved-module-path-name
(module-path-index-resolve
(module-path-index-join rel-mod-path base-mpi))))
(cond [(pair? r)
(cons 'submod r)]
[(symbol? r)
(list 'quote r)]
[else r])))
(require (for-template (submod "." source)))

9
racket/collects/syntax/parse/experimental/contract.rkt
View File

@ -10,8 +10,9 @@
(define not-given (gensym))
(define-syntax-class (expr/c ctc-stx
#:positive [pos-blame 'use-site]
#:negative [neg-blame 'from-macro]
#:arg? [arg? #t]
#:positive [pos-blame 'from-macro]
#:negative [neg-blame 'use-site]
#:macro [macro-name #f]
#:name [expr-name not-given]
#:context [ctx #f])
@ -21,6 +22,7 @@
#:with
c (wrap-expr/c ctc-stx
#'y
#:arg? arg?
#:positive pos-blame
#:negative neg-blame
#:name (if (eq? expr-name not-given)
@ -31,7 +33,8 @@
(provide-syntax-class/contract
[expr/c (syntax-class/c (syntax?)
(#:positive (or/c syntax? string? module-path-index?
(#:arg? any/c
#:positive (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
#:negative (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)