trace.rkt (7636B)
1 #lang racket/base 2 (require (for-syntax racket/base) 3 racket/promise 4 racket/list 5 syntax/modcode 6 syntax/modresolve 7 parser-tools/lex 8 "deriv-parser.rkt" 9 "deriv-tokens.rkt") 10 11 (provide trace 12 trace* 13 trace-module 14 trace*-module 15 trace/result 16 trace-verbose? 17 events->token-generator 18 current-expand-observe 19 expand/compile-time-evals 20 21 trace-macro-limit 22 trace-limit-handler) 23 24 (define current-expand-observe 25 (dynamic-require ''#%expobs 'current-expand-observe)) 26 27 (define trace-verbose? (make-parameter #f)) 28 29 ;; trace : stx -> Deriv 30 (define (trace stx [expander expand/compile-time-evals]) 31 (let-values ([(result events derivp) (trace* stx expander)]) 32 (force derivp))) 33 34 ;; trace-module : module-path -> Deriv 35 (define (trace-module module-path) 36 (let-values ([(result events derivp) (trace*-module module-path)]) 37 (force derivp))) 38 39 ;; trace/result : stx -> stx/exn Deriv 40 (define (trace/result stx [expander expand/compile-time-evals]) 41 (let-values ([(result events derivp) (trace* stx expander)]) 42 (values result 43 (force derivp)))) 44 45 ;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv) 46 (define (trace* stx [expander expand/compile-time-evals]) 47 (let-values ([(result events) (expand/events stx expander)]) 48 (values result 49 events 50 (delay (parse-derivation 51 (events->token-generator events)))))) 52 53 ;; trace*-module : module-path -> stx/exn (listof event) (promiseof Deriv) 54 (define (trace*-module module-path) 55 (get-module-code (resolve-module-path module-path #f) 56 #:choose (lambda _ 'src) 57 #:compile (lambda (stx) 58 (trace* stx expand)))) 59 60 ;; events->token-generator : (list-of event) -> (-> token) 61 (define (events->token-generator events) 62 (let ([pos 1]) 63 (lambda () 64 (define sig+val (car events)) 65 (set! events (cdr events)) 66 (let* ([sig (car sig+val)] 67 [val (cdr sig+val)] 68 [t (tokenize sig val pos)]) 69 (when (trace-verbose?) 70 (printf "~s: ~s\n" pos 71 (token-name (position-token-token t)))) 72 (set! pos (add1 pos)) 73 t)))) 74 75 (define trace-macro-limit (make-parameter +inf.0)) 76 (define trace-limit-handler (make-parameter #f)) 77 78 ;; expand/events : stx (stx -> stx) -> stx/exn (list-of event) 79 (define (expand/events sexpr expander) 80 (define events null) 81 ;; Problem: jumps within expansion (eg, macro catches error thrown from within 82 ;; call to 'local-expand') can result in ill-formed event stream. 83 ;; In general, not possible to detect jump endpoints, but we can at least isolate 84 ;; the bad parts by watching for mismatched bracketing events 85 ;; (eg, macro-{pre,post}-transform). 86 (define counter 0) ;; = (length events) 87 (define macro-stack null) ;; (listof (cons (U stx 'local-bind) nat)) 88 (define (add! x y) 89 (set! counter (add1 counter)) 90 (set! events (cons (cons (signal->symbol x) y) events))) 91 (define add!/check 92 (let ([limit (trace-macro-limit)] 93 [handler (trace-limit-handler)] 94 [limit-counter 0] 95 [last-local-value-id #f]) 96 (lambda (x y) 97 (add! x y) 98 (case x 99 ((8) ;; enter-macro 100 (set! limit-counter (add1 limit-counter)) 101 (when (>= limit-counter limit) 102 (set! limit (handler limit-counter)))) 103 ((21) ;; macro-pre-transform 104 (let ([rec (cons y counter)]) 105 (set! macro-stack (cons rec macro-stack)))) 106 ((22) ;; macro-post-transform 107 (cond [(and (pair? macro-stack) 108 (eq? (car (car macro-stack)) (cdr y))) 109 (set! macro-stack (cdr macro-stack))] 110 [else ;; Jumped! 111 (let loop ([ms macro-stack]) 112 (let ([top (car ms)]) 113 (cond [(eq? (car top) (cdr y)) 114 (let* ([reset-to (cdr top)] 115 [len (- counter reset-to 1)] 116 [pfx (take (cdr events) len)] 117 [sfx (drop (cdr events) len)]) 118 (set! macro-stack (cdr ms)) 119 (set! events sfx) 120 (set! counter (cdr top)) 121 (add! 'local-mess (reverse pfx)) 122 (add! 'macro-post-transform y))] 123 [else (loop (cdr ms))])))])) 124 ((143) ;; local-bind 125 (let ([rec (cons 'local-bind counter)]) 126 (set! macro-stack (cons rec macro-stack)))) 127 ((160) ;; exit-local-bind 128 (let ([top (car macro-stack)]) 129 (cond [(eq? (car top) 'local-bind) 130 (set! macro-stack (cdr macro-stack))] 131 [else ;; Jumped! 132 (error 'trace "internal error: cannot handle catch within bind")]))) 133 ((153) ;; local-value 134 (set! last-local-value-id y)) 135 ((154) ;; local-value-result 136 (add! 'local-value-binding 137 (and y (identifier-binding last-local-value-id))) 138 (set! last-local-value-id #f)))))) 139 (parameterize ((current-expand-observe add!/check)) 140 (let ([result 141 (with-handlers ([(lambda (exn) #t) 142 (lambda (exn) 143 (add! 'error exn) 144 exn)]) 145 (expander sexpr))]) 146 (add! 'EOF #f) 147 (values result 148 (reverse events))))) 149 150 (require syntax/stx 151 syntax/kerncase) 152 153 (define (emit sig [val #f]) 154 ((current-expand-observe) sig val)) 155 156 (define (expand/compile-time-evals stx) 157 (define (expand/cte stx) 158 (define _ (emit 'visit stx)) 159 (define e1 (expand-syntax-to-top-form stx)) 160 (define e2 161 (syntax-case e1 (begin) 162 [(begin expr ...) 163 (begin 164 (emit 'top-begin e1) 165 (with-syntax ([(expr ...) 166 ;;left-to-right part of this map is important: 167 (map (lambda (e) 168 (emit 'next) 169 (expand/cte e)) 170 (syntax->list #'(expr ...)))] 171 [beg (stx-car e1)]) 172 (datum->syntax e1 (syntax-e (syntax (beg expr ...))) e1 e1)))] 173 [else 174 (begin 175 (emit 'top-non-begin) 176 (let ([e (expand-syntax e1)]) 177 ;; Must set to void to avoid catching DrRacket's annotations... 178 (parameterize ((current-expand-observe void)) 179 (eval-compile-time-part e)) 180 e))])) 181 (emit 'return e2) 182 e2) 183 (emit 'start) 184 (expand/cte (namespace-syntax-introduce (datum->syntax #f stx)))) 185 186 ;; eval-compile-time-part : syntax boolean -> void 187 ;; compiles the syntax it receives as an argument and evaluates the compile-time part of it. 188 ;; pre: there are no top-level begins in stx. 189 (define (eval-compile-time-part stx) 190 (define (eval/compile stx) 191 (eval (compile-syntax stx))) 192 (kernel-syntax-case stx #f 193 [(#%require req ...) 194 (for ([req (syntax->list #'(req ...))]) 195 (namespace-require/expansion-time (syntax->datum req)))] 196 [(module . _) 197 (eval/compile stx)] 198 [(define-syntaxes . _) 199 (eval/compile stx)] 200 [(begin-for-syntax . _) 201 (eval/compile stx)] 202 [(define-values (id ...) . _) 203 (eval/compile #'(define-syntaxes (id ...) (values)))] 204 [_else 205 (void)]))