commit 086f4cd1714464661ed05b38ece2dc8ea4c4af66
parent d0712ceee237ee1469f4b4c19d4adbaf0a176bc0
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 5 Dec 2012 12:07:08 -0500
log time for macro-stepper gui steps
original commit: dbf8026576c13a8861292fb50677288ffe25c2ac
Diffstat:
5 files changed, 80 insertions(+), 34 deletions(-)
diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl
@@ -567,3 +567,6 @@ module path and the module paths of its immediate dependents.
(get-dependencies 'openssl #:exclude (list 'racket))
]
}
+
+
+@close-eval[the-eval]
diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt
@@ -222,12 +222,7 @@
[#:learn (list #'?var)])]
[(Wrap p:provide (e1 e2 rs ?1 inners ?2))
- (let ([wrapped-inners
- (for/list ([inner (in-list inners)])
- (match inner
- [(Wrap deriv (e1 e2))
- (make local-expansion e1 e2
- #f e1 inner #f e2 #f)]))])
+ (let ([wrapped-inners (map expr->local-action inners)])
(R [! ?1]
[#:pattern ?form]
[#:pass1]
@@ -668,7 +663,9 @@
[#:do (DEBUG (printf "** module begin pass 2\n"))]
[ModulePass ?forms pass2]
;; ignore pass3 for now: only provides
- )]))
+ [#:new-local-context
+ [#:pattern ?form]
+ [LocalActions ?form (map expr->local-action (or pass3 null))]])]))
;; ModulePass : (list-of MBRule) -> RST
(define (ModulePass mbrules)
@@ -724,12 +721,14 @@
[#:set-syntax (append stxs old-forms)]
[ModulePass ?forms rest]])]
[(cons (Wrap mod:lift-end (stxs)) rest)
- (R [#:pattern ?forms]
- [#:when (pair? stxs)
- [#:left-foot null]
- [#:set-syntax (append stxs #'?forms)]
- [#:step 'splice-module-lifts stxs]]
- [ModulePass ?forms rest])]
+ ;; In pass2, stxs contains a mixture of terms and kind-tagged terms (pairs)
+ (let ([stxs (map (lambda (e) (if (pair? e) (car e) e)) stxs)])
+ (R [#:pattern ?forms]
+ [#:when (pair? stxs)
+ [#:left-foot null]
+ [#:set-syntax (append stxs #'?forms)]
+ [#:step 'splice-module-lifts stxs]]
+ [ModulePass ?forms rest]))]
[(cons (Wrap mod:skip ()) rest)
(R [#:pattern (?firstS . ?rest)]
[ModulePass ?rest rest])]
@@ -796,6 +795,12 @@
(when #f
(apply error sym args)))
+(define (expr->local-action d)
+ (match d
+ [(Wrap deriv (e1 e2))
+ (make local-expansion e1 e2
+ #f e1 d #f e2 #f)]))
+
;; opaque-table
;; Weakly remembers assoc between opaque values and
;; actual syntax, so that actual can be substituted in
diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt
@@ -8,7 +8,8 @@
"pretty-printer.rkt"
"interfaces.rkt"
"prefs.rkt"
- "util.rkt")
+ "util.rkt"
+ "../util/logger.rkt")
(provide print-syntax-to-editor
code-style)
@@ -36,19 +37,23 @@
[insertion-point (send text last-position)])
(define output-port (open-output-string/count-lines))
(define range
- (pretty-print-syntax stx output-port
- (send/i controller controller<%> get-primary-partition)
- (length (send/i config config<%> get-colors))
- (send/i config config<%> get-suffix-option)
- (send config get-pretty-styles)
- columns
- (send config get-pretty-abbrev?)))
+ (with-log-time "** pretty-print-syntax"
+ (pretty-print-syntax stx output-port
+ (send/i controller controller<%> get-primary-partition)
+ (length (send/i config config<%> get-colors))
+ (send/i config config<%> get-suffix-option)
+ (send config get-pretty-styles)
+ columns
+ (send config get-pretty-abbrev?))))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
- (fixup-parentheses output-string range)
+ (log-macro-stepper-debug "size of pretty-printed text: ~s" output-length)
+ (with-log-time "fixup-parentheses"
+ (fixup-parentheses output-string range))
(with-unlock text
- (uninterruptible
- (send text insert output-length output-string insertion-point))
+ (with-log-time "inserting pretty-printed text"
+ (uninterruptible
+ (send text insert output-length output-string insertion-point)))
(new display%
(text text)
(controller controller)
@@ -87,22 +92,26 @@
;; initialize : -> void
(define/private (initialize)
- (uninterruptible
- (send text change-style base-style start-position end-position #f))
- (uninterruptible (apply-primary-partition-styles))
- (uninterruptible (add-clickbacks)))
+ (with-log-time "changing base style"
+ (uninterruptible
+ (send text change-style base-style start-position end-position #f)))
+ (with-log-time "applying primary styles"
+ (uninterruptible (apply-primary-partition-styles)))
+ (with-log-time "adding clickbacks"
+ (uninterruptible (add-clickbacks))))
;; add-clickbacks : -> void
(define/private (add-clickbacks)
(define mapping (send text get-region-mapping 'syntax))
(define lazy-interval-map-init
(delay
+ (with-log-time "forcing clickback mapping"
(uninterruptible
(for ([range (send/i range range<%> all-ranges)])
(let ([stx (range-obj range)]
[start (range-start range)]
[end (range-end range)])
- (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))
+ (interval-map-set! mapping (+ start-position start) (+ start-position end) stx)))))))
(define (the-callback position)
(force lazy-interval-map-init)
(send/i controller selection-manager<%> set-selected-syntax
@@ -113,6 +122,7 @@
;; refresh : -> void
;; Clears all highlighting and reapplies all non-foreground styles.
(define/public (refresh)
+ (with-log-time "refresh"
(with-unlock text
(uninterruptible
(let ([undo-select/highlight-d (get-undo-select/highlight-d)])
@@ -134,7 +144,7 @@
(uninterruptible
(apply-secondary-relation-styles selected-syntax))
(uninterruptible
- (apply-selection-styles selected-syntax)))))
+ (apply-selection-styles selected-syntax))))))
;; get-range : -> range<%>
(define/public (get-range) range)
diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt
@@ -14,6 +14,7 @@
"text.rkt"
"util.rkt"
"../util/eomap.rkt"
+ "../util/logger.rkt"
"../util/mpi.rkt")
(provide widget%)
@@ -132,6 +133,7 @@
(send -text insert "\n")
(define range (send/i display display<%> get-range))
(define offset (send/i display display<%> get-start-position))
+ (with-log-time "substitutions"
(for ([subst (in-list substitutions)])
(for ([r (in-list (send/i range range<%> get-ranges (car subst)))])
(send -text insert (cdr subst)
@@ -142,18 +144,21 @@
(code-style -text (send/i config config<%> get-syntax-font-size))
(+ offset (car r))
(+ offset (cdr r))
- #f)))
+ #f))))
;; Apply highlighting
+ (with-log-time "highlights"
(for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)])
- (send/i display display<%> highlight-syntaxes hi-stxs hi-color))
+ (send/i display display<%> highlight-syntaxes hi-stxs hi-color)))
;; Underline binders (and shifted binders)
+ (with-log-time "underline binders"
(send/i display display<%> underline-syntaxes
(let ([binder-list (hash-map binders (lambda (k v) k))])
(append (apply append (map get-shifted binder-list))
- binder-list)))
+ binder-list))))
(send display refresh)
;; Make arrows (& billboards, when enabled)
+ (with-log-time "add arrows"
(when (send config get-draw-arrows?)
(define (definite-phase id)
(and definites
@@ -186,7 +191,7 @@
(for ([binder (in-list (get-binders id phase))])
(for ([binder-r (in-list (send/i range range<%> get-ranges binder))])
(for ([id-r (in-list (send/i range range<%> get-ranges id))])
- (add-binding-arrow offset binder-r id-r phase))))))
+ (add-binding-arrow offset binder-r id-r phase)))))))
(void)))
(define/private (add-binding-arrow start binder-r id-r phase)
diff --git a/collects/macro-debugger/util/logger.rkt b/collects/macro-debugger/util/logger.rkt
@@ -0,0 +1,23 @@
+#lang racket/base
+(require racket/format)
+(provide (all-defined-out))
+
+(define-logger macro-stepper)
+
+(define (log-macro-stepper-time task msecs)
+ (log-macro-stepper-debug
+ (format "time for ~a: ~ams" task (~r msecs #:precision 0))))
+
+(define-syntax-rule (with-log-time task body ...)
+ (let ([time1 (current-inexact-milliseconds)])
+ (begin0 (begin body ...)
+ (let ([time2 (current-inexact-milliseconds)])
+ (log-macro-stepper-time task (- time2 time1))))))
+
+(define-syntax-rule (splicing-with-log-time task body ...)
+ (begin (define time1 (current-inexact-milliseconds))
+ body ...
+ (define time2 (current-inexact-milliseconds))
+ (define-values ()
+ (begin0 (values)
+ (log-macro-stepper-time task (- time2 time1))))))
