0197902309
Macros and other tools that need syntax privilege used `(current-code-inspector)' at the module top-level to try to capture the right code inspector at load time. It's more consistent to instead use the enclosing module's declaration-time inspector, and `var-ref->mod-decl-insp' provides that. The new function works only on references to anonymous variables, which limits access to the inspector. The real function name is longer, of course.
402 lines
19 KiB
Racket
402 lines
19 KiB
Racket
(module annotator scheme/base
|
|
|
|
(require (prefix-in kernel: syntax/kerncase)
|
|
gui-debugger/marks
|
|
mzlib/etc
|
|
(prefix-in srfi: srfi/1/search)
|
|
(for-syntax scheme/base)
|
|
(only-in mzscheme [apply plain-apply])
|
|
)
|
|
(provide annotate-stx annotate-for-single-stepping)
|
|
|
|
(define (arglist-bindings arglist-stx)
|
|
(syntax-case arglist-stx ()
|
|
[var
|
|
(identifier? arglist-stx)
|
|
(list arglist-stx)]
|
|
[(var ...)
|
|
(syntax->list arglist-stx)]
|
|
[(var . others)
|
|
(cons #'var (arglist-bindings #'others))]))
|
|
|
|
;; Retreives the binding of a variable from a normal-breakpoint-info.
|
|
;; Returns a list of pairs `(,variable-name-stx ,variable-value). Each
|
|
;; item in the list is a shadowed instance of a variable with the given
|
|
;; name, with the first item being the one in scope.
|
|
#;
|
|
(define (bindings top-mark marks sym)
|
|
(let ([mark-list (cons top-mark (continuation-mark-set->list marks debug-key))])
|
|
(map (lambda (binding) (list (mark-binding-binding binding)
|
|
(mark-binding-value binding)))
|
|
(lookup-all-bindings (lambda (id) (eq? (syntax-e id) sym))
|
|
mark-list))))
|
|
|
|
|
|
;; annotate-for-single-stepping uses annotate-stx to create an annotated
|
|
;; version of STX that pauses before and after each expression, in the style
|
|
;; of a single stepping debugger.
|
|
;;
|
|
;; BREAK?, BREAK-BEFORE, BREAK-AFTER are inserted into the resulting syntax
|
|
;; as 3D code. When the resulting syntax is evaluated, before each
|
|
;; expression is evaluated, BREAK? is called with the syntax position of
|
|
;; that expression. If BREAK? returns true, BREAK-BEFORE is called with two
|
|
;; arguments: the debug-info structure representing the first stack frame
|
|
;; and the current continuation marks representing the other stack frames
|
|
;; (use the key DEBUG-KEY). If BREAK-BEFORE returns some value, the
|
|
;; evaluation skips the expression entirely and just returns that value.
|
|
;; Otherwise, evaluation proceeds normally. After the expression is
|
|
;; evaluated, BREAK? is called with the position of the end of the expression.
|
|
;; If it returns true, BREAK-AFTER is called; otherwise, the expression returns
|
|
;; normally. If BREAK-AFTER returns some value, the
|
|
;; return value of the expression is replaced by that value.
|
|
;;
|
|
;; RECORD-BOUND-ID and RECORD-TOP-LEVEL-ID are simply passed to ANNOTATE-STX.
|
|
|
|
(define annotate-for-single-stepping
|
|
(opt-lambda (stx break? break-before break-after record-bound-id record-top-level-id [source #f])
|
|
(annotate-stx
|
|
stx
|
|
(lambda (debug-info annotated raw is-tail?)
|
|
(let* ([start (syntax-position raw)]
|
|
[end (+ start (syntax-span raw) -1)]
|
|
[break? (break? (syntax-source raw))])
|
|
(if is-tail?
|
|
#`(let-values ([(value-list) #f])
|
|
(if (#%plain-app #,break? #,start)
|
|
(set! value-list (#%plain-app
|
|
#,break-before
|
|
#,debug-info
|
|
(#%plain-app current-continuation-marks)))
|
|
(#%plain-app void))
|
|
(if (#%plain-app not value-list)
|
|
#,annotated
|
|
(#%plain-app plain-apply values value-list)))
|
|
#`(let-values ([(value-list) #f])
|
|
(if (#%plain-app #,break? #,start)
|
|
(set! value-list (#%plain-app
|
|
#,break-before
|
|
#,debug-info
|
|
(#%plain-app current-continuation-marks)))
|
|
(#%plain-app void))
|
|
(if (#%plain-app not value-list)
|
|
(#%plain-app
|
|
call-with-values
|
|
(#%plain-lambda () #,annotated)
|
|
(case-lambda
|
|
[(val) (if (#%plain-app #,break? #,end)
|
|
(#%plain-app
|
|
#,break-after
|
|
#,debug-info
|
|
(#%plain-app current-continuation-marks) val)
|
|
val)]
|
|
[vals (if (#%plain-app
|
|
#,break? #,end)
|
|
(#%plain-app
|
|
plain-apply
|
|
#,break-after
|
|
#,debug-info
|
|
(#%plain-app current-continuation-marks) vals)
|
|
(#%plain-app plain-apply values vals))]))
|
|
(if (#%plain-app #,break? #,end)
|
|
(#%plain-app
|
|
plain-apply #,break-after
|
|
#,debug-info
|
|
(#%plain-app current-continuation-marks)
|
|
value-list)
|
|
(#%plain-app plain-apply values value-list)))))))
|
|
record-bound-id
|
|
record-top-level-id
|
|
source)))
|
|
|
|
|
|
; annotate-stx : (syntax?
|
|
; (mark? syntax? syntax? boolean? . -> . syntax?)
|
|
; (symbol? syntax? syntax? . -> . void?)
|
|
; . -> .
|
|
; syntax?)
|
|
|
|
|
|
;; annotate-stx consumes a syntax, transverses it, and gives the opportunity
|
|
;; to the break-wrap to annotate every expression. Once for each expression
|
|
;; in the source program, annotate-stx will call break-wrap with that
|
|
;; expression as an argument and insert the result in the original syntax.
|
|
;; Expressions that were duplicated during the macro expansion are
|
|
;; nevertheless only wrapped once.
|
|
;;
|
|
;; annotate-stx inserts annotations around each expression that introduces a
|
|
;; new scope: let, lambda, and function calls. These annotations reify the
|
|
;; call stack, and allows to list the current variable in scope, look up
|
|
;; their value, as well as change their value. The reified stack is accessed
|
|
;; via the CURRENT-CONTINUATION-MARKS using the key DEBUG-KEY
|
|
;;
|
|
;; BREAK-WRAP is called with four arguments:
|
|
;; debug-info : the top frame of the reified stack (which never changes
|
|
;; across execution)
|
|
;; annotate-stx : the syntax with its subbranches already
|
|
;; annotated. BREAK-WRAP should return a modified version of this syntax.
|
|
;; original-stx : the original syntax before annoatations
|
|
;; is-tail? : true when original syntax was in tail position
|
|
;;
|
|
;; The RECORD-BOUND-ID function is a callback that is invoked each time a
|
|
;; new variable is introduced, looked up, or set in STX (lexically).
|
|
;; RECORD-BOUND-ID takes three arguments:
|
|
;; use-case : either 'bind or 'ref or 'set, respectively
|
|
;; bound-stx : syntax where the symbol is introduced, looked up, set, respectively
|
|
;; binding-stx : syntax where the symbol was bound
|
|
;;
|
|
;; Naturally, when USE-CASE is 'bind, BOUND-STX and BINDING-STX are equal.
|
|
;;
|
|
(define annotate-stx
|
|
(opt-lambda (stx break-wrap record-bound-id record-top-level-id [source #f])
|
|
|
|
(define breakpoints (make-hasheq))
|
|
|
|
(define (previous-bindings bound-vars)
|
|
(if (null? bound-vars)
|
|
#'null
|
|
#'(#%plain-app debugger-local-bindings)))
|
|
|
|
(define (top-level-annotate stx)
|
|
(kernel:kernel-syntax-case/phase
|
|
stx (namespace-base-phase)
|
|
[(module identifier name mb)
|
|
(syntax-case (disarm #'mb) ()
|
|
[(plain-module-begin . module-level-exprs)
|
|
(with-syntax ([(module . _) stx])
|
|
(quasisyntax/loc stx (module identifier name
|
|
#,(rearm
|
|
#'mb
|
|
#`(plain-module-begin
|
|
#,@(map (lambda (e) (module-level-expr-iterator
|
|
e (list (syntax-e #'identifier)
|
|
(syntax-source #'identifier))))
|
|
(syntax->list #'module-level-exprs)))))))])]
|
|
[else-stx
|
|
(general-top-level-expr-iterator stx #f)]))
|
|
|
|
(define (module-level-expr-iterator stx module-name )
|
|
(kernel:kernel-syntax-case
|
|
stx #f
|
|
[(#%provide . provide-specs)
|
|
stx]
|
|
[else-stx
|
|
(general-top-level-expr-iterator stx module-name )]))
|
|
|
|
(define (general-top-level-expr-iterator stx module-name )
|
|
(kernel:kernel-syntax-case
|
|
stx #f
|
|
[(define-values (var ...) expr)
|
|
|
|
(begin
|
|
(for-each (lambda (v) (record-bound-id 'bind v v))
|
|
(syntax->list #'(var ...)))
|
|
(quasisyntax/loc stx
|
|
(begin (define-values (var ...) #,(annotate #`expr '() #t module-name))
|
|
#,(if (syntax-source stx)
|
|
#`(begin (#%plain-app
|
|
#,record-top-level-id '#,module-name #'var (case-lambda
|
|
[() var]
|
|
[(v) (set! var v)])) ...)
|
|
#'(#%plain-app void))
|
|
(#%plain-app void)))
|
|
)
|
|
]
|
|
[(define-syntaxes (var ...) expr)
|
|
stx]
|
|
[(begin-for-syntax . exprs)
|
|
;; compile time, so treat it like define-syntaxes
|
|
stx]
|
|
[(begin . top-level-exprs)
|
|
(quasisyntax/loc stx (begin #,@(map (lambda (expr)
|
|
(module-level-expr-iterator expr module-name ))
|
|
(syntax->list #'top-level-exprs))))]
|
|
[(#%require . require-specs)
|
|
stx]
|
|
[else
|
|
(annotate stx '() #f module-name )]))
|
|
|
|
(define (annotate expr bound-vars is-tail? module-name)
|
|
|
|
(define annotate-break?
|
|
(let ([pos (syntax-position expr)]
|
|
[src (syntax-source expr)])
|
|
(and src pos
|
|
(hash-ref breakpoints pos (lambda () #t))
|
|
(kernel:kernel-syntax-case
|
|
expr #f
|
|
[(if test then else) #t]
|
|
[(begin . bodies) #t]
|
|
[(begin0 . bodies) #t]
|
|
[(let-values . clause) #t]
|
|
[(letrec-values . clause) #t]
|
|
[(set! var val) #t]
|
|
[(with-continuation-mark key mark body) #t]
|
|
[(#%plain-app . exprs) #t]
|
|
[_ #f])
|
|
(begin
|
|
(hash-set! breakpoints pos #f)
|
|
(when (not is-tail?)
|
|
(hash-set! breakpoints (+ pos (syntax-span expr) -1) #f))
|
|
#t))))
|
|
|
|
(define (let/rec-values-annotator letrec?)
|
|
(kernel:kernel-syntax-case
|
|
(disarm expr) #f
|
|
[(label (((var ...) rhs) ...) . bodies)
|
|
(let* ([new-bindings (apply append
|
|
(map syntax->list
|
|
(syntax->list #`((var ...) ...))))]
|
|
[all-bindings (append new-bindings bound-vars)]
|
|
[new-rhs (map (lambda (expr)
|
|
(annotate expr
|
|
(if letrec? all-bindings bound-vars)
|
|
#f module-name ))
|
|
(syntax->list #'(rhs ...)))]
|
|
[last-body (car (reverse (syntax->list #'bodies)))]
|
|
[all-but-last-body (reverse (cdr (reverse (syntax->list #'bodies))))]
|
|
[bodies (append (map (lambda (expr)
|
|
(annotate expr all-bindings #f module-name ))
|
|
all-but-last-body)
|
|
(list (annotate
|
|
last-body
|
|
all-bindings
|
|
is-tail? module-name )))]
|
|
[local-debug-info (assemble-debug-info new-bindings new-bindings 'normal #f)]
|
|
[previous-bindings (previous-bindings bound-vars)])
|
|
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bindings)
|
|
(with-syntax ([(new-rhs/trans ...) new-rhs]
|
|
[previous-bindings previous-bindings])
|
|
(if letrec?
|
|
(quasisyntax/loc expr
|
|
(let ([old-bindings previous-bindings])
|
|
(label (((debugger-local-bindings) (#%plain-lambda ()
|
|
(#%plain-app
|
|
list*
|
|
#,@local-debug-info
|
|
old-bindings)))
|
|
((var ...) new-rhs/trans) ...)
|
|
#,@bodies)))
|
|
(quasisyntax/loc expr
|
|
(label (((var ...) new-rhs/trans) ...)
|
|
(let ([debugger-local-bindings (#%plain-lambda ()
|
|
(#%plain-app
|
|
list*
|
|
#,@local-debug-info
|
|
previous-bindings))])
|
|
#,@bodies))))))]))
|
|
|
|
(define (lambda-clause-annotator clause)
|
|
(kernel:kernel-syntax-case
|
|
clause #f
|
|
[(arg-list . bodies)
|
|
(let* ([new-bound-vars (arglist-bindings #'arg-list)]
|
|
[all-bound-vars (append new-bound-vars bound-vars)]
|
|
[new-bodies (let loop ([bodies (syntax->list #'bodies)])
|
|
(if (equal? '() (cdr bodies))
|
|
(list (annotate (car bodies) all-bound-vars #t module-name ))
|
|
(cons (annotate (car bodies) all-bound-vars #f module-name )
|
|
(loop (cdr bodies)))))])
|
|
(for-each (lambda (id) (record-bound-id 'bind id id)) new-bound-vars)
|
|
(quasisyntax/loc clause
|
|
(arg-list
|
|
(let ([debugger-local-bindings
|
|
(#%plain-lambda ()
|
|
(#%plain-app
|
|
list*
|
|
#,@(assemble-debug-info new-bound-vars new-bound-vars 'normal #f)
|
|
#,(previous-bindings bound-vars)))])
|
|
#,@new-bodies))))]))
|
|
|
|
(define annotated
|
|
(rearm
|
|
expr
|
|
(kernel:kernel-syntax-case
|
|
(disarm expr) #f
|
|
[var-stx (identifier? (syntax var-stx))
|
|
(let ([binder (and (syntax-original? expr)
|
|
(srfi:member expr bound-vars free-identifier=?))])
|
|
(if binder
|
|
(record-bound-id 'ref expr (car binder))
|
|
(record-bound-id 'top-level expr expr))
|
|
expr)]
|
|
|
|
[(#%plain-lambda . clause)
|
|
(quasisyntax/loc expr
|
|
(#%plain-lambda #,@(lambda-clause-annotator #'clause)))]
|
|
|
|
[(case-lambda . clauses)
|
|
(quasisyntax/loc expr
|
|
(case-lambda #,@(map lambda-clause-annotator (syntax->list #'clauses))))]
|
|
|
|
[(if test then else)
|
|
(quasisyntax/loc expr (if #,(annotate #'test bound-vars #f module-name )
|
|
#,(annotate #'then bound-vars is-tail? module-name )
|
|
#,(annotate #'else bound-vars is-tail? module-name )))]
|
|
|
|
[(begin . bodies)
|
|
(letrec ([traverse
|
|
(lambda (lst)
|
|
(if (and (pair? lst) (equal? '() (cdr lst)))
|
|
`(,(annotate (car lst) bound-vars is-tail? module-name ))
|
|
(cons (annotate (car lst) bound-vars #f module-name )
|
|
(traverse (cdr lst)))))])
|
|
(quasisyntax/loc expr (begin #,@(traverse (syntax->list #'bodies)))))]
|
|
|
|
[(begin0 . bodies)
|
|
(quasisyntax/loc expr (begin0 #,@(map (lambda (expr)
|
|
(annotate expr bound-vars #f module-name ))
|
|
(syntax->list #'bodies))))]
|
|
|
|
[(let-values . clause)
|
|
(let/rec-values-annotator #f)]
|
|
|
|
[(letrec-values . clause)
|
|
(let/rec-values-annotator #t)]
|
|
|
|
[(set! var val)
|
|
(let ([binder (and (syntax-original? #'var)
|
|
(srfi:member #'var bound-vars free-identifier=?))])
|
|
(when binder
|
|
(record-bound-id 'set expr (car binder)))
|
|
(quasisyntax/loc expr (set! var #,(annotate #`val bound-vars #f module-name ))))]
|
|
|
|
[(quote _) expr]
|
|
|
|
[(quote-syntax _) expr]
|
|
|
|
[(with-continuation-mark key mark body)
|
|
(quasisyntax/loc expr (with-continuation-mark key
|
|
#,(annotate #'mark bound-vars #f module-name )
|
|
#,(annotate #'body bound-vars is-tail? module-name )))]
|
|
|
|
[(#%plain-app . exprs)
|
|
(let ([subexprs (map (lambda (expr)
|
|
(annotate expr bound-vars #f module-name ))
|
|
(syntax->list #'exprs))])
|
|
(if (or is-tail? (not (syntax-source expr)))
|
|
(quasisyntax/loc expr (#%plain-app . #,subexprs))
|
|
(wcm-wrap (make-debug-info module-name expr bound-vars bound-vars 'normal #f (previous-bindings bound-vars))
|
|
(quasisyntax/loc expr (#%plain-app . #,subexprs)))))]
|
|
|
|
[(#%top . var) expr]
|
|
[(#%variable-reference . _) expr]
|
|
|
|
[else (error 'expr-syntax-object-iterator "unknown expr: ~a"
|
|
(syntax->datum expr))])))
|
|
|
|
(if annotate-break?
|
|
(break-wrap
|
|
(make-debug-info module-name expr bound-vars bound-vars 'at-break #f (previous-bindings bound-vars))
|
|
annotated
|
|
expr
|
|
is-tail?)
|
|
annotated))
|
|
|
|
(values (top-level-annotate stx) (hash-map breakpoints (lambda (k v) k)))))
|
|
|
|
(define (disarm stx) (syntax-disarm stx code-insp))
|
|
(define (rearm old new) (syntax-rearm new old))
|
|
|
|
(define code-insp (variable-reference->module-declaration-inspector
|
|
(#%variable-reference))))
|