diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl index e0a24f4..03a9827 100644 --- 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 index fdc88b0..3b1c43d 100644 --- 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 index 003278b..6232a1e 100644 --- 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 index ccafe7e..2a1bda3 100644 --- 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 new file mode 100644 index 0000000..32a3f2d --- /dev/null +++ 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))))))