log time for macro-stepper gui steps

original commit: dbf8026576c13a8861292fb50677288ffe25c2ac

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]

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
+     (let ([wrapped-inners (map expr->local-action inners)])
-            (for/list ([inner (in-list inners)])
-              (match inner
-                [(Wrap deriv (e1 e2))
-                 (make local-expansion e1 e2
-                       #f e1 inner #f e2 #f)]))])
        (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]
+     ;; In pass2, stxs contains a mixture of terms and kind-tagged terms (pairs)
-        [#:when (pair? stxs)
+     (let ([stxs (map (lambda (e) (if (pair? e) (car e) e)) stxs)])
-                [#:left-foot null]
+       (R [#:pattern ?forms]
-                [#:set-syntax (append stxs #'?forms)]
+          [#:when (pair? stxs)
-                [#:step 'splice-module-lifts stxs]]
+                  [#:left-foot null]
-        [ModulePass ?forms rest])]
+                  [#: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

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 
+    (with-log-time "** pretty-print-syntax"
-                         (send/i controller controller<%> get-primary-partition)
+      (pretty-print-syntax stx output-port 
-                         (length (send/i config config<%> get-colors))
+                           (send/i controller controller<%> get-primary-partition)
-                         (send/i config config<%> get-suffix-option)
+                           (length (send/i config config<%> get-colors))
-                         (send config get-pretty-styles)
+                           (send/i config config<%> get-suffix-option)
-                         columns
+                           (send config get-pretty-styles)
-                         (send config get-pretty-abbrev?)))
+                           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
+    (with-log-time "inserting pretty-printed text"
-     (send text insert output-length output-string insertion-point))
+      (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
+      (with-log-time "changing base style"
-       (send text change-style base-style start-position end-position #f))
+        (uninterruptible
-      (uninterruptible (apply-primary-partition-styles))
+         (send text change-style base-style start-position end-position #f)))
-      (uninterruptible (add-clickbacks)))
+      (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)

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)

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))))))