From 5920708c4778915dbe5f116dee7a79564d397d93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Tue, 14 Mar 2017 20:30:58 +0100 Subject: [PATCH] Disable contracts for performance (a bit too aggressive, need to rollback some of these) --- private/ddd-forms.rkt | 10 ++++++++-- private/ddd.rkt | 3 ++- ...fully-expanded-grammar-extract-bindings.rkt | 2 +- private/lifted-variables-communication.rkt | 3 ++- private/optcontract.rkt | 13 +++++++++++++ private/subscripts.rkt | 2 +- private/template-subscripts.rkt | 5 +++-- test/test-copy-attribute-template-problem.rkt | 11 +++++++++++ test/test-performance.rkt | 18 ++++++++++++++++++ 9 files changed, 59 insertions(+), 8 deletions(-) create mode 100644 private/optcontract.rkt create mode 100644 test/test-copy-attribute-template-problem.rkt create mode 100644 test/test-performance.rkt diff --git a/private/ddd-forms.rkt b/private/ddd-forms.rkt index b42e9b0..647f213 100644 --- a/private/ddd-forms.rkt +++ b/private/ddd-forms.rkt @@ -118,14 +118,20 @@ {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a … ;#'(#%app apply fn (#%app append arg.expanded …)) (syntax/top-loc this-syntax - (#%app apply fn (#%app splice-append arg.expanded … #:rest rest.v)))] + (#%plain-app apply fn (#%plain-app splice-append-nokw rest.v arg.expanded …)))] [(_ arg:arg … . rest:not-stx-pair) ;; shorthand for list creation ;#'(#%app apply list (#%app append arg.expanded …)) + #;(syntax/top-loc this-syntax + (#%plain-app apply list + (#%plain-app splice-append-nokw rest.v arg.expanded …))) + ;; (apply list v) is a no-op asside from error handling. (syntax/top-loc this-syntax - (#%app apply list (#%app splice-append arg.expanded … #:rest rest.v)))])) + (#%plain-app splice-append-nokw rest.v arg.expanded …))])) (define (splice-append #:rest [rest '()] . l*) (splice-append* (if (null? rest) l* (append l* rest)))) +(define (splice-append-nokw rest . l*) + (splice-append* (if (null? rest) l* (append l* rest)))) (define (splice-append* l*) (cond [(pair? l*) diff --git a/private/ddd.rkt b/private/ddd.rkt index c131126..bb16423 100644 --- a/private/ddd.rkt +++ b/private/ddd.rkt @@ -9,7 +9,7 @@ (prefix-in - syntax/parse/private/residual) racket/stxparam "lifted-variables-communication.rkt" - (for-syntax racket/contract + (for-syntax "optcontract.rkt";racket/contract racket/syntax phc-toolkit/untyped racket/function @@ -256,6 +256,7 @@ ;;; pvar outside of the body. (define-syntax/case (ddd body) () (define/with-syntax (pvar …) (current-pvars-shadowers)) + (displayln (stx-map syntax-e (current-pvars-shadowers))) (define-temp-ids "~aᵢ" (pvar …)) (define/with-syntax f diff --git a/private/fully-expanded-grammar-extract-bindings.rkt b/private/fully-expanded-grammar-extract-bindings.rkt index e59f8b8..5b93e83 100644 --- a/private/fully-expanded-grammar-extract-bindings.rkt +++ b/private/fully-expanded-grammar-extract-bindings.rkt @@ -4,7 +4,7 @@ (require syntax/parse phc-toolkit/untyped - racket/contract + "optcontract.rkt";racket/contract racket/list (for-template '#%kernel)) diff --git a/private/lifted-variables-communication.rkt b/private/lifted-variables-communication.rkt index 9fdd3b9..096f8bc 100644 --- a/private/lifted-variables-communication.rkt +++ b/private/lifted-variables-communication.rkt @@ -8,7 +8,8 @@ (require racket/stxparam (for-syntax racket/base racket/syntax - racket/contract)) + "optcontract.rkt";racket/contract + )) (define-syntax-parameter lift-late-pvars-param #f) diff --git a/private/optcontract.rkt b/private/optcontract.rkt new file mode 100644 index 0000000..c979646 --- /dev/null +++ b/private/optcontract.rkt @@ -0,0 +1,13 @@ +#lang racket + +(require racket/contract) + +(provide (except-out (all-from-out racket/contract) + define-struct/contract + ;define/contract + provide/contract + invariant-assertion) + define/contract) + +(define-syntax-rule (define/contract sig c . rest) + (define sig . rest)) \ No newline at end of file diff --git a/private/subscripts.rkt b/private/subscripts.rkt index f64ac65..601aabe 100644 --- a/private/subscripts.rkt +++ b/private/subscripts.rkt @@ -10,7 +10,7 @@ racket/function racket/list phc-toolkit/untyped - racket/contract + "optcontract.rkt";racket/contract racket/string racket/syntax) diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt index 5aa23a6..e31df30 100644 --- a/private/template-subscripts.rkt +++ b/private/template-subscripts.rkt @@ -4,7 +4,7 @@ racket/list racket/string racket/function - racket/contract + "optcontract.rkt";racket/contract phc-toolkit/untyped phc-toolkit/untyped-only/syntax-parse racket/stxparam @@ -32,7 +32,8 @@ srfi/13 (subtract-in racket/string srfi/13) syntax/contract - racket/contract)) + "optcontract.rkt";racket/contract + )) (provide subtemplate quasisubtemplate diff --git a/test/test-copy-attribute-template-problem.rkt b/test/test-copy-attribute-template-problem.rkt new file mode 100644 index 0000000..407733d --- /dev/null +++ b/test/test-copy-attribute-template-problem.rkt @@ -0,0 +1,11 @@ +#lang racket +(require subtemplate/private/copy-attribute + stxparse-info/parse + stxparse-info/parse/experimental/template + phc-toolkit/untyped) + +(syntax->datum + (syntax-parse #'([1 2 3] #:kw [4 5]) + [({~and {~or #:kw (x …)}} …) + (copy-raw-syntax-attribute y (attribute* x) 2 #t) + (template [(?? (?@ y …) empty) …])])) \ No newline at end of file diff --git a/test/test-performance.rkt b/test/test-performance.rkt new file mode 100644 index 0000000..3cd09d3 --- /dev/null +++ b/test/test-performance.rkt @@ -0,0 +1,18 @@ +#lang racket + +(require subtemplate/override) + +#;(time + (syntax-case #'((((0 1 2 3 4 5 6 7 8 9)))) () + [((((a b c d e f g h i j) …) …) …) + #'(a … … …)])) + +#;(time + (syntax-case #'((((0 1 2 3 4 5 6 7 8 9)))) () + [((((a b c d e f g h i j) …) …) …) + (list #'a … … …)])) + +(time + (syntax-case #'(((0 1 2 3 4 5 6 7 8 9))) () + [(((a b c d e f g h i j) …) …) + (list #'a … …)])) \ No newline at end of file