From e273dae9b1de1d3ade2d29ee07da894fd42e91ad Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 22 Oct 2009 22:00:49 +0000 Subject: [PATCH] macro-stepper: made syntax display faster, esp for early terms calculate arrows etc wrt known binders instead of all binders svn: r16416 --- .../macro-debugger/model/reductions-config.ss | 11 ++- .../macro-debugger/model/reductions-engine.ss | 18 ++++ collects/macro-debugger/model/reductions.ss | 43 ++++++---- .../macro-debugger/syntax-browser/widget.ss | 52 ++++++------ collects/macro-debugger/view/step-display.ss | 85 +++++++++---------- collects/macro-debugger/view/term-record.ss | 15 ++-- collects/tests/macro-debugger/gentests.ss | 2 +- collects/tests/macro-debugger/test-setup.ss | 2 +- .../tests/macro-debugger/tests/collects.ss | 2 +- collects/tests/macro-debugger/tests/hiding.ss | 2 +- 10 files changed, 133 insertions(+), 99 deletions(-) diff --git a/collects/macro-debugger/model/reductions-config.ss b/collects/macro-debugger/model/reductions-config.ss index 2fbe36f068..35b6d1c125 100644 --- a/collects/macro-debugger/model/reductions-config.ss +++ b/collects/macro-debugger/model/reductions-config.ss @@ -37,6 +37,7 @@ [marking-table (parameter/c (or/c hash? false/c))] [current-binders (parameter/c (listof identifier?))] [current-definites (parameter/c (listof identifier?))] + [current-binders (parameter/c (listof identifier?))] [current-frontier (parameter/c (listof syntax?))] [sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))] [phase (parameter/c exact-nonnegative-integer?)] @@ -48,6 +49,7 @@ [block-value-bindings (parameter/c (listof syntaxish?))] [block-expressions (parameter/c syntaxish?)] + [learn-binders ((listof identifier?) . -> . any)] [learn-definites ((listof identifier?) . -> . any)] [add-frontier ((listof syntax?) . -> . any)] @@ -82,7 +84,6 @@ (define marking-table (make-parameter #f)) ;; current-binders : parameterof (listof identifier) -;; FIXME: not yet used (define current-binders (make-parameter null)) ;; current-definites : parameter of (list-of identifier) @@ -160,6 +161,10 @@ (current-definites (append ids (current-definites)))) +(define (learn-binders ids) + (current-binders + (append ids (current-binders)))) + (define (get-frontier) (or (current-frontier) null)) (define (add-frontier stxs) @@ -322,8 +327,8 @@ (define (current-state-with e fs) (make state e (foci fs) (context) (big-context) - (current-binders) (current-definites) (current-frontier) - (sequence-number))) + (current-binders) (current-definites) + (current-frontier) (sequence-number))) (define (walk e1 e2 type #:foci1 [foci1 e1] diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index b0831080c3..c656117ec2 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -253,6 +253,12 @@ (check-same-stx 'rename/no-step real-from from)) (R** f v p s ws [#:rename pvar to] . more))] + ;; Add to definite binders + [(R** f v p s ws [#:binders ids] . more) + #:declare ids (expr/c #'(listof identifier)) + #'(begin (learn-binders (flatten-identifiers (with-syntax1 ([p f]) ids))) + (R** f v p s ws . more))] + ;; Add to definite uses [(R** f v p s ws [#:learn ids] . more) #:declare ids (expr/c #'(listof identifier?)) @@ -550,3 +556,15 @@ (cons (wrongness (stx-car a) (stx-car b)) (wrongness (stx-cdr a) (stx-cdr b)))] [else (stx->datum a)])) + + +;; flatten-identifiers : syntaxlike -> (list-of identifier) +(define (flatten-identifiers stx) + (syntax-case stx () + [id (identifier? #'id) (list #'id)] + [() null] + [(x . y) (append (flatten-identifiers #'x) (flatten-identifiers #'y))] + [else (error 'flatten-identifers "neither syntax list nor identifier: ~s" + (if (syntax? stx) + (syntax->datum stx) + stx))])) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 340940bd6b..b2a5748990 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -13,20 +13,21 @@ ;; reductions : WDeriv -> ReductionSequence (define (reductions d) - (let-values ([(steps definites estx exn) (reductions+ d)]) + (let-values ([(steps binders definites estx exn) (reductions+ d)]) steps)) ;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn (define (reductions+ d) (parameterize ((current-definites null) + (current-binders null) (current-frontier null) (hides-flags (list (box #f))) (sequence-number 0)) (RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null) (lambda (steps stx vstx s) - (values (reverse steps) (current-definites) vstx #f)) + (values (reverse steps) (current-binders) (current-definites) vstx #f)) (lambda (steps exn) - (values (reverse steps) (current-definites) #f exn))))) + (values (reverse steps) (current-binders) (current-definites) #f exn))))) ;; Syntax @@ -97,17 +98,16 @@ [! ?1])] [(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2)) (R [! ?1] - [#:pattern (?define-syntaxes formals ?rhs)] + [#:pattern (?define-syntaxes ?vars ?rhs)] + [#:binders #'?vars] [Expr/PhaseUp ?rhs rhs] [! ?2])] [(Wrap p:define-values (e1 e2 rs ?1 rhs)) (R [! ?1] - [#:pattern (?define-values ?formals ?rhs)] + [#:pattern (?define-values ?vars ?rhs)] + [#:binders #'?vars] [#:when rhs - [Expr ?rhs rhs]] - [#:when (not rhs) - [#:do (DEBUG (printf "=== end (dvrhs) ===\n"))] - [#:do (DEBUG (printf "===\n"))]])] + [Expr ?rhs rhs]])] [(Wrap p:#%expression (e1 e2 rs ?1 inner #f)) (R [! ?1] [#:pattern (?expr-kw ?inner)] @@ -156,6 +156,7 @@ [(Wrap p:lambda (e1 e2 rs ?1 renames body)) (R [! ?1] [#:pattern (?lambda ?formals . ?body)] + [#:binders #'?formals] [#:rename (?formals . ?body) renames 'rename-lambda] [Block ?body body])] [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) @@ -166,12 +167,14 @@ (R [! ?1] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values] + [#:binders #'(?vars ...)] [Expr (?rhs ...) rhss] [Block ?body body])] [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) (R [! ?1] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values] + [#:binders #'(?vars ...)] [Expr (?rhs ...) rhss] [Block ?body body])] [(Wrap p:letrec-syntaxes+values @@ -182,10 +185,12 @@ [#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) srenames 'rename-lsv] + [#:binders #'(?svars ... ?vvars ...)] [BindSyntaxes (?srhs ...) srhss] ;; If vrenames is #f, no var bindings to rename [#:when vrenames - [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv]] + [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv] + [#:binders #'(?vvars ...)]] [Expr (?vrhs ...) vrhss] [Block ?body body] [#:pass2] @@ -328,6 +333,7 @@ (R [! ?1] [#:pattern ((?formals . ?body) . ?rest)] [#:rename (?formals . ?body) rename 'rename-case-lambda] + [#:binders #'?formals] [Block ?body body] [CaseLambdaClauses ?rest rest])])) @@ -393,6 +399,7 @@ [(struct local-lift (expr ids)) ;; FIXME: add action (R [#:do (take-lift!)] + [#:binders ids] [#:reductions (list (walk expr ids 'local-lift))])] [(struct local-lift-end (decl)) @@ -409,6 +416,7 @@ [(struct local-bind (names ?1 renames bindrhs)) [R [! ?1] ;; FIXME: use renames + [#:binders names] [#:when bindrhs => (BindSyntaxes bindrhs)]]])) ;; List : ListDerivation -> RST @@ -489,11 +497,12 @@ [Expr ?first head] [! ?1] [#:pass2] - [#:pattern ((?define-values . ?clause) . ?rest)] - [#:rename ?clause rename] + [#:pattern ((?define-values ?vars . ?body) . ?rest)] + [#:rename (?vars . ?body) rename] + [#:binders #'?vars] [! ?2] [#:do (block-value-bindings - (cons #'?clause (block-value-bindings)))] + (cons (cons #'?vars #'?body) (block-value-bindings)))] [#:pattern (?first . ?rest)] [BlockPass ?rest rest])] [(cons (Wrap b:defstx (renames head ?1 rename ?2 bindrhs)) rest) @@ -503,11 +512,12 @@ [Expr ?first head] [! ?1] [#:pass2] - [#:pattern ((?define-syntaxes . ?clause) . ?rest)] - [#:rename ?clause rename] + [#:pattern ((?define-syntaxes ?vars . ?body) . ?rest)] + [#:rename (?vars . ?body) rename] + [#:binders #'?vars] [! ?2] [#:do (block-syntax-bindings - (cons #'?clause (block-syntax-bindings)))] + (cons (cons #'?vars #'?body) (block-syntax-bindings)))] [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] [BindSyntaxes ?rhs bindrhs] [#:pattern (?first . ?rest)] @@ -519,7 +529,6 @@ [#:do (block-expressions #'(?first . ?rest))] ;; rest better be empty [BlockPass ?rest rest])] - )) ;; BindSyntaxes : BindSyntaxes -> RST diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 07d21b917e..f32e001206 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -5,7 +5,7 @@ framework/framework scheme/list scheme/match - syntax/boundmap + syntax/id-table macro-debugger/util/class-iop "interfaces.ss" "controller.ss" @@ -107,18 +107,12 @@ (send -text change-style clickback-style a b))))) (define/public (add-syntax stx - #:binder-table [alpha-table #f] + #:binders [binders null] #:shift-table [shift-table #f] #:definites [definites null] #:hi-colors [hi-colors null] #:hi-stxss [hi-stxss null] #:substitutions [substitutions null]) - (define (get-binders id) - (define binder - (module-identifier-mapping-get alpha-table id (lambda () #f))) - (if shift-table - (cons binder (hash-ref shift-table binder null)) - (list binder))) (let ([display (internal-add-syntax stx)] [definite-table (make-hasheq)]) (let ([range (send: display display<%> get-range)] @@ -141,22 +135,32 @@ (when shift-table (for ([shifted-definite (hash-ref shift-table definite null)]) (hash-set! definite-table shifted-definite #t)))) - (when alpha-table - (let ([range (send: display display<%> get-range)] - [start (send: display display<%> get-start-position)]) - (let* ([binders0 - (module-identifier-mapping-map alpha-table (lambda (k v) k))] - [binders - (apply append (map get-binders binders0))]) - (send: display display<%> underline-syntaxes binders)) - (for ([id (send: range range<%> get-identifier-list)]) - (define definite? (hash-ref definite-table id #f)) - (when #f ;; DISABLED - (add-binding-billboard start range id definite?)) - (for ([binder (get-binders id)]) - (for ([binder-r (send: range range<%> get-ranges binder)]) - (for ([id-r (send: range range<%> get-ranges id)]) - (add-binding-arrow start binder-r id-r definite?))))))) + (let ([binder-table (make-free-id-table)]) + (define range (send: display display<%> get-range)) + (define start (send: display display<%> get-start-position)) + (define (get-binders id) + (let ([binder (free-id-table-ref binder-table id #f)]) + (cond [(not binder) null] + [shift-table (cons binder (get-shifted binder))] + [else (list binder)]))) + (define (get-shifted id) + (hash-ref shift-table id null)) + ;; Populate table + (for ([binder binders]) + (free-id-table-set! binder-table binder binder)) + ;; Underline binders (and shifted binders) + (send: display display<%> underline-syntaxes + (append (apply append (map get-shifted binders)) + binders)) + ;; Make arrows (& billboards, when enabled) + (for ([id (send: range range<%> get-identifier-list)]) + (define definite? (hash-ref definite-table id #f)) + (when #f ;; DISABLED + (add-binding-billboard start range id definite?)) + (for ([binder (get-binders id)]) + (for ([binder-r (send: range range<%> get-ranges binder)]) + (for ([id-r (send: range range<%> get-ranges id)]) + (add-binding-arrow start binder-r id-r definite?)))))) (void))) (define/private (add-binding-arrow start binder-r id-r definite?) diff --git a/collects/macro-debugger/view/step-display.ss b/collects/macro-debugger/view/step-display.ss index ad1d941547..355a940b35 100644 --- a/collects/macro-debugger/view/step-display.ss +++ b/collects/macro-debugger/view/step-display.ss @@ -81,42 +81,41 @@ (add-text "\n"))) (define/public (add-step step - #:binders binders #:shift-table [shift-table #f]) (cond [(step? step) - (show-step step binders shift-table)] + (show-step step shift-table)] [(misstep? step) - (show-misstep step binders shift-table)] + (show-misstep step shift-table)] [(prestep? step) - (show-prestep step binders shift-table)] + (show-prestep step shift-table)] [(poststep? step) - (show-poststep step binders shift-table)])) + (show-poststep step shift-table)])) (define/public (add-syntax stx - #:binders [binders #f] - #:shift-table [shift-table #f] - #:definites [definites null]) + #:binders [binders null] + #:definites [definites null] + #:shift-table [shift-table #f]) (send: sbview sb:syntax-browser<%> add-syntax stx - #:binder-table binders - #:shift-table shift-table - #:definites definites)) + #:binders binders + #:definites definites + #:shift-table shift-table)) (define/public (add-final stx error #:binders binders - #:shift-table [shift-table #f] - #:definites definites) + #:definites definites + #:shift-table [shift-table #f]) (when stx (send*: sbview sb:syntax-browser<%> (add-text "Expansion finished\n") (add-syntax stx - #:binder-table binders - #:shift-table shift-table - #:definites definites))) + #:binders binders + #:definites definites + #:shift-table shift-table))) (when error (add-error error))) ;; show-lctx : Step -> void - (define/private (show-lctx step binders shift-table) + (define/private (show-lctx step shift-table) (define state (protostep-s1 step)) (define lctx (state-lctx state)) (when (pair? lctx) @@ -126,7 +125,7 @@ "while executing macro transformer in:\n") (insert-syntax/redex (bigframe-term bf) (bigframe-foci bf) - binders + (state-binders state) shift-table (state-uses state) (state-frontier state))))) @@ -141,15 +140,15 @@ (step-type->string (protostep-type step)))) ;; show-step : Step -> void - (define/private (show-step step binders shift-table) + (define/private (show-step step shift-table) (let-values ([(common-context state1 state2) (factor-common-context (protostep-s1 step) (step-s2 step))]) - (show-state/redex state1 binders shift-table) + (show-state/redex state1 shift-table) (separator step) - (show-state/contractum state2 binders shift-table) - (show-common-context common-context state1 binders shift-table) - (show-lctx step binders shift-table))) + (show-state/contractum state2 shift-table) + (show-common-context common-context state1 shift-table) + (show-lctx step shift-table))) (define/private (factor-common-context state1 state2) (if (send: config config<%> get-split-context?) @@ -173,7 +172,7 @@ (make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2)) (values common-ctx state1z state2z)) - (define/private (show-common-context ctx state1 binders shift-table) + (define/private (show-common-context ctx state1 shift-table) (match-define (struct state (_ _ _ _ _ uses1 frontier1 _)) state1) (when (pair? ctx) @@ -182,43 +181,43 @@ (send*: sbview sb:syntax-browser<%> (add-text "\nin context:\n") (add-syntax the-syntax - #:binder-table binders - #:shift-table shift-table #:definites uses1 + #:binders (state-binders state1) + #:shift-table shift-table #:substitutions (list (cons hole-stx "[ HOLE ]"))))))) - (define/private (show-state/redex state binders shift-table) + (define/private (show-state/redex state shift-table) (insert-syntax/redex (state-term state) (state-foci state) - binders + (state-binders state) shift-table (state-uses state) (state-frontier state))) - (define/private (show-state/contractum state binders shift-table) + (define/private (show-state/contractum state shift-table) (insert-syntax/contractum (state-term state) (state-foci state) - binders + (state-binders state) shift-table (state-uses state) (state-frontier state))) ;; show-prestep : Step -> void - (define/private (show-prestep step binders shift-table) + (define/private (show-prestep step shift-table) (separator/small step) - (show-state/redex (protostep-s1 step) binders shift-table) - (show-lctx step binders shift-table)) + (show-state/redex (protostep-s1 step) shift-table) + (show-lctx step shift-table)) ;; show-poststep : Step -> void - (define/private (show-poststep step binders shift-table) + (define/private (show-poststep step shift-table) (separator/small step) - (show-state/contractum (protostep-s1 step) binders shift-table) - (show-lctx step binders shift-table)) + (show-state/contractum (protostep-s1 step) shift-table) + (show-lctx step shift-table)) ;; show-misstep : Step -> void - (define/private (show-misstep step binders shift-table) + (define/private (show-misstep step shift-table) (define state (protostep-s1 step)) - (show-state/redex state binders shift-table) + (show-state/redex state shift-table) (separator step) (send*: sbview sb:syntax-browser<%> (add-error-text (exn-message (misstep-exn step))) @@ -226,10 +225,10 @@ (when (exn:fail:syntax? (misstep-exn step)) (for ([e (exn:fail:syntax-exprs (misstep-exn step))]) (send: sbview sb:syntax-browser<%> add-syntax e - #:binder-table binders - #:shift-table shift-table - #:definites (or (state-uses state) null)))) - (show-lctx step binders shift-table)) + #:binders (or (state-binders state) null) + #:definites (or (state-uses state) null) + #:shift-table shift-table))) + (show-lctx step shift-table)) ;; insert-syntax/color (define/private (insert-syntax/color stx foci binders shift-table @@ -238,7 +237,7 @@ (define highlight-frontier? (send: config config<%> get-highlight-frontier?)) (send: sbview sb:syntax-browser<%> add-syntax stx #:definites (or definites null) - #:binder-table binders + #:binders binders #:shift-table shift-table #:hi-colors (list hi-color "WhiteSmoke") diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index b58e0e5879..e13daf5cad 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -47,12 +47,12 @@ (define deriv #f) (define deriv-hidden? #f) - (define binders #f) (define shift-table #f) (define raw-steps #f) (define raw-steps-estx #f) ;; #f if raw-steps-exn is exn (define raw-steps-exn #f) ;; #f if raw-steps-estx is syntax + (define raw-steps-binders #f) (define raw-steps-definites #f) (define raw-steps-oops #f) @@ -75,9 +75,9 @@ (define-guarded-getters (recache-deriv!) [get-deriv deriv] [get-deriv-hidden? deriv-hidden?] - [get-binders binders] [get-shift-table shift-table]) (define-guarded-getters (recache-raw-steps!) + [get-raw-steps-binders raw-steps-binders] [get-raw-steps-definites raw-steps-definites] [get-raw-steps-exn raw-steps-exn] [get-raw-steps-oops raw-steps-oops]) @@ -95,6 +95,7 @@ (set! raw-steps #f) (set! raw-steps-estx #f) (set! raw-steps-exn #f) + (set! raw-steps-binders #f) (set! raw-steps-definites #f) (set! raw-steps-oops #f)) @@ -108,7 +109,6 @@ (invalidate-synth!) (set! deriv #f) (set! deriv-hidden? #f) - (set! binders #f) (set! shift-table #f)) ;; recache! : -> void @@ -141,7 +141,6 @@ (module-identifier-mapping-put! alpha-table id id)) binder-ids) (set! deriv d) - (set! binders alpha-table) (set! shift-table (compute-shift-table d))))))))) ;; recache-synth! : -> void @@ -158,12 +157,13 @@ (with-handlers ([(lambda (e) #t) (lambda (e) (set! raw-steps-oops e))]) - (let-values ([(raw-steps* definites* estx* error*) + (let-values ([(raw-steps* binders* definites* estx* error*) (parameterize ((macro-policy show-macro?)) (reductions+ deriv))]) (set! raw-steps raw-steps*) (set! raw-steps-estx estx*) (set! raw-steps-exn error*) + (set! raw-steps-binders binders*) (set! raw-steps-definites definites*))))))) ;; recache-steps! : -> void @@ -283,7 +283,7 @@ (recache-steps!) (cond [(syntax? raw-steps-estx) (send: displayer step-display<%> add-syntax raw-steps-estx - #:binders binders + #:binders raw-steps-binders #:shift-table shift-table #:definites raw-steps-definites)] [(exn? raw-steps-exn) @@ -297,10 +297,9 @@ (let ([step (cursor:next steps)]) (if step (send: displayer step-display<%> add-step step - #:binders binders #:shift-table shift-table) (send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn - #:binders binders + #:binders raw-steps-binders #:shift-table shift-table #:definites raw-steps-definites)))] [else (display-oops #t)])) diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss index ec0c9fd71e..76ce2365d1 100644 --- a/collects/tests/macro-debugger/gentests.ss +++ b/collects/tests/macro-debugger/gentests.ss @@ -61,7 +61,7 @@ [else #f])) (define (check-hide d policy expect-ok?) - (let-values ([(steps defs stx2 exn) + (let-values ([(steps binders uses stx2 exn) (parameterize ((macro-policy policy)) (reductions+ d))]) (check-pred list? steps) diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.ss index 5fdb4646b0..8ca59c2eea 100644 --- a/collects/tests/macro-debugger/test-setup.ss +++ b/collects/tests/macro-debugger/test-setup.ss @@ -127,7 +127,7 @@ ;; Specialized macro hiding tests (define (stx/hide-policy d policy) - (define-values (_steps _uses stx _exn) + (define-values (_steps _binders _uses stx _exn) (parameterize ((macro-policy policy)) (reductions+ d))) stx) diff --git a/collects/tests/macro-debugger/tests/collects.ss b/collects/tests/macro-debugger/tests/collects.ss index cbcf8d79f0..524b5629ea 100644 --- a/collects/tests/macro-debugger/tests/collects.ss +++ b/collects/tests/macro-debugger/tests/collects.ss @@ -66,7 +66,7 @@ (check-steps deriv policy)))) (define (check-steps deriv policy) - (define-values (steps defs stx exn) + (define-values (steps binders uses stx exn) (parameterize ((macro-policy policy)) (reductions+ deriv))) (check-pred syntax? stx) (check-eq? exn #f) diff --git a/collects/tests/macro-debugger/tests/hiding.ss b/collects/tests/macro-debugger/tests/hiding.ss index 8cf25d2a02..b4de80e0e1 100644 --- a/collects/tests/macro-debugger/tests/hiding.ss +++ b/collects/tests/macro-debugger/tests/hiding.ss @@ -11,7 +11,7 @@ (syntax-rules () [(th form hidden-e2 policy) (test-case (format "~s" 'form) - (let-values ([(steps defs stx exn) + (let-values ([(steps binders uses stx exn) (parameterize ((macro-policy policy)) (reductions+ (trace/k 'form)))]) (check-pred syntax? stx)