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

Instrument the opt/kw protocol for feature-specific profiling.

Browse Source 
That code is only executed for higher-order uses of these functions,
otherwise protocol gets optimized away.
This commit is contained in:
Vincent St-Amour 2013-12-11 17:15:20 -05:00
parent b76b2aa638
commit 9d7b6a1c89
1 changed files with 50 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
racket/collects/racket/private/kw.rkt
View File

@ -492,12 +492,15 @@
. new-rest) . new-rest)
;; sort out the arguments into the user-supplied bindings, ;; sort out the arguments into the user-supplied bindings,
;; evaluating default-value expressions as needed: ;; evaluating default-value expressions as needed:
(let-maybe ([id opt-expr kind] ... . rest) #,(syntax-property
(kw-arg ...) (kw-arg? ...) (quasisyntax/loc stx ; kw-opt profiler uses this srcloc
(opt-arg ...) (opt-arg? ...) (let-maybe ([id opt-expr kind] ... . rest)
(new-plain-id ... . new-rest) (kw-arg ...) (kw-arg? ...)
;; the original body, finally: (opt-arg ...) (opt-arg? ...)
body1 body ...)))))] (new-plain-id ... . new-rest)
;; the original body, finally:
body1 body ...))
'feature-profile:kw-opt-protocol #t)))))]
[mk-unpack [mk-unpack
(lambda () (lambda ()
;; like core, but keywords must be unpacked: ;; like core, but keywords must be unpacked:
@ -510,10 +513,15 @@
. new-rest) . new-rest)
;; sort out the arguments into the user-supplied bindings, ;; sort out the arguments into the user-supplied bindings,
;; evaluating default-value expressions as needed: ;; evaluating default-value expressions as needed:
(let-kws given-kws given-args kws-sorted #,(syntax-property
(core #,@(flatten-keywords sorted-kws) (quasisyntax/loc stx ; kw-opt profiler uses this srcloc
new-plain-id ... opt-arg ... opt-arg? ... (let-kws given-kws given-args kws-sorted
. new-rest))))))] #,(syntax-property
#`(core #,@(flatten-keywords sorted-kws)
new-plain-id ... opt-arg ... opt-arg? ...
. new-rest)
'kw-feature-profile:opt-protocol 'antimark)))
'feature-profile:kw-opt-protocol #f)))))]
[mk-no-kws [mk-no-kws
(lambda (kw-core?) (lambda (kw-core?)
;; entry point without keywords: ;; entry point without keywords:
@ -571,11 +579,14 @@
#`(let ([#,n #,p]) #,n) #`(let ([#,n #,p]) #,n)
p))] p))]
[with-kws (mk-with-kws)]) [with-kws (mk-with-kws)])
(syntax/loc stx (quasisyntax/loc stx
(make-okp (make-okp
(lambda (given-kws given-argc) (lambda (given-kws given-argc)
(and (in-range?/static given-argc with-kw-min-args with-kw-max-arg) #,(syntax-property
(subset?/static given-kws 'kws))) (syntax/loc stx ; kw-opt profiler uses this srcloc
(and (in-range?/static given-argc with-kw-min-args with-kw-max-arg)
(subset?/static given-kws 'kws)))
'feature-profile:kw-opt-protocol #t))
with-kws with-kws
null null
'kws 'kws
@ -595,11 +606,14 @@
[call-fail (mk-kw-arity-stub)]) [call-fail (mk-kw-arity-stub)])
(syntax-local-lift-expression (syntax-local-lift-expression
#'(make-required 'n call-fail method? #f)))]) #'(make-required 'n call-fail method? #f)))])
(syntax/loc stx (quasisyntax/loc stx
(mk-id (mk-id
(lambda (given-kws given-argc) (lambda (given-kws given-argc)
(and (in-range?/static given-argc with-kw-min-args with-kw-max-arg) #,(syntax-property
(subsets?/static 'needed-kws given-kws 'kws))) (syntax/loc stx ; kw-opt profiler uses this srcloc
(and (in-range?/static given-argc with-kw-min-args with-kw-max-arg)
(subsets?/static 'needed-kws given-kws 'kws)))
'feature-profile:kw-opt-protocol #t))
with-kws with-kws
'needed-kws 'needed-kws
'kws))))]))))))])) 'kws))))]))))))]))
@ -740,28 +754,32 @@
;; (where, e.g., an optional keyword argument might ;; (where, e.g., an optional keyword argument might
;; precede a required argument, so the required argument ;; precede a required argument, so the required argument
;; cannot be used to compute the default). ;; cannot be used to compute the default).
(define-syntax let-maybe (define-syntax (let-maybe stx)
(syntax-rules (required) (syntax-case stx (required)
[(_ () () () () () () . body) [(_ () () () () () () . body)
(let () . body)] (syntax-property
#'(let () . body)
'feature-profile:kw-opt-protocol 'antimark)]
[(_ ([id ignore #:plain] . more) kw-args kw-arg?s opt-args opt-arg?s (req-id . req-ids) . body) [(_ ([id ignore #:plain] . more) kw-args kw-arg?s opt-args opt-arg?s (req-id . req-ids) . body)
(let ([id req-id]) #'(let ([id req-id])
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))] (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
[(_ ([id expr #:opt] . more) kw-args kw-arg?s (opt-arg . opt-args) (opt-arg? . opt-arg?s) req-ids . body) [(_ ([id expr #:opt] . more) kw-args kw-arg?s (opt-arg . opt-args) (opt-arg? . opt-arg?s) req-ids . body)
(let ([id (if opt-arg? #'(let ([id (if opt-arg?
opt-arg opt-arg
expr)]) expr)])
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))] (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
[(_ ([id expr #:kw-req] . more) (kw-arg . kw-args) kw-arg?s opt-args opt-arg?s req-ids . body) [(_ ([id expr #:kw-req] . more) (kw-arg . kw-args) kw-arg?s opt-args opt-arg?s req-ids . body)
(let ([id kw-arg]) #'(let ([id kw-arg])
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))] (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
[(_ ([id expr #:kw-opt] . more) (kw-arg . kw-args) (kw-arg? . kw-arg?s) opt-args opt-arg?s req-ids . body) [(_ ([id expr #:kw-opt] . more) (kw-arg . kw-args) (kw-arg? . kw-arg?s) opt-args opt-arg?s req-ids . body)
(let ([id (if kw-arg? #'(let ([id (if kw-arg?
kw-arg kw-arg
expr)]) expr)])
(let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))] (let-maybe more kw-args kw-arg?s opt-args opt-arg?s req-ids . body))]
[(_ (id) () () () () (req-id) . body) [(_ (id) () () () () (req-id) . body)
(let ([id req-id]) . body)])) (syntax-property
#'(let ([id req-id]) . body)
'feature-profile:kw-opt-protocol 'antimark)]))
;; ---------------------------------------- ;; ----------------------------------------
;; Helper macros: ;; Helper macros: