#lang racket/base (require (prefix-in kernel: syntax/kerncase) racket/match racket/contract "marks.rkt" "shared.rkt" "syntax-property.rkt" "my-macros.rkt" #;"xml-box.rkt" (prefix-in beginner-defined: "beginner-defined.rkt") (for-syntax racket/base)) (define-syntax (where stx) (syntax-case stx () [(_ body bindings) (syntax/loc stx (letrec bindings body))])) ; CONTRACTS ; PROVIDE (provide/contract [annotate (syntax? ; syntax to annotate ((or/c continuation-mark-set? false/c) break-kind? (or/c list? false/c) . -> . any/c) ; procedure for runtime break boolean? ; show-lambdas-as-lambdas? . -> . syntax?)] ; result #;[top-level-rewrite (-> syntax? syntax?)]) ; ; ; ; ; ; ; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; oh-say-can-you-see,by-the-dawn's-early-light,what-so-proudly-we-hailed,at-the-twilight's-last-gle ; a m i n g . W h o s e b r o a d s t r i p ; pe s a n d b r i g h t s t a r s , t hrough-the-perilous-night,o'er-the-ramparts-we-watched,were- ; s o g a l l a n t l y s t r e a m i n g . ; an d t h e r o c k e t ' s r e d g l are,the-bombs-bursting-in-air,gave-proof-through-the-night,, ; t h a t o u r f l a g w a s s t i l l t h ; er e . O h s a y , d o e s t h a t s tar-spangled-banner-yet-wave,o'er-the-land-of-the-free,and-t ; h e h o m e o f t h e b r a v e ? . . . . ; .. . . . . . . . . . . . . . . . . . ............................................................ ; . . . . . . . . . . . . . . . . . . . . . ; .........you-know,-this-flag-doesn't-feel-quite-as............................................... ; . . ; ..........lighthearted-as-it-did-when-I-created-it-in-1998....................................... ; . . ; ................................................................................................. ; . . ; ................................................................................................. ; . . ; ................................................................................................. ; . . ; ................................................................................................. ; . . ; ................................................................................................. ; . . ; ................................................................................................. ; ;; given an expression to annotate, and a 'break' expression to call ;; when a breakpoint occurs, and a boolean indicating whether ;; lambdas are to be displayed as lambdas, return an annotated expression. (define (annotate main-exp break show-lambdas-as-lambdas?) #;(define _ (>>> main-exp #;(syntax->datum main-exp))) (define binding-indexer (let ([binding-index 0]) (lambda () (let ([temp binding-index]) (set! binding-index (+ binding-index 1)) temp)))) (define (normal-break) (break (current-continuation-marks) 'normal-break #f)) (define (result-exp-break) (break (current-continuation-marks) 'result-exp-break #f)) (define (result-value-break vals-list) (break (current-continuation-marks) 'result-value-break vals-list)) (define (normal-break/values vals-list) (break (current-continuation-marks) 'normal-break/values vals-list)) (define (exp-finished-break info-list) (break #f 'expr-finished-break info-list)) (define (double-break) (break (current-continuation-marks) 'double-break #f)) (define ((make-opaque-exp-break exp)) (exp-finished-break (list (list (lambda () exp) #f (lambda () (error 'make-define-struct-break "no getter for a define-struct")))))) ; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr (define (wcm-pre-break-wrap debug-info exp) (wcm-wrap debug-info (pre-break-wrap exp))) ;; wrap a pre-break around stx (define (pre-break-wrap stx) #`(begin (#%plain-app #,result-exp-break) #,stx)) ;; wrap a normal break around stx (define (break-wrap exp) #`(begin (#%plain-app #,normal-break) #,exp)); ;; wrap a double-break around exp (define (double-break-wrap exp) #`(begin (#%plain-app #,double-break) #,exp)) ;; abstraction used in the next two defs (define (return-value-wrap-maker break-proc) (lambda (exp) #`(#%plain-app call-with-values (#%plain-lambda () #,exp) (#%plain-lambda args (#%plain-app #,break-proc args) (#%plain-app #,apply values args))))) ;; wrap a return-value-break around exp (define return-value-wrap (return-value-wrap-maker result-value-break)) ;; wrap a normal-break/values around exp (define normal-break/values-wrap (return-value-wrap-maker normal-break/values)) (define (top-level-annotate/inner exp source-exp defined-name) (match-let* ([(vector annotated dont-care) (annotate/inner exp 'all #f defined-name)]) #`(with-continuation-mark #,debug-key #,(make-top-level-mark source-exp) ;; inserting eta-expansion to prevent destruction of top-level mark (#%plain-app call-with-values (#%plain-lambda () #,annotated) (#%plain-lambda args (#%plain-app #,apply values args)))))) ; annotate/inner takes ; a) an expression to annotate ; b) a list of all bindings which this expression is tail w.r.t. ; or 'all to indicate that this expression is tail w.r.t. _all_ bindings. ; d) a boolean indicating whether this expression will be the r.h.s. of a reduction ; (and therefore should be broken before) ; g) information about the binding name of the given expression. This is used ; to associate a name with a closure mark (though this may now be redundant) ; it returns (as a 2vals) ; a) an annotated s-expression ; b) a list of varrefs for the variables which occur free in the expression ; ;(syntax-object BINDING-SET bool bool (or/c #f symbol (list binding symbol)) -> ; sexp (list-of z:varref)) ; ; ; ; ; ; ; ; ;;; ; ;; ; ;; ;;; ;;;; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; ; ; ; ; ; ; ;;;; ; ; ; ; (define annotate/inner #;(syntax? binding-set? boolean? (or/c false/c syntax? (list/p syntax? syntax?)) (or/c false/c integer?) . -> . (vector/p syntax? binding-set?)) (lambda (exp tail-bound pre-break? procedure-name-info) ;; annotate an exp with a stepper/skipto or stepper-skipto/discard ;; label (define (dont-annotate traversal) ;; mutable, to catch free vars. Mutated several times, we ;; only care about the last. A bit yecchy. (define free-vars-captured #f) (define (subterm-recur subterm) (match-let* ([(vector stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) (set! free-vars-captured free-vars) stx)) (define annotated (skipto/auto exp traversal subterm-recur)) (vector (wcm-wrap skipto-mark annotated) free-vars-captured)) ;; recurrence procedures, used to recur on sub-expressions: (define (tail-recur exp) (annotate/inner exp tail-bound #t procedure-name-info)) (define (non-tail-recur exp) (annotate/inner exp null #f #f)) (define (result-recur exp) (annotate/inner exp null #f procedure-name-info)) (define (set!-rhs-recur exp name) (annotate/inner exp null #f name)) (define (let-rhs-recur exp binding-names dyn-index-syms) (define proc-name-info (if (not (null? binding-names)) (list (car binding-names) (car dyn-index-syms)) #f)) (annotate/inner exp null #f proc-name-info)) (define (lambda-body-recur exp) (annotate/inner exp 'all #t #f)) ; let bodies have a startling number of recurrence patterns. ouch! ;; ... looks like these can maybe be collapsed with a simpler desired reduction sequence ;; (a.k.a. not safe-for-space). ;; no pre-break, tail w.r.t. new bindings: (define (let-body-recur/single exp bindings) (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)) ;; different flavors of make-debug-info allow users to provide only the needed fields: (define (make-debug-info-normal free-bindings) (make-debug-info exp tail-bound free-bindings 'none #t)) (define (make-debug-info-app tail-bound free-bindings label) (make-debug-info exp tail-bound free-bindings label #t)) (define (make-debug-info-let free-bindings binding-list let-counter) (make-debug-info exp (binding-set-union (list tail-bound binding-list (list let-counter))) (varref-set-union (list free-bindings binding-list (list let-counter))) ; NB using bindings as varrefs 'let-body #t)) (define (make-debug-info-fake-exp exp free-bindings) (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) tail-bound free-bindings 'none #t)) (define (make-debug-info-fake-exp/tail-bound exp tail-bound free-bindings) (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) tail-bound free-bindings 'none #t)) (define outer-wcm-wrap (if pre-break? wcm-pre-break-wrap wcm-wrap)) (define (wcm-break-wrap debug-info exp) (outer-wcm-wrap debug-info (break-wrap exp))) ;; used for things that are values: (define (normal-bundle free-vars annotated) (vector (outer-wcm-wrap (make-debug-info-normal free-vars) annotated) free-vars)) ; @@ @@ @@ ; @ @ @ ; @ $@$: @@+-$: @-@$ $@:@ $@$: ; @ -@ @+@$@ @+ *$ $* *@ -@ ; @ -$@$@ @ @ @ @ @ @ @ -$@$@ ; @ $* @ @ @ @ @ @ @ @ $* @ ; @ @- *@ @ @ @ @ +$ $* *@ @- *@ ; @@@@@ -$$-@@@@@@@@@@@+@$ $@:@@ -$$-@@ ; (define (lambda-clause-abstraction clause) (with-syntax ([(args-stx . bodies) clause]) (match-let* ([(vector annotated-body free-varrefs) ; wrap bodies in explicit begin if more than 1 ; user-introduced (non-skipped) bodies ; NB: CAN'T HAPPEN in beginner up through int/lambda (let ([non-skipped-bodies (filter (lambda (clause) (not (to-be-skipped? clause))) (syntax->list (syntax bodies)))]) (if (> (length non-skipped-bodies) 1) (lambda-body-recur (syntax (begin . bodies))) (match-let* ([(vector annotated-bodies free-var-sets) (2vals-map lambda-body-recur (syntax->list #`bodies))]) (vector #`(begin . #,annotated-bodies) (varref-set-union free-var-sets)))))] [new-free-varrefs (varref-set-remove-bindings free-varrefs (arglist-flatten #'args-stx))]) (vector (datum->syntax #'here `(,#'args-stx ,annotated-body) #'clause) new-free-varrefs)))) (define (outer-lambda-abstraction annotated-lambda free-varrefs) (let* ([closure-info (make-debug-info-app 'all free-varrefs 'none)] ;; if we manually disable the storage of names, ;; lambdas get rendered as lambdas. ;; Yikes, this seems like a pretty gross hack... JBC 2010-12 [closure-name (if show-lambdas-as-lambdas? #f (cond [(syntax? procedure-name-info) procedure-name-info] [(pair? procedure-name-info) (car procedure-name-info)] [else #f]))] [closure-storing-proc (lambda (clo debug-info maybe-index) (annotated-proc clo (make-closure-record closure-name debug-info #f maybe-index)))] [captured (cond [(pair? procedure-name-info) #`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info #,(cadr procedure-name-info))] [else #`(#%plain-app #,closure-storing-proc #,annotated-lambda #,closure-info #f)])] ;; gnarr! I can't find a test case ;; that depends on the attachment of the inferred name... [inferred-name-struct (if closure-name (syntax-property captured 'inferred-name (syntax-e closure-name)) captured)]) (normal-bundle free-varrefs inferred-name-struct))) ; @@ ; @ @ ; @ -@@$ @@@@@ ; @ $ -$ @ ; @ @@@@@ @ ; @ $ @ ; @ +: @: :$ ; @@@@@ $@@+ :@@$- ; The let transformation is complicated. ; here's a sample transformation (not including 'break's): ;(let-values ([(a b c) e1] [(d e) e2]) e3) ; ;turns into ; ;(let ([counter ()]) ;(let-values ([(a b c d e lifter-a-1 lifter-b-2 lifter-c-3 lifter-d-4 lifter-e-5 let-counter) ; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated* ; counter counter counter counter counter 0)]) ; (with-continuation-mark ; key huge-value ; (begin ; (set!-values (a b c) e1) ; (set! let-counter 1) ; (set!-values (d e) e2) ; (set! let-counter 2) ; e3)))) ; ; note that this elaboration looks exactly like the one for letrec, and that's ; okay, because expand guarantees that reordering them will not cause capture. ; this is because a bound variable answers is considered bound by a binding only when ; the pair answers true to bound-identifier=?, which is determined during (the first) ; expand. ; another irritating point: the mark and the break that must go immediately ; around the body. Irritating because they will be instantly replaced by ; the mark and the break produced by the annotated body itself. However, ; they're necessary, because the body may not contain free references to ; all of the variables defined in the let, and thus their values are not ; known otherwise. ; whoops! hold the phone. I think I can get away with a break before, and ; a mark after, so only one of each. groovy, eh? ; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of ; continuations; backing up a computation using a set! will not revert the ; counter, and the stepper may think that the computation is in a different ; place. To fix this, we must go to a pure let* with nested marks at each right-hand-side. ; 2006-01: oh dear heaven. Begin expands into a let-values. This means that the ; let-values really has most of the complexity of the whole stepper, all in one ; place. Re-formulating the bodies as a begin and re-calling annotate/inner broke ; implied invariants (in particular, that annotate/inner was only called on subexprs) ; and confused the heck out of me for some time today. Bleah. I'm just going to ; do the whole expansion here. Also, I'm going to make this expansion call/cc-clean, ; because I think it'll actually be easier to state & read this way. ; 2006-11: appears to work now. I'm about to try to transfer this new idiom to begin0; ; wish me luck. (define (let-abstraction stx output-identifier make-init-list) (with-syntax ([(_ ([(var ...) val] ...) . bodies) stx]) (match-let* ([binding-sets (map syntax->list (syntax->list #'((var ...) ...)))] [binding-list (apply append binding-sets)] [vals (syntax->list #'(val ...))] [lifted-var-sets (map (lx (map get-lifted-var _)) binding-sets)] [lifted-vars (apply append lifted-var-sets)] [(vector annotated-vals free-varref-sets-vals) (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)] [bodies-list (syntax->list #'bodies)] [(vector annotated-body free-varrefs-body) (if (= (length bodies-list) 1) (let-body-recur/single (car bodies-list) binding-list) ;; oh dear lord, we have to unfold these like an application: (let unroll-loop ([bodies-list bodies-list] [outermost? #t]) (cond [(null? bodies-list) (error 'annotate "no bodies in let")] [(null? (cdr bodies-list)) (tail-recur (car bodies-list))] [else (match-let* ([(vector rest free-vars-rest) (unroll-loop (cdr bodies-list) #f)] [(vector this-one free-vars-this) (non-tail-recur (car bodies-list))] [free-vars-all (varref-set-union (list free-vars-rest free-vars-this))] [debug-info (make-debug-info-fake-exp #`(begin #,@bodies-list) free-vars-all)] [begin-form #`(begin #,(normal-break/values-wrap this-one) #,rest)]) (vector (if outermost? (wcm-wrap debug-info begin-form) (wcm-pre-break-wrap debug-info begin-form)) free-vars-all))])))]) ((vector (quasisyntax/loc exp (let ([#,counter-id (#,binding-indexer)]) (#,output-identifier #,outer-initialization #,wrapped-begin))) free-varrefs) . where . ([free-varrefs (varref-set-remove-bindings (varref-set-union (cons free-varrefs-body free-varref-sets-vals)) binding-list)] [counter-id #`lifting-counter] [unevaluated-list (make-init-list binding-list)] [outer-initialization #`([(#,@lifted-vars #,@binding-list #,let-counter) (values #,@(append (map (lambda (dc_binding) counter-id) binding-list) unevaluated-list (list 0)))])] [counter-clauses (build-list (length binding-sets) (lambda (num) #`(set! #,let-counter #,(+ num 1))))] [set!-clauses (map (lambda (binding-set val) #`(set!-values #,binding-set #,val)) binding-sets annotated-vals)] [exp-finished-clauses (with-syntax ([(_ let-clauses . dc) stx] [((lifted-var ...) ...) lifted-var-sets]) (with-syntax ([(exp-thunk ...) (map (lx (lambda () _)) (syntax->list #`let-clauses))]) #`(#%plain-app list (#%plain-app list exp-thunk (#%plain-app list lifted-var ...) (#%plain-lambda () (#%plain-app list var ...))) ...)))] ; time to work from the inside out again ; without renaming, this would all be much much simpler. [wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs binding-list let-counter) (double-break-wrap #`(begin #,@(apply append (zip set!-clauses counter-clauses)) (#%plain-app #,exp-finished-break #,exp-finished-clauses) #,annotated-body)))]))))) ; @ :@@$ ; @: ; -@@ @@@@@ ; @ @ ; @ @ ; @ @ ; @ @ ; @@@@@ @@@@@ ; if-abstraction: (-> syntax? syntax? (or/c false/c syntax?) (values syntax? varref-set?)) (define (if-abstraction test then else) (match-let* ([(vector annotated-test free-varrefs-test) (non-tail-recur test)] [test-with-break (normal-break/values-wrap annotated-test)] [(vector annotated-then free-varrefs-then) (tail-recur then)] [(vector annotated-else free-varrefs-else) (if else (tail-recur else) (vector #f null))] [free-varrefs (varref-set-union (list free-varrefs-test free-varrefs-then free-varrefs-else))] [annotated-if (if else (quasisyntax/loc exp (if #,test-with-break #,annotated-then #,annotated-else)) (quasisyntax/loc exp (if #,test-with-break #,annotated-then)))]) (vector (outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-if) free-varrefs))) ; ; ; ;;; ; ; ; ; ; ; ; ;;;; ; ;;; ; ;;; ;;; ;;;;;; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;;;; ; ; ; ; (define (varref-abstraction var) (match-let* ([free-varrefs (list var)] [varref-break-wrap (lambda () (wcm-break-wrap (make-debug-info-normal free-varrefs) (return-value-wrap var)))] [varref-no-break-wrap (lambda () (outer-wcm-wrap (make-debug-info-normal free-varrefs) var))] ;; JBC: shouldn't this be the namespace of the user's code... ? [base-namespace-symbols (namespace-mapped-symbols (make-base-namespace))] [module-bound-varref-break-wrap (lambda () (varref-break-wrap) #;(if (or (memq (syntax-e var) beginner-defined:must-reduce) (and (stepper-syntax-property var 'lazy-op) (not (memq (syntax->datum var) base-namespace-symbols)))) (varref-break-wrap) (varref-no-break-wrap)))]) (vector (match (stepper-syntax-property var 'stepper-binding-type) [(or 'lambda-bound 'macro-bound) (varref-no-break-wrap)] ['let-bound (varref-break-wrap)] ['non-lexical ;; is it from this module or not? (match (identifier-binding var) ;; this can only come up when stepping through non-module code... ;; perhaps we should just signal an error here. (#f (varref-break-wrap)) ['lexical ;; my reading of the docs suggest that this should not occur in v4... (error 'varref-abstraction "identifier-binding should not be 'lexical")] [(list-rest (? module-path-index? path-index) dontcare) (let-values ([(module-path dc5) (module-path-index-split path-index)]) (if module-path ;; not a module-local variable: (module-bound-varref-break-wrap) ;; a module-local-variable: (varref-break-wrap)))] [other (error 'annotate "unexpected value for identifier-binding: ~v" other)])] [other (error 'annotate "unexpected value for stepper-binding-type on variable ~e: ~e" (syntax->datum var) other)]) free-varrefs))) (define (recertifier vals) (match-let* ([(vector new-exp bindings) vals]) (vector new-exp (map (lambda (b) b) bindings)))) ;; this is a terrible hack... until some other language form needs it. ;; It wraps the given annotated expression with a break that adds the ;; result to the list of completed expressions (define maybe-final-val-wrap (match-lambda [(vector annotated free-vars) (vector (if (stepper-syntax-property exp 'stepper-use-val-as-final) #`(#%plain-app call-with-values (#%plain-lambda () #,annotated) (#%plain-lambda results (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () results)))) (#%plain-app values results))) annotated) free-vars)] [error 'maybe-final-val-wrap "stepper internal error 20080527"])) (cond [(stepper-syntax-property exp 'stepper-skipto) (dont-annotate 'rebuild)] [(stepper-syntax-property exp 'stepper-skipto/discard) (dont-annotate 'discard)] [(to-be-skipped? exp) (vector (wcm-wrap 13 exp) null)] [else (let ([exp (syntax-disarm exp saved-code-inspector)]) (recertifier (maybe-final-val-wrap (kernel:kernel-syntax-case exp #f [(#%plain-lambda . clause) (match-let* ([(vector annotated-clause free-varrefs) (lambda-clause-abstraction (syntax clause))] [annotated-lambda (with-syntax ([annotated-clause annotated-clause]) (syntax/loc exp (#%plain-lambda . annotated-clause)))]) (outer-lambda-abstraction annotated-lambda free-varrefs))] [(case-lambda . clauses) (match-let* ([(vector annotated-cases free-varrefs-cases) (2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))] [annotated-case-lambda (with-syntax ([annotated-cases annotated-cases]) (syntax/loc exp (case-lambda . annotated-cases)))] [free-varrefs (varref-set-union free-varrefs-cases)]) (outer-lambda-abstraction annotated-case-lambda free-varrefs))] [(if test then else) (if-abstraction (syntax test) (syntax then) (syntax else))] ; ; ; ; ; ; ; ; ; ; ; ;; ;;; ;;;; ;;; ; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;;;; ;;;; ;; ; ;;; ; ; ; ; ; ;;;; ; [(begin . bodies-stx) (begin (error 'annotate-inner "nothing expands into begin! : ~v" (syntax->datum exp)) #;(begin-abstraction (syntax->list #`bodies-stx)))] ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ;;; ;;;; ;;; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ;;;; ;;;; ;; ; ;;; ; ; ;; ; ; ; ;;;; ; ;; one-element begin0 is a special case, because in this case only ;; the body of the begin0 is in tail position. [(begin0 body) (match-let* ([(vector annotated-body free-vars-body) (tail-recur #'body)]) (vector (wcm-break-wrap (make-debug-info-normal free-vars-body) (quasisyntax/loc exp (begin0 #,annotated-body))) free-vars-body))] [(begin0 first-body . bodies-stx) (match-let* ([(vector annotated-first free-vars-first) (result-recur #'first-body)] [(vector annotated-rest free-vars-rest) (2vals-map non-tail-recur (syntax->list #`bodies-stx))] [wrapped-rest (map normal-break/values-wrap annotated-rest)] [all-free-vars (varref-set-union (cons free-vars-first free-vars-rest))] [early-debug-info (make-debug-info-normal all-free-vars)] [tagged-temp (stepper-syntax-property begin0-temp 'stepper-binding-type 'stepper-temp)] [debug-info-maker (lambda (rest-exps) (make-debug-info-fake-exp/tail-bound #`(begin0 #,@rest-exps) (binding-set-union (list (list tagged-temp) tail-bound)) (varref-set-union (list (list tagged-temp) all-free-vars))))] [rolled-into-fakes (let loop ([remaining-wrapped wrapped-rest] [remaining-src (syntax->list #`bodies-stx)] [first-time? #t]) ((if first-time? wcm-wrap wcm-pre-break-wrap) (debug-info-maker remaining-src) (cond [(null? remaining-src) begin0-temp] [else #`(begin #,(car remaining-wrapped) #,(loop (cdr remaining-wrapped) (cdr remaining-src) #f))])))]) (vector (wcm-wrap early-debug-info #`(let ([#,begin0-temp #,annotated-first]) #,rolled-into-fakes)) all-free-vars))] [(let-values . _) (let-abstraction exp #`let-values (lambda (bindings) (map (lambda (_) *unevaluated*) bindings)))] [(letrec-values . _) (let-abstraction exp #`letrec-values (lambda (bindings) (map (lambda (b) #`#,b) bindings)))] ; $ ; @ @ ; :@@+@ -@@$ @@@@@ @ ; @$ -@ $ -$ @ @ ; :@@$- @@@@@ @ @ ; *@ $ @ ; @ :@ +: @: :$ ; $+@@: $@@+ :@@$- $ [(set! var val) (match-let* ([(vector annotated-val val-free-varrefs) (set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top) [(#%top . real-var) (syntax-e (syntax real-var))] [else (syntax var)]))] [free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))] [annotated-set! (return-value-wrap (quasisyntax/loc exp (set! var #,(normal-break/values-wrap annotated-val))))]) (vector (outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-set!) free-varrefs))] ; @ ; $@-@@@@ @@ $@$ @@@@@ -@@$ ; $- :@ @ @ $- -$ @ $ -$ ; @ @ @ @ @ @ @ @@@@@ ; @ @ @ @ @ @ @ $ ; $- :@ @: +@ $- -$ @: :$ +: ; $@-@ :@$-@@ $@$ :@@$- $@@+ ; @ ; @@@ [(quote _) (normal-bundle null exp)] [(quote-syntax _) (normal-bundle null exp)] ; @@@ @@@ $@+@ @@+-$: ; @ @ $+ -@ @+@$@ ; $-@ @ @@@@@ @ @@@@@ @ @ @ ; ++@+$ @ @ @ @ ; :@@$+ $* -$ @ @ @ ; -@$@* $@$- @@@@@@@ [(with-continuation-mark key mark body) ;(match-let* ([(annotated-key free-varrefs-key) ; (non-tail-recur (syntax key))] ; [(annotated-mark free-varrefs-mark) ; (non-tail-recur (syntax mark))] ; [(annotated-body dc_free-varrefs-body) ; (result-recur (syntax body))]) (error 'annotate/inner "this region of code is still under construction") ; [annotated #`(let-values ([key-temp #,*unevaluated*] ; [mark-temp #,*unevaluated*] ;) ] ; @@ @ @ ; @ @ ; $@$: @@:@$- @@:@$- @ -@@ $@+@ $@$: @@@@@ -@@ $@$ @@:@@: ; -@ @: -$ @: -$ @ @ $+ -@ -@ @ @ $- -$ @+ :@ ; -$@$@ @ @ @ @ @ @ @ -$@$@ @ @ @ @ @ @ ; $* @ @ @ @ @ @ @ @ $* @ @ @ @ @ @ @ ; @- *@ @: -$ @: -$ @ @ $* -$ @- *@ @: :$ @ $- -$ @ @ ; -$$-@@ @-@$ @-@$ @@@@@ @@@@@ $@$- -$$-@@ :@@$- @@@@@ $@$ @@@ @@@ ; @ @ ; @@@ @@@ ; [foot-wrap? ; (wcm-wrap debug-info annotated)]) ; free-bindings))] ; the app form's elaboration looks like this, where M0 etc. stand for expressions, and t0 etc ; are temp identifiers that do not occur in the program: ; (M0 ...) ; ; goes to ; ;(let ([t0 *unevaluated*] ; ...) ; (with-continuation-mark ; debug-key ; huge-value ; (set! t0 M0) ; ... ; (with-continuation-mark ; debug-key ; much-smaller-value ; (t0 ...)))) ; ; 'break's are not illustrated. An optimization is possible when all expressions M0 ... are ; varrefs. In particular (where v0 ... are varrefs): ; (v0 ...) ; ; goes to ; ; (with-continuation-mark ; debug-key ; debug-value ; (v0 ...)) ; ; in other words, no real elaboration occurs. Note that this doesn't work as-is for the ; stepper, because there's nowhere to hang the breakpoint; you want to see the break ; occur after all vars have been evaluated. I suppose you could do (wcm ... (begin v0 ... (v0 ...))) ; where the second set are not annotated ... but stepper runtime is not at a premium. ;; the call/cc-safe version of this appears to work, and it lives in the definition of let. I should ;; transfer that knowledge to here. -- JBC, 2006-10-11 [(#%plain-app . terms) (match-let* ([(vector annotated-terms free-varrefs-terms) (2vals-map non-tail-recur (syntax->list (syntax terms)))] [free-varrefs (varref-set-union free-varrefs-terms)]) (vector (let* ([arg-temps (build-list (length annotated-terms) get-arg-var)] [tagged-arg-temps (map (lambda (var) (stepper-syntax-property var 'stepper-binding-type 'stepper-temp)) arg-temps)] [let-clauses #`((#,tagged-arg-temps (#%plain-app values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))] [set!-list (map (lambda (arg-symbol annotated-sub-exp) #`(set! #,arg-symbol #,annotated-sub-exp)) tagged-arg-temps annotated-terms)] [new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))] [app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)] [app-term (quasisyntax/loc exp (#%plain-app #,@tagged-arg-temps))] [debug-info (make-debug-info-app new-tail-bound (varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars 'not-yet-called)] [let-body (outer-wcm-wrap debug-info #`(begin #,@set!-list #,(break-wrap (wcm-wrap app-debug-info #`(if (#%plain-app #,annotated-proc? #,(car tagged-arg-temps)) #,app-term #,(return-value-wrap app-term))))))]) #`(let-values #,let-clauses #,let-body)) ;) free-varrefs))] ; @@ ; @ @ ; $@:@ $@$: @@@@@ @@ @@ @@+-$: ; $* *@ -@ @ @ @ @+@$@ ; @ @ -$@$@ @ @ @ @ @ @ ; @ @ $* @ @ @ @ @ @ @ ; $* *@ @- *@ @: :$ @: +@ @ @ @ ; $@:@@ -$$-@@ :@@$- :@$-@@@@@@@@@ [(#%top . var-stx) (varref-abstraction #`var-stx)] [var-stx (identifier? #`var-stx) (varref-abstraction #`var-stx)] [else (error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))]))))]))) ;; annotate/top-level : syntax-> syntax ;; expansion of teaching level language programs produces two kinds of ;; expressions: modules containing all of the code in the def'ns window, and ;; require statements that invoke those modules. In the first case, we must annotate ;; the expressions inside the top-level module, and in the second, we should just ;; leave it alone. (define/contract annotate/top-level (syntax? . -> . syntax?) (lambda (exp) (syntax-case exp (module #%plain-module-begin let-values dynamic-wind #%plain-lambda #%plain-app define-values) [(module name lang (#%plain-module-begin . bodies)) #`(module name lang (#%plain-module-begin #,@(map annotate/module-top-level (syntax->list #`bodies))))] ; the 'require' form is used for the test harness [(require module-name) exp] ; the 'dynamic-require' form is used by the actual expander [(let-values ([(done-already?) . rest1]) (#%plain-app dynamic-wind void (#%plain-lambda () . rest2) (#%plain-lambda () . rest3))) exp] ; STC: for lazy, handle defines [(define-values (ids ...) bodies) (annotate/module-top-level exp)] [else (annotate/module-top-level exp)] #;[else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax->datum exp)) #;(annotate/module-top-level exp)]))) #;(define/contract annotate/top-level/acl2 (syntax? . -> . syntax?) (lambda (exp) (syntax-case exp (begin define-values #%plain-app) [(begin contract-thingy (begin body (begin))) #`(begin contract-thingy (begin #,(annotate/module-top-level #`body) (begin)))] #;(define-values (lifted) (begin (#%app contract/proc provide/contract-contract-id-zp zp provide/contract-pos-module-source-zp (#%app module-source-as-symbol (quote-syntax here)) (quote-syntax zp)))) #;(if (#%app null? (#%app lifted (#%datum . 3))) 'y 'x) [else (annotate/module-top-level exp)] #;[else (begin (eprintf "~v\n" (syntax->datum exp)) (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax->datum exp)))]))) ;; annotate expressions at the top level within a module. (define (annotate/module-top-level exp) (cond [(stepper-syntax-property exp 'stepper-replace)] [(to-be-skipped? exp) exp] ;; for kathy's test engine: [(syntax-property exp 'test-call) exp] [(stepper-syntax-property exp 'stepper-black-box-expr) #`(begin #,exp (#%plain-app #,(make-opaque-exp-break exp)))] [(stepper-syntax-property exp 'stepper-skipto) (skipto/auto exp 'rebuild annotate/module-top-level)] [else (syntax-case exp (#%app #%plain-app call-with-values define-values define-syntaxes #%require #%provide begin #%plain-lambda lambda) [(define-values (new-var ...) e) (let* ([name-list (syntax->list #`(new-var ...))] [defined-name (if (and (pair? name-list) (null? (cdr name-list))) (car name-list) #f)]) (stepper-recertify #`(begin (define-values (new-var ...) #,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name)) ;; this next expression should deliver the newly computed values to an ;; exp-finished-break (#%plain-app #,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () (#%plain-app list new-var ...)))))) #'e))] [(define-syntaxes (new-vars ...) e) exp] [(#%require specs ...) ;; this should only include requires inserted automatically, as others should ;; get caught above in the "stepper-black-box-expr" check: exp] [(#%provide specs ...) exp] [(begin . bodies) #`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))] ; STC: for lazy racket, need this case to catch and hide toplevel-forcer ; stepper tests will expand to this case, with call-with-values [(#%plain-app call-with-values (#%plain-lambda () (#%plain-app (#%plain-app toplevel-forcer) operand)) print-values) (stepper-recertify #`(#%plain-app call-with-values (#%plain-lambda () (#%plain-app (#%plain-app toplevel-forcer) #,(top-level-annotate/inner (top-level-rewrite #'operand) exp #f))) (#%plain-lambda vals (begin (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () vals)))) (#%plain-app call-with-values (#%plain-lambda () vals) values)))) exp)] [(#%plain-app call-with-values (#%plain-lambda () body) print-values) ;; re-extract the plain-lambda term, to use in recertification: (let ([lam-for-cert (syntax-case exp (#%plain-app call-with-values) [(#%plain-app call-with-values lam print-values) #'lam] [other (error 'annotate/module-top-level "unreachable 2010-01-23 22:14")])]) ;; this recertify looks to be superfluous now that it has the "transparent" certificate-mode tag, ;; but it can't hurt, and I'd rather just leave it in here. (stepper-recertify #`(#%plain-app call-with-values #,(stepper-recertify #`(#%plain-lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f)) lam-for-cert) (#%plain-lambda vals (begin (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () vals)))) (#%plain-app call-with-values (#%plain-lambda () vals) print-values)))) exp))] ; STC: for lazy racket, need this case to catch and hide toplevel-forcer ; This is similar to app case above, but with toplevel-forcer ; normal lazy stepper operation expands to this case [(#%plain-app (#%plain-app toplevel-forcer) operand) (stepper-recertify #`(#%plain-app call-with-values (#%plain-lambda () (#%plain-app (#%plain-app toplevel-forcer) #,(top-level-annotate/inner (top-level-rewrite #'operand) exp #f))) (#%plain-lambda vals (begin (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () vals)))) (#%plain-app call-with-values (#%plain-lambda () vals) values)))) exp)] [any (stepper-syntax-property exp 'stepper-test-suite-hint) (top-level-annotate/inner (top-level-rewrite exp) exp #f)] [else (top-level-annotate/inner (top-level-rewrite exp) exp #f) ;; the following check can't be permitted in the presence of things like test-suite cases ;; which produce arbitrary expressions at the top level. #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])])) ; body of local (annotate/top-level main-exp)) ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ;;; ; ;;; ; ;;; ; ; ;;; ; ; ;; ;;; ; ; ; ; ;; ; ;;;; ;;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ;;;;; ; ; ;;;;; ; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;;; ; ;;; ; ;;;; ; ;;;; ; ; ;;;; ; ; ; ; ;; ;;;; ; ; ; ; ; ; top-level-rewrite : (SYNTAX-OBJECT -> SYNTAX-OBJECT) ; top-level-rewrite performs several tasks; it labels variables with their types ; (let-bound, lambda-bound, or non-lexical), it flags if's which could come from ; cond's, it labels the begins in conds with 'stepper-skip annotations ; label-var-types returns a syntax object which is identical to the ; original except that the variable references are labeled with the ; stepper-syntax-property 'stepper-binding-type, which is set to either ; let-bound, lambda-bound, or non-lexical. (It can also be 'macro-bound, set ; earlier during macro expansion.) (define (top-level-rewrite stx) (let loop ([stx stx] [let-bound-bindings null] [cond-test (lx #f)]) (define (recur-regular stx) (loop stx let-bound-bindings (lx #f))) (define (recur-with-bindings exp vars) (loop exp (append vars let-bound-bindings) (lx #f))) (define (recur-in-cond stx new-cond-test) (loop stx let-bound-bindings new-cond-test)) (define (do-let/rec stx rec?) (with-syntax ([(label ((vars rhs) ...) . bodies) stx]) (let* ([vars-list (apply append (map syntax->list (syntax->list (syntax (vars ...)))))] [labelled-vars-list (map (lambda (var-list) (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list var-list))) (syntax->list (syntax (vars ...))))] [rhs-list (if rec? (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'(rhs ...))) (map recur-regular (syntax->list #'(rhs ...))))] [new-bodies (map (lambda (exp) (recur-with-bindings exp vars-list)) (syntax->list #'bodies))] [new-bindings (map list labelled-vars-list rhs-list)]) (datum->syntax stx `(,#'label ,new-bindings ,@new-bodies) stx stx)))) ; evaluated at runtime, using 3D code: (define (put-into-xml-table val) (hash-set! finished-xml-box-table val #t) val) (cond [(or (to-be-skipped? stx) (stepper-syntax-property stx 'stepper-black-box-expr)) stx] [else (define rewritten (let ([stx (syntax-disarm stx saved-code-inspector)]) (kernel:kernel-syntax-case stx #f ; cond : [(if test (let-values () then) else-stx) (let ([origin (syntax-property stx 'origin)] [rebuild-if (lambda (new-cond-test) (let* ([new-then (recur-regular (syntax then))] [rebuilt (stepper-syntax-property (rebuild-stx `(if ,(recur-regular (syntax test)) ,new-then ,(recur-in-cond (syntax else-stx) new-cond-test)) stx) 'stepper-hint 'comes-from-cond)]) ; move the stepper-else mark to the if, if it's present: (if (stepper-syntax-property (syntax test) 'stepper-else) (stepper-syntax-property rebuilt 'stepper-else #t) rebuilt)))]) (cond [(cond-test stx) ; continuing an existing 'cond' (rebuild-if cond-test)] [(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond' (rebuild-if (lambda (test-stx) (and (eq? (syntax-source stx) (syntax-source test-stx)) (eq? (syntax-position stx) (syntax-position test-stx)))))] [else ; not from a 'cond' at all. (rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))] [(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL (cond-test stx) (stepper-syntax-property stx 'stepper-skip-completely #t)] ; wrapper on a local. This is necessary because ; teach.rkt expands local into a trivial let wrapping a bunch of ; internal defines, and therefore the letrec-values on ; which I want to hang the 'stepper-hint doesn't yet ; exist. So we patch it up after expansion. And we ; discard the outer 'let' at the same time. [(let-values () expansion-of-local) (eq? (stepper-syntax-property stx 'stepper-hint) 'comes-from-local) (syntax-case #`expansion-of-local (letrec-values) [(letrec-values (bogus-clause clause ...) . bodies) (recur-regular (stepper-syntax-property #`(letrec-values (clause ...) . bodies) 'stepper-hint 'comes-from-local))] [else (error 'top-level-rewrite "expected a letrec-values inside a local, given: ~e" (syntax->datum #`expansion-of-local))])] ; let/letrec : [(let-values x ...) (do-let/rec stx #f)] [(letrec-values x ...) (do-let/rec stx #t)] ; varref : [var (identifier? (syntax var)) (stepper-syntax-property (syntax var) 'stepper-binding-type (if (eq? (identifier-binding (syntax var)) 'lexical) (cond [(ormap (lx (bound-identifier=? _ (syntax var))) let-bound-bindings) 'let-bound] [else 'lambda-bound]) 'non-lexical))] [else (let ([content (syntax-e stx)]) (if (pair? content) (rebuild-stx (syntax-pair-map content recur-regular) stx) stx))]))) (if (eq? (stepper-syntax-property stx 'stepper-xml-hint) 'from-xml-box) (stepper-syntax-property #`(#%plain-app #,put-into-xml-table #,rewritten) 'stepper-skipto (list syntax-e cdr car)) (stepper-recertify rewritten stx))]))) ;; recertify the output of the stepper, to allow it to run: (define (stepper-recertify new-stx old-stx) (syntax-rearm new-stx old-stx #t)) ;; does this stx have the 'stepper-skip-completely property? (define (to-be-skipped? stx) (stepper-syntax-property stx 'stepper-skip-completely))