From 5ada142ee9be4481ab272e7788ace61984abc2cc Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 30 Dec 2018 18:06:11 -0600 Subject: [PATCH] wrap-expr/c: improve performance, add #:arg?, fix pos/neg args - 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. --- .../syntax/scribblings/contract.scrbl | 11 +- .../syntax/scribblings/parse/ex-exprc.scrbl | 21 +++ .../syntax/scribblings/parse/lib.scrbl | 37 ++-- .../racket-test/tests/stxparse/test-exprc.rkt | 70 ++++++++ .../tests/syntax/contract/perf-liftable.rkt | 18 ++ .../syntax/contract/perf-nolift-result.rkt | 19 ++ .../tests/syntax/contract/perf-nolift.rkt | 24 +++ .../tests/syntax/contract/test-errors.rkt | 81 +++++++++ racket/collects/syntax/contract.rkt | 167 +++++++++++------- .../syntax/parse/experimental/contract.rkt | 9 +- 10 files changed, 376 insertions(+), 81 deletions(-) create mode 100644 pkgs/racket-test/tests/stxparse/test-exprc.rkt create mode 100644 pkgs/racket-test/tests/syntax/contract/perf-liftable.rkt create mode 100644 pkgs/racket-test/tests/syntax/contract/perf-nolift-result.rkt create mode 100644 pkgs/racket-test/tests/syntax/contract/perf-nolift.rkt create mode 100644 pkgs/racket-test/tests/syntax/contract/test-errors.rkt diff --git a/pkgs/racket-doc/syntax/scribblings/contract.scrbl b/pkgs/racket-doc/syntax/scribblings/contract.scrbl index b25b9a9ce1..ae9df32424 100644 --- a/pkgs/racket-doc/syntax/scribblings/contract.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/contract.scrbl @@ -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] diff --git a/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl index 366d60a893..3baa98ab2a 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl @@ -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) diff --git a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl index bf75ab7e2f..05e082433a 100644 --- a/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl +++ b/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl @@ -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} diff --git a/pkgs/racket-test/tests/stxparse/test-exprc.rkt b/pkgs/racket-test/tests/stxparse/test-exprc.rkt new file mode 100644 index 0000000000..6dde3f6a93 --- /dev/null +++ b/pkgs/racket-test/tests/stxparse/test-exprc.rkt @@ -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))) diff --git a/pkgs/racket-test/tests/syntax/contract/perf-liftable.rkt b/pkgs/racket-test/tests/syntax/contract/perf-liftable.rkt new file mode 100644 index 0000000000..211a355916 --- /dev/null +++ b/pkgs/racket-test/tests/syntax/contract/perf-liftable.rkt @@ -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))) diff --git a/pkgs/racket-test/tests/syntax/contract/perf-nolift-result.rkt b/pkgs/racket-test/tests/syntax/contract/perf-nolift-result.rkt new file mode 100644 index 0000000000..6e7f9efb72 --- /dev/null +++ b/pkgs/racket-test/tests/syntax/contract/perf-nolift-result.rkt @@ -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))) diff --git a/pkgs/racket-test/tests/syntax/contract/perf-nolift.rkt b/pkgs/racket-test/tests/syntax/contract/perf-nolift.rkt new file mode 100644 index 0000000000..da2db5e24d --- /dev/null +++ b/pkgs/racket-test/tests/syntax/contract/perf-nolift.rkt @@ -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))) diff --git a/pkgs/racket-test/tests/syntax/contract/test-errors.rkt b/pkgs/racket-test/tests/syntax/contract/test-errors.rkt new file mode 100644 index 0000000000..5369429db3 --- /dev/null +++ b/pkgs/racket-test/tests/syntax/contract/test-errors.rkt @@ -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")))) diff --git a/racket/collects/syntax/contract.rkt b/racket/collects/syntax/contract.rkt index aaefbd03b4..5da0d30ee0 100644 --- a/racket/collects/syntax/contract.rkt +++ b/racket/collects/syntax/contract.rkt @@ -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))) diff --git a/racket/collects/syntax/parse/experimental/contract.rkt b/racket/collects/syntax/parse/experimental/contract.rkt index b4dbec4107..615ac96c7e 100644 --- a/racket/collects/syntax/parse/experimental/contract.rkt +++ b/racket/collects/syntax/parse/experimental/contract.rkt @@ -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)