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

Instrument pattern matching for feature-specific profiling.

Browse Source
This commit is contained in:
Vincent St-Amour 2014-01-21 16:45:12 -05:00
parent 5502bf5b1b
commit fc512ba78d
2 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
racket/collects/racket/match/compiler.rkt
View File

@ -428,13 +428,16 @@
([fail (make-rename-transformer
(quote-syntax #,esc))])
#,(Row-rhs (car blocks)))])
(if (Row-unmatch (car blocks))
#`(call-with-continuation-prompt
(lambda () (let ([#,(Row-unmatch (car blocks))
(lambda () (abort-current-continuation match-prompt-tag))])
(define unmatch (Row-unmatch (car blocks)))
(if unmatch
(quasisyntax/loc unmatch
(call-with-continuation-prompt
(lambda () (let ([#,unmatch
(lambda ()
(abort-current-continuation match-prompt-tag))])
rhs))
match-prompt-tag
(lambda () (#,esc)))
(lambda () (#,esc))))
#'rhs))])
;; then compile the rest, with our name as the esc
(loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))])

15
racket/collects/racket/match/gen-match.rkt
View File

@ -55,7 +55,11 @@
'match (format "wrong number of match clauses, expected ~a and got ~a" len lp) pats))
(define (mk unm rhs)
(make-Row (for/list ([p (syntax->list pats)]) (parse p))
#`(let () . #,rhs) unm null))
(syntax-property
(quasisyntax/loc stx
(let () . #,rhs))
'feature-profile:pattern-matching 'antimark)
unm null))
(syntax-parse rhs
[()
(raise-syntax-error
@ -72,7 +76,12 @@
[_ (mk #f rhs)])))
(define/with-syntax body
(compile* (syntax->list #'(xs ...)) parsed-clauses #'outer-fail))
(define/with-syntax (exprs* ...)
(for/list ([e (in-list (syntax->list #'(exprs ...)))])
(syntax-property e 'feature-profile:pattern-matching 'antimark)))
(syntax-property
(quasisyntax/loc stx
(let ([xs exprs] ...)
(let ([xs exprs*] ...)
(define (outer-fail) raise-error)
body))]))
body))
'feature-profile:pattern-matching #t)]))