From 43b0e2157c5247653da96d24dee833be429c4bfc Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 26 Nov 2012 13:38:13 -0700 Subject: [PATCH] Optimize stick-to-next-sexp? to speculative match before using forward-match. Profiler output suggests that forward-match is a bit expensive. Here is profiler output from the original code, when profiler is wrapped around tabify-selection: ------------------------------------------------------------------------------------------------------------ loop [34] 0.1% get-backward-sexp method in ...k/private/racket.rkt:425:2 [28] 99.9% [37] 50648(61.1%) 0(0.0%) stick-to-next-sexp? method in ...k/private/racket.rkt:425:2 ... do-forward-match method in ...rk/private/color.rkt:71:2 [50] 99.9% ... ------------------------------------------------------------------------------------------------------------ get-forward-sexp method in ...k/private/racket.rkt:425:2 [38] 17.1% stick-to-next-sexp? method in ...k/private/racket.rkt:425:2 [37] 82.9% [50] 61043(73.6%) 53(0.1%) do-forward-match method in ...rk/private/color.rkt:71:2 ... colorer-driver method in ...rk/private/color.rkt:71:2 [66] 99.8% match-forward method in paren-tree% [72] 0.1% ------------------------------------------------------------------------------------------------------------ The patch does the prerequisite string matching before calling forward-match. Reference to dev list: http://lists.racket-lang.org/dev/archive/2012-November/010976.html --- collects/framework/private/racket.rkt | 43 ++++++++++++++++++++------- 1 file changed, 33 insertions(+), 10 deletions(-) diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt index 4432caf397..45d6ad98f5 100644 --- a/collects/framework/private/racket.rkt +++ b/collects/framework/private/racket.rkt @@ -5,6 +5,7 @@ (require string-constants racket/class + racket/string mred/mred-sig syntax-color/module-lexer "collapsed-snipclass-helpers.rkt" @@ -900,17 +901,39 @@ (let ([snip-pos (get-snip-position snip)]) (delete snip-pos (+ snip-pos 1))) (set-position pos pos))) - + + + ;; stick-to-next-sexp?: natural -> boolean + (define stick-to-patterns + '("'" "," ",@" "`" "#'" "#," "#`" "#,@" + "#&" "#;" "#hash" "#hasheq" "#ci" "#cs")) + (define stick-to-patterns-union + (regexp (string-append + "^(" + (string-join (map regexp-quote stick-to-patterns) "|") + ")"))) + (define stick-to-patterns-union-anchored + (regexp (string-append + "^(" + (string-join (map regexp-quote stick-to-patterns) "|") + ")$"))) + (define stick-to-max-pattern-length + (apply max (map string-length stick-to-patterns))) (define/public (stick-to-next-sexp? start-pos) - (let ([end-pos (forward-match start-pos (last-position))]) - (and end-pos - (member (get-text start-pos end-pos) - '("'" "," ",@" "`" - "#'" "#," "#`" "#,@" - "#&" "#;" - "#hash" "#hasheq" - "#ci" "#cs"))))) - + ;; Optimization: speculatively check whether the string will + ;; match the patterns; at time of writing, forward-match can be + ;; really expensive. + (define snippet + (get-text start-pos + (min (last-position) + (+ start-pos stick-to-max-pattern-length)))) + (and (regexp-match stick-to-patterns-union snippet) + (let ([end-pos (forward-match start-pos (last-position))]) + (and end-pos + (regexp-match stick-to-patterns-union-anchored + (get-text start-pos end-pos)) + #t)))) + (define/public (get-forward-sexp start-pos) ;; loop to work properly with quote, etc. (let loop ([one-forward (forward-match start-pos (last-position))])