diff --git a/collects/stepper/private/annotate.rkt b/collects/stepper/private/annotate.rkt index 42521cf12b..bb8b8bd1a1 100644 --- a/collects/stepper/private/annotate.rkt +++ b/collects/stepper/private/annotate.rkt @@ -102,134 +102,147 @@ ; (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. +; 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. (define (top-level-rewrite stx) (let loop ([stx stx] [let-bound-bindings null] [cond-test (lx #f)]) - (if (or (stepper-syntax-property stx 'stepper-skip-completely) - (stepper-syntax-property stx 'stepper-define-struct-hint)) - stx - (let* ([recur-regular - (lambda (stx) - (loop stx let-bound-bindings (lx #f)))] - [recur-with-bindings - (lambda (exp vars) - (loop exp (append vars let-bound-bindings) (lx #f)))] - [recur-in-cond - (lambda (stx new-cond-test) - (loop stx let-bound-bindings new-cond-test))] - [do-let/rec - (lambda (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: - [put-into-xml-table (lambda (val) - (hash-set! finished-xml-box-table val #t) - val)] - - - [rewritten - (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.ss 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))])]) + (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 (stepper-syntax-property stx 'stepper-skip-completely) + (stepper-syntax-property stx 'stepper-define-struct-hint)) + stx] + [else + (define rewritten + (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)] - (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)))))) + ; wrapper on a local. This is necessary because + ; teach.ss 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))]))) ; @@ -345,14 +358,15 @@ "no getter for a define-struct"))))))) (define (top-level-annotate/inner exp source-exp defined-name) - (let*-2vals ([(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)))))) + (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 @@ -391,757 +405,766 @@ . -> . (vector/p syntax? binding-set?)) (lambda (exp tail-bound pre-break? procedure-name-info) - (cond [(cond - ((stepper-syntax-property exp 'stepper-skipto) 'rebuild) - ((stepper-syntax-property exp 'stepper-skipto/discard) 'discard) - (else #f)) - => (lambda (traversal) - (let* ([free-vars-captured #f] ; this will be set!'ed - ;;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))] - ;; WARNING! I depend on the order of evaluation in application arguments here: - [annotated (skipto/auto - exp - traversal - (lambda (subterm) - (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) - (set! free-vars-captured free-vars) - stx)))]) - (2vals (wcm-wrap - skipto-mark - annotated) - free-vars-captured)))] + ;; 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 (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, becuase 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))] + [top-level-varref-break-wrap + (lambda () + (if (memq (syntax-e var) beginner-defined:must-reduce) + (varref-break-wrap) + (varref-no-break-wrap)))]) + (vector + (case (stepper-syntax-property var 'stepper-binding-type) + ((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) + (#f (top-level-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: + (top-level-varref-break-wrap) + ;; a module-local-variable: + (varref-break-wrap)))] + [other (error + 'annotate + "unexpected value for identifier-binding: ~v" other)]))) + free-varrefs))) + + (define (recertifier vals) + (match-let* ([(vector new-exp bindings) vals]) + (vector (stepper-recertify new-exp exp) + (map (lambda (b) + (stepper-recertify b exp)) + 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)] [(stepper-syntax-property exp 'stepper-skip-completely) - (2vals (wcm-wrap 13 exp) null)] + (vector (wcm-wrap 13 exp) null)] [else - (let* - ;; recurrence procedures, used to recur on sub-expressions: - ([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))] - [non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))] - [result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))] - [set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))] - [let-rhs-recur (lambda (exp binding-names dyn-index-syms) - (let* ([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)))] - [lambda-body-recur (lambda (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: - [let-body-recur/single - (lambda (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: - - [make-debug-info-normal (lambda (free-bindings) - (make-debug-info exp tail-bound free-bindings 'none #t))] - [make-debug-info-app (lambda (tail-bound free-bindings label) - (make-debug-info exp tail-bound free-bindings label #t))] - [make-debug-info-let (lambda (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))] - [make-debug-info-fake-exp (lambda (exp free-bindings) - (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) - tail-bound free-bindings 'none #t))] - [make-debug-info-fake-exp/tail-bound (lambda (exp tail-bound free-bindings) - (make-debug-info (stepper-syntax-property exp 'stepper-fake-exp #t) - tail-bound free-bindings 'none #t))] - - [outer-wcm-wrap (if pre-break? - wcm-pre-break-wrap - wcm-wrap)] - [wcm-break-wrap (lambda (debug-info exp) - (outer-wcm-wrap debug-info (break-wrap exp)))] - - ;; used for things that are values: - [normal-bundle - (lambda (free-vars annotated) - (2vals (outer-wcm-wrap (make-debug-info-normal free-vars) - annotated) - free-vars))] - - - ; @@ @@ @@ - ; @ @ @ - ; @ $@$: @@+-$: @-@$ $@:@ $@$: - ; @ -@ @+@$@ @+ *$ $* *@ -@ - ; @ -$@$@ @ @ @ @ @ @ @ -$@$@ - ; @ $* @ @ @ @ @ @ @ @ $* @ - ; @ @- *@ @ @ @ @ +$ $* *@ @- *@ - ; @@@@@ -$$-@@@@@@@@@@@+@$ $@:@@ -$$-@@ - ; - - [lambda-clause-abstraction - (lambda (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 (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))))] - - [outer-lambda-abstraction - (lambda (annotated-lambda free-varrefs) - (let*-2vals - ([closure-info (make-debug-info-app 'all free-varrefs 'none)] - ;; if we manually disable the storage of names, lambdas get rendered as lambdas. - [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]))] - - #;[make-ap-struct - (lambda (clo debug-info maybe-index) - (annotated-proc - clo - (make-closure-record - closure-name - debug-info - #f - maybe-index)))] - - - - [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, becuase 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. - - - [let-abstraction - (lambda (stx output-identifier make-init-list) - (with-syntax ([(_ ([(var ...) val] ...) . bodies) stx]) - (let*-2vals - ([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)] - [(annotated-vals free-varref-sets-vals) - (2vals-map let-rhs-recur vals binding-sets lifted-var-sets)] - [bodies-list (syntax->list #'bodies)] - [(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 - (let*-2vals - ([(rest free-vars-rest) (unroll-loop (cdr bodies-list) #f)] - [(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)]) - (2vals (if outermost? - (wcm-wrap debug-info begin-form) - (wcm-pre-break-wrap debug-info begin-form)) - free-vars-all))])))]) - - ((2vals (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?)) - [if-abstraction - (lambda (test then else) - (let*-2vals - ([(annotated-test free-varrefs-test) - (non-tail-recur test)] - [test-with-break - (normal-break/values-wrap annotated-test)] - [(annotated-then free-varrefs-then) - (tail-recur then)] - [(annotated-else free-varrefs-else) - (if else - (tail-recur else) - (2vals #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)))]) - (2vals - (outer-wcm-wrap (make-debug-info-normal free-varrefs) annotated-if) - free-varrefs)))] - - - - ; - ; - ; ;;; - ; ; - ; ; - ; ; ; ;;;; ; ;;; ; ;;; ;;; ;;;;;; - ; ; ; ; ; ;; ; ;; ; ; ; ; - ; ; ; ; ; ; ; ;;;;; ; - ; ; ; ; ; ; ; ; ; - ; ; ; ; ;; ; ; ; ; - ; ; ;; ; ; ; ;;;; ; - ; - ; - ; - - - [varref-abstraction - (lambda (var) - (let*-2vals ([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))] - [top-level-varref-break-wrap - (lambda () - (if (memq (syntax-e var) beginner-defined:must-reduce) - (varref-break-wrap) - (varref-no-break-wrap)))]) - (2vals - (case (stepper-syntax-property var 'stepper-binding-type) - ((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) - (#f (top-level-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: - (top-level-varref-break-wrap) - ;; a module-local-variable: - (varref-break-wrap)))] - [other (error 'annotate "unexpected value for identifier-binding: ~v" other)]))) - free-varrefs)))] - - [recertifier - (lambda (vals) - (let*-2vals ([(new-exp bindings) vals]) - (2vals (stepper-recertify new-exp exp) - (map (lambda (b) - (stepper-recertify b exp)) - 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 - [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"])] - - ) - ; find the source expression and associate it with the parsed expression - ; (when (and red-exprs foot-wrap?) - ; (set-exp-read! exp (find-read-expr exp))) - - - (recertifier - (maybe-final-val-wrap - (kernel:kernel-syntax-case exp #f - - [(#%plain-lambda . clause) - (let*-2vals ([(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) - (let*-2vals ([(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) - (let*-2vals ([(annotated-body free-vars-body) - (tail-recur #'body)]) - (2vals (wcm-break-wrap (make-debug-info-normal free-vars-body) - (quasisyntax/loc exp (begin0 #,annotated-body))) - free-vars-body))] - - - [(begin0 first-body . bodies-stx) - (let*-2vals ([(annotated-first free-vars-first) (result-recur #'first-body)] - [(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))])))]) - (2vals (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) - (let*-2vals - ([(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))))]) - (2vals - (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) - ;(let*-2vals ([(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*] + (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)) ;) - ] - - - ; @@ @ @ - ; @ @ - ; $@$: @@:@$- @@:@$- @ -@@ $@+@ $@$: @@@@@ -@@ $@$ @@:@@: - ; -@ @: -$ @: -$ @ @ $+ -@ -@ @ @ $- -$ @+ :@ - ; -$@$@ @ @ @ @ @ @ @ -$@$@ @ @ @ @ @ @ - ; $* @ @ @ @ @ @ @ @ $* @ @ @ @ @ @ @ - ; @- *@ @: -$ @: -$ @ @ $* -$ @- *@ @: :$ @ $- -$ @ @ - ; -$$-@@ @-@$ @-@$ @@@@@ @@@@@ $@$- -$$-@@ :@@$- @@@@@ $@$ @@@ @@@ - ; @ @ - ; @@@ @@@ - - - ; [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) - (let*-2vals - ([(annotated-terms free-varrefs-terms) - (2vals-map non-tail-recur (syntax->list (syntax terms)))] - [free-varrefs (varref-set-union free-varrefs-terms)]) - (2vals - (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))]))))]))) + 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 diff --git a/collects/stepper/private/lifting.rkt b/collects/stepper/private/lifting.rkt index b120af7042..2094fdf565 100644 --- a/collects/stepper/private/lifting.rkt +++ b/collects/stepper/private/lifting.rkt @@ -1,14 +1,11 @@ -(module lifting scheme/base - (require mzlib/etc - mzlib/contract - (prefix-in kernel: syntax/kerncase) - mzlib/match - "testing-shared.ss" - "shared.ss" - "my-macros.ss" - (for-syntax scheme/base)) +#lang racket - (define-struct context-record (stx index kind)) +(require (prefix-in kernel: syntax/kerncase) + "testing-shared.ss" + "shared.ss" + (for-syntax racket/base)) + +(define-struct context-record (stx index kind)) ; context-records are used to represent syntax context frames. That is, ; a list of context records represents a path through a syntax tree @@ -24,7 +21,7 @@ (define (lift stx lift-in-highlight?) - (let*-2vals ([(context-records highlight) (find-highlight stx)]) + (match-let* ([(vector context-records highlight) (find-highlight stx)]) (lift-local-defs context-records highlight lift-in-highlight?))) ; [find-highlight (-> syntax? (listof context-record?))] @@ -34,123 +31,131 @@ (define (find-highlight stx) (let/ec success-escape - (local - ((define (make-try-all-subexprs stx kind context-so-far) - (lambda (index-mangler list-of-subtries) - (let loop ([index 0] [remaining list-of-subtries]) - (unless (null? remaining) - (let* ([try (car remaining)] - [corrected-index (index-mangler index)]) - ((car try) (cadr try) (cons (make-context-record stx corrected-index kind) context-so-far)) - (loop (+ index 1) (cdr remaining))))))) - - (define try->offset-try - (lambda (try) - (lambda (offset subtries) - (try (lambda (index) (list (+ offset index))) subtries)))) - - ;; WHOA: this code uses the template for fully-expanded syntax; what the code - ;; actually gets is reconstructed code. This is a problem, because you can't - ;; distinguish a top-level begin from one that's the result of some evaluation. - ;; I think for the moment that it will solve our problem simply to remove the - ;; special case for begin at the top level. JBC, 2006-10-09 - - ;; ... aaaand, yep, there's a bug. The input is not fully-expanded syntax, and - ;; therefore _can_ include a two-branched 'if' (because the reconstructor produces it.) - ;; - - (define (top-level-expr-iterator stx context-so-far) - (let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))]) - (kernel:kernel-syntax-case stx #f - [(module identifier name (#%plain-module-begin . module-level-exprs)) - (try 3 (map (lambda (expr) `(,module-level-expr-iterator ,expr)) - (syntax->list #'module-level-exprs)))] - [else-stx - (general-top-level-expr-iterator stx context-so-far)]))) - - (define (module-level-expr-iterator stx context-so-far) - (kernel:kernel-syntax-case stx #f - [(#%provide . provide-specs) - (void)] - [else-stx - (general-top-level-expr-iterator stx context-so-far)])) - - (define (general-top-level-expr-iterator stx context-so-far) - (let ([try (try->offset-try (make-try-all-subexprs stx 'general-top-level context-so-far))]) - (kernel:kernel-syntax-case stx #f - [(define-values (var ...) expr) - (try 2 `((,expr-iterator ,#'expr)))] - [(define-syntaxes (var ...) expr) - (try 2 `((,expr-iterator ,#'expr)))] - ;; this code is buggy, but I believe it doesn't belong here at all - ;; per above discussion. JBC, 2006-10-09 - #;[(begin . top-level-exprs) - (try 1 (map (lambda (expr) `(,top-level-expr-iterator ,expr)) - (syntax->list #'exprs)))] - [(#%require . require-specs) - (void)] - [else - (expr-iterator stx context-so-far)]))) - - (define (expr-iterator stx context-so-far) - (when (stepper-syntax-property stx 'stepper-highlight) - (success-escape (2vals context-so-far stx))) - (let* ([try (make-try-all-subexprs stx 'expr context-so-far)] - [try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr)) - (syntax->list exprs))))] - [try-exprs-offset (try->offset-try try-exprs)] - [let-values-abstraction - (lambda (stx) - (kernel:kernel-syntax-case stx #f - [(kwd (((variable ...) rhs) ...) . bodies) - (begin - (try-exprs (lambda (index) (list 1 index 1)) #'(rhs ...)) - (try-exprs-offset 2 #'bodies))] - [else - (error 'expr-syntax-object-iterator - "unexpected let(rec) expression: ~a" - (syntax->datum stx))]))]) - (kernel:kernel-syntax-case stx #f - [var-stx - (identifier? (syntax var-stx)) - (void)] - [(#%plain-lambda vars . bodies) - (try-exprs-offset 2 #'bodies)] - [(case-lambda (vars . bodies) ...) - (let loop ([count 1] [clauses (syntax->list #'(bodies ...))]) - (unless (null? clauses) - (try-exprs (lambda (index) (list count (+ index 1))) (cdar clauses)) - (loop (+ count 1) (cdr clauses))))] - [(if test then else) - (try-exprs-offset 1 #'(test then else))] - [(if test then) - (try-exprs-offset 1 #'(test then))] - [(begin . bodies) - (try-exprs-offset 1 #'bodies)] - [(begin0 . bodies) - (try-exprs-offset 1 #'bodies)] - [(let-values . _) - (let-values-abstraction stx)] - [(letrec-values . _) - (let-values-abstraction stx)] - [(set! var val) - (try-exprs-offset 2 #'(val))] - [(quote _) - (void)] - [(quote-syntax _) - (void)] - [(with-continuation-mark key mark body) - (try-exprs-offset 1 #'(key mark body))] - [(#%plain-app . exprs) - (try-exprs-offset 1 #'exprs)] - [(#%top . var) - (void)] - [else - (error 'expr-iterator "unknown expr: ~a" - (syntax->datum stx))])))) + (let () + (define (make-try-all-subexprs stx kind context-so-far) + (lambda (index-mangler list-of-subtries) + (let loop ([index 0] [remaining list-of-subtries]) + (unless (null? remaining) + (let* ([try (car remaining)] + [corrected-index (index-mangler index)]) + ((car try) (cadr try) (cons (make-context-record stx corrected-index kind) context-so-far)) + (loop (+ index 1) (cdr remaining))))))) - (begin (top-level-expr-iterator stx null) - (error 'find-highlight "couldn't find highlight-placeholder in expression: ~v" (syntax->datum stx)))))) + (define try->offset-try + (lambda (try) + (lambda (offset subtries) + (try (lambda (index) (list (+ offset index))) subtries)))) + + ;; WHOA: this code uses the template for fully-expanded syntax; what the code + ;; actually gets is reconstructed code. This is a problem, because you can't + ;; distinguish a top-level begin from one that's the result of some evaluation. + ;; I think for the moment that it will solve our problem simply to remove the + ;; special case for begin at the top level. JBC, 2006-10-09 + + ;; ... aaaand, yep, there's a bug. The input is not fully-expanded syntax, and + ;; therefore _can_ include a two-branched 'if' (because the reconstructor produces it.) + ;; + + (define (top-level-expr-iterator stx context-so-far) + (let ([try (try->offset-try (make-try-all-subexprs stx 'top-level context-so-far))]) + (kernel:kernel-syntax-case + stx #f + [(module identifier name (#%plain-module-begin . module-level-exprs)) + (try 3 (map (lambda (expr) `(,module-level-expr-iterator ,expr)) + (syntax->list #'module-level-exprs)))] + [else-stx + (general-top-level-expr-iterator stx context-so-far)]))) + + + + (define (module-level-expr-iterator stx context-so-far) + (kernel:kernel-syntax-case + stx #f + [(#%provide . provide-specs) + (void)] + [else-stx + (general-top-level-expr-iterator stx context-so-far)])) + + (define (general-top-level-expr-iterator stx context-so-far) + (let ([try (try->offset-try (make-try-all-subexprs stx 'general-top-level context-so-far))]) + (kernel:kernel-syntax-case + stx #f + [(define-values (var ...) expr) + (try 2 `((,expr-iterator ,#'expr)))] + [(define-syntaxes (var ...) expr) + (try 2 `((,expr-iterator ,#'expr)))] + ;; this code is buggy, but I believe it doesn't belong here at all + ;; per above discussion. JBC, 2006-10-09 + #;[(begin . top-level-exprs) + (try 1 (map (lambda (expr) `(,top-level-expr-iterator ,expr)) + (syntax->list #'exprs)))] + [(#%require . require-specs) + (void)] + [else + (expr-iterator stx context-so-far)]))) + + + (define (expr-iterator stx context-so-far) + (when (stepper-syntax-property stx 'stepper-highlight) + (success-escape (vector context-so-far stx))) + (let* ([try (make-try-all-subexprs stx 'expr context-so-far)] + [try-exprs (lambda (index-mangler exprs) (try index-mangler (map (lambda (expr) (list expr-iterator expr)) + (syntax->list exprs))))] + [try-exprs-offset (try->offset-try try-exprs)] + [let-values-abstraction + (lambda (stx) + (kernel:kernel-syntax-case stx #f + [(kwd (((variable ...) rhs) ...) . bodies) + (begin + (try-exprs (lambda (index) (list 1 index 1)) #'(rhs ...)) + (try-exprs-offset 2 #'bodies))] + [else + (error 'expr-syntax-object-iterator + "unexpected let(rec) expression: ~a" + (syntax->datum stx))]))]) + (kernel:kernel-syntax-case + stx #f + [var-stx + (identifier? (syntax var-stx)) + (void)] + [(#%plain-lambda vars . bodies) + (try-exprs-offset 2 #'bodies)] + [(case-lambda (vars . bodies) ...) + (let loop ([count 1] [clauses (syntax->list #'(bodies ...))]) + (unless (null? clauses) + (try-exprs (lambda (index) (list count (+ index 1))) (cdar clauses)) + (loop (+ count 1) (cdr clauses))))] + [(if test then else) + (try-exprs-offset 1 #'(test then else))] + [(if test then) + (try-exprs-offset 1 #'(test then))] + [(begin . bodies) + (try-exprs-offset 1 #'bodies)] + [(begin0 . bodies) + (try-exprs-offset 1 #'bodies)] + [(let-values . _) + (let-values-abstraction stx)] + [(letrec-values . _) + (let-values-abstraction stx)] + [(set! var val) + (try-exprs-offset 2 #'(val))] + [(quote _) + (void)] + [(quote-syntax _) + (void)] + [(with-continuation-mark key mark body) + (try-exprs-offset 1 #'(key mark body))] + [(#%plain-app . exprs) + (try-exprs-offset 1 #'exprs)] + [(#%top . var) + (void)] + [else + (error 'expr-iterator "unknown expr: ~a" + (syntax->datum stx))]))) + + ;; this should exit before reaching the error: + (top-level-expr-iterator stx null) + (error 'find-highlight "couldn't find highlight-placeholder in expression: ~v" (syntax->datum stx))))) ; TESTING: @@ -186,12 +191,12 @@ (list `(define-values (f) (lambda (x) (letrec-values ([(a) (lambda (x) (#%app b (#%app (#%top . -) x (quote 1))))] [(b) (lambda (x) (#%app a x))]) (#%app a x)))) '(2) 'general-top-level))) - (let*-2vals ([(context-records highlight) (find-highlight test-datum)]) + (match-let* ([(vector context-records highlight) (find-highlight test-datum)]) (test expected map datum-ize-context-record context-records)) (test null (lambda () - (let*-2vals ([(context-records dc) + (match-let* ([(vector context-records dc) (find-highlight (car (build-stx-with-highlight `((hilite foo)))))]) context-records)))) @@ -312,5 +317,5 @@ ) (report-errs) - )) + ) diff --git a/collects/stepper/private/marks.rkt b/collects/stepper/private/marks.rkt index adb9b966bf..6c26f3fef2 100644 --- a/collects/stepper/private/marks.rkt +++ b/collects/stepper/private/marks.rkt @@ -160,23 +160,24 @@ ;;;;;;;;;; (define (make-debug-info source tail-bound free-vars label lifting?) - (let*-2vals ([kept-vars (binding-set-varref-set-intersect tail-bound free-vars)]) - (if lifting? - (let*-2vals ([let-bindings (filter (lambda (var) - (and - (case (stepper-syntax-property var 'stepper-binding-type) - ((let-bound macro-bound) #t) - ((lambda-bound stepper-temp non-lexical) #f) - (else (error 'make-debug-info - "varref ~a's binding-type info was not recognized: ~a" - (syntax-e var) - (stepper-syntax-property var 'stepper-binding-type)))) - (not (stepper-syntax-property var 'stepper-no-lifting-info)))) - kept-vars)] - [lifter-syms (map get-lifted-var let-bindings)]) - (make-full-mark source label (append kept-vars lifter-syms))) - ;; I'm not certain that non-lifting is currently tested: 2005-12, JBC - (make-full-mark source label kept-vars)))) + (define kept-vars (binding-set-varref-set-intersect tail-bound free-vars)) + (define (let-binding? var) + (and + (not (stepper-syntax-property var 'stepper-no-lifting-info)) + (case (stepper-syntax-property var 'stepper-binding-type) + ((let-bound macro-bound) #t) + ((lambda-bound stepper-temp non-lexical) #f) + (else (error 'make-debug-info + "varref ~a's binding-type info was not recognized: ~a" + (syntax-e var) + (stepper-syntax-property var 'stepper-binding-type)))))) + (cond [lifting? + (define let-bindings (filter let-binding? kept-vars)) + (define lifter-syms (map get-lifted-var let-bindings)) + (make-full-mark source label (append kept-vars lifter-syms))] + [else + ;; I'm not certain that non-lifting is currently tested: 2005-12, JBC + (make-full-mark source label kept-vars)])) (define (make-top-level-mark source-expr) diff --git a/collects/stepper/private/my-macros.rkt b/collects/stepper/private/my-macros.rkt index 00fcfbd755..ee610095f8 100644 --- a/collects/stepper/private/my-macros.rkt +++ b/collects/stepper/private/my-macros.rkt @@ -44,30 +44,7 @@ ;; honestly, match-let* supersedes all of this, if I ever have time to redo it... -(provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals) - -(define 2vals vector) - -(define-syntax (let*-2vals stx) - (syntax-case stx (let*-2vals) - [(let*-2vals () . bodies) - (syntax/loc stx (begin . bodies))] - [(let*-2vals ([(id-a id-b) rhs] binding ...) . bodies) ; 2 values in a vector - (syntax/loc stx (let* ([_a rhs] [id-a (vector-ref _a 0)] [id-b (vector-ref _a 1)]) - (let*-2vals (binding ...) . bodies)))] - [(let*-2vals ([id-a rhs] binding ...) . bodies) ; just 1 value - (quasisyntax/loc stx (let* ([id-a rhs]) - #,(syntax/loc stx (let*-2vals (binding ...) . bodies))))])) - -(define-syntax (2vals-first stx) - (syntax-case stx (2vals-first) - [(2vals-first a) - (syntax (vector-ref a 0))])) - -(define-syntax (2vals-second stx) - (syntax-case stx (2vals-second) - [(2vals-second a) - (syntax (vector-ref a 1))])) +(provide 2vals-map apply-to-first-of-2vals) (define (apply-to-first-of-2vals proc 2vals) (vector (proc (vector-ref 2vals 0)) @@ -79,10 +56,10 @@ (define (2vals-map f . lsts) (if (null? (car lsts)) - (2vals null null) - (let*-2vals ([(a b) (apply f (map car lsts))] - [(a-rest b-rest) (apply 2vals-map f (map cdr lsts))]) - (2vals (cons a a-rest) (cons b b-rest))))) + (vector null null) + (match-let* ([(vector a b) (apply f (map car lsts))] + [(vector a-rest b-rest) (apply 2vals-map f (map cdr lsts))]) + (vector (cons a a-rest) (cons b b-rest))))) ; test cases ; (require my-macros) diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index 6c714627bc..cb02a2c053 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -54,7 +54,7 @@ (define-struct let-glump (name-set exp val-set)) - ; split-list : ('a -> boolean) (listof 'a) -> (2vals (listof 'a) (listof 'a)) + ; split-list : ('a -> boolean) (listof 'a) -> (vector (listof 'a) (listof 'a)) ; split-list splits a list into two lists at the first element s.t. (fn element) => true). ; that is, split-list yields the lists A and B such that (append A B) gives the original ; list, and (fn element) => false for all elements in A, and B is either empty or @@ -63,15 +63,15 @@ (define (split-list fn lst) (let loop ([remaining lst] [so-far null]) (cond [(null? remaining) - (2vals (reverse so-far) null)] + (vector (reverse so-far) null)] [else (if (fn (car remaining)) - (2vals (reverse so-far) remaining) + (vector (reverse so-far) remaining) (loop (cdr remaining) (cons (car remaining) so-far)))]))) ; test cases - ; (test (2vals '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1)) - ; (test (2vals '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5)) + ; (test (vector '(93 4 2) '(0 2 1)) split-list (lambda (x) (= x 0)) '(93 4 2 0 2 1)) + ; (test (vector '(3 4 5) '()) split-list (lambda (x) (= x 0)) '(3 4 5)) ; n-split-list : num ('a list) -> ('a list) ('a list) ; n-split-list splits a given list A into two lists B and C, such that B contains the @@ -82,11 +82,11 @@ (error 'n-split-list "can't split list ~a after ~ath element; not long enough" lst num)) (let loop ([count num] [remaining lst] [so-far null]) (if (= count 0) - (2vals (reverse so-far) remaining) + (vector (reverse so-far) remaining) (loop (- count 1) (cdr remaining) (cons (car remaining) so-far))))) ; test cases - ; (test (2vals '(a b c) '(d e f)) n-split-list 3 '(a b c d e f)) + ; (test (vector '(a b c) '(d e f)) n-split-list 3 '(a b c d e f)) (define (mark-as-highlight stx) @@ -646,68 +646,69 @@ [recon-let (lambda () (with-syntax ([(label ((vars rhs) ...) . bodies) exp]) - (let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))] - [binding-list (apply append binding-sets)] - [glumps - (map (lambda (binding-set rhs) - (make-let-glump - (map (lambda (binding) - (stepper-syntax-property binding - 'stepper-lifted-name - (binding-lifted-name mark-list binding))) - binding-set) - rhs - (map (lambda (arg-binding) - (lookup-binding mark-list arg-binding)) - binding-set))) - binding-sets - (syntax->list #`(rhs ...)))] - [num-defns-done (lookup-binding mark-list let-counter)] - [(done-glumps not-done-glumps) - (n-split-list num-defns-done glumps)] - [recon-lifted - (lambda (names expr) - #`(#,names #,expr))] - [before-bindings - (map - (lambda (glump) - (let* ([name-set (let-glump-name-set glump)] - [rhs-val-set (map (lambda (val) - (if (> (length name-set) 0) - (recon-value val render-settings (car name-set)) - (recon-value val render-settings))) - (let-glump-val-set glump))]) - (if (= (length rhs-val-set) 1) - #`(#,name-set #,@rhs-val-set) - #`(#,name-set (values #,rhs-val-set))))) - done-glumps)] - [reconstruct-remaining-def - (lambda (glump) - (let ([rhs-source (let-glump-exp glump)] - [rhs-name-set (let-glump-name-set glump)]) - (recon-lifted rhs-name-set - (recon-source-current-marks rhs-source))))] - [after-bindings - (if (pair? not-done-glumps) - (if (eq? so-far nothing-so-far) - (map reconstruct-remaining-def not-done-glumps) - (cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far) - (map reconstruct-remaining-def (cdr not-done-glumps)))) - null)] - [recon-bindings (append before-bindings after-bindings)] - ;; there's a terrible tangle of invariants here. Among them: - ;; num-defns-done = (length binding-sets) IFF the so-far has a 'stepper-offset' index - ;; that is not #f (that is, we're evaluating the body...) - [so-far-offset-index (and (not (eq? so-far nothing-so-far)) - (stepper-syntax-property so-far 'stepper-offset-index))] - [bodies (syntax->list (syntax bodies))] - [rectified-bodies - (map (lambda (body offset-index) - (if (eq? offset-index so-far-offset-index) - so-far - (recon-source-expr body mark-list binding-list binding-list render-settings))) - bodies - (iota (length bodies)))]) + (match-let* + ([binding-sets (map syntax->list (syntax->list #'(vars ...)))] + [binding-list (apply append binding-sets)] + [glumps + (map (lambda (binding-set rhs) + (make-let-glump + (map (lambda (binding) + (stepper-syntax-property binding + 'stepper-lifted-name + (binding-lifted-name mark-list binding))) + binding-set) + rhs + (map (lambda (arg-binding) + (lookup-binding mark-list arg-binding)) + binding-set))) + binding-sets + (syntax->list #`(rhs ...)))] + [num-defns-done (lookup-binding mark-list let-counter)] + [(vector done-glumps not-done-glumps) + (n-split-list num-defns-done glumps)] + [recon-lifted + (lambda (names expr) + #`(#,names #,expr))] + [before-bindings + (map + (lambda (glump) + (let* ([name-set (let-glump-name-set glump)] + [rhs-val-set (map (lambda (val) + (if (> (length name-set) 0) + (recon-value val render-settings (car name-set)) + (recon-value val render-settings))) + (let-glump-val-set glump))]) + (if (= (length rhs-val-set) 1) + #`(#,name-set #,@rhs-val-set) + #`(#,name-set (values #,rhs-val-set))))) + done-glumps)] + [reconstruct-remaining-def + (lambda (glump) + (let ([rhs-source (let-glump-exp glump)] + [rhs-name-set (let-glump-name-set glump)]) + (recon-lifted rhs-name-set + (recon-source-current-marks rhs-source))))] + [after-bindings + (if (pair? not-done-glumps) + (if (eq? so-far nothing-so-far) + (map reconstruct-remaining-def not-done-glumps) + (cons (recon-lifted (let-glump-name-set (car not-done-glumps)) so-far) + (map reconstruct-remaining-def (cdr not-done-glumps)))) + null)] + [recon-bindings (append before-bindings after-bindings)] + ;; there's a terrible tangle of invariants here. Among them: + ;; num-defns-done = (length binding-sets) IFF the so-far has a 'stepper-offset' index + ;; that is not #f (that is, we're evaluating the body...) + [so-far-offset-index (and (not (eq? so-far nothing-so-far)) + (stepper-syntax-property so-far 'stepper-offset-index))] + [bodies (syntax->list (syntax bodies))] + [rectified-bodies + (map (lambda (body offset-index) + (if (eq? offset-index so-far-offset-index) + so-far + (recon-source-expr body mark-list binding-list binding-list render-settings))) + bodies + (iota (length bodies)))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) (if (stepper-syntax-property exp 'stepper-fake-exp) diff --git a/collects/tests/stepper/through-tests.rkt b/collects/tests/stepper/through-tests.rkt index f0860b4c0d..0e0103d5d8 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -1504,7 +1504,7 @@ (provide ggg) ;; run whatever tests are enabled (intended for interactive use): (define (ggg) - (parameterize (#;[disable-stepper-error-handling #t] + (parameterize ([disable-stepper-error-handling #t] #;[display-only-errors #t] #;[store-steps #f] #;[show-all-steps #t]) @@ -1512,5 +1512,5 @@ check-error check-error-bad)) #;(run-tests '(teachpack-universe)) #;(run-all-tests) - (run-tests '(mz-app2)) + (run-tests '(simple-if)) ))