From 5a795b614ccc4527097f5dacc59a43d90e2c33ba Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 21 Nov 2006 23:01:26 +0000 Subject: [PATCH] working on begin0 svn: r4914 --- collects/stepper/private/annotate.ss | 88 ++++++++++++++++++++----- collects/stepper/private/reconstruct.ss | 46 ++++--------- collects/stepper/private/shared.ss | 26 ++++---- 3 files changed, 101 insertions(+), 59 deletions(-) diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index be9bd9f9d7..51ab094a7f 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -452,6 +452,7 @@ [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) @@ -574,6 +575,9 @@ ; 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) @@ -702,14 +706,21 @@ free-varrefs)))] - ; :@@$ - ; @: - ; @@@ @@@ $@$: @@-$+ @@-$+ -@@$ @@@@@ - ; $ $ -@ @$ : @$ : $ -$ @ - ; +: ++ -$@$@ @ @ @@@@@ @ - ; $ $ $* @ @ @ $ @ - ; $:+ @- *@ @ @ +: @ - ; :@ -$$-@@ @@@@@ @@@@@ $@@+ @@@@@ + + ; + ; + ; ;;; + ; ; + ; ; + ; ; ; ;;;; ; ;;; ; ;;; ;;; ;;;;;; + ; ; ; ; ; ;; ; ;; ; ; ; ; + ; ; ; ; ; ; ; ;;;;; ; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ;; ; ; ; ; + ; ; ;; ; ; ; ;;;; ; + ; + ; + ; [varref-abstraction @@ -822,7 +833,45 @@ ; ;;;; ; - [(begin0 . 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))] + + #;(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))])) + + #;[(begin0 first-body . bodies-stx) + (let*-2vals ([(annotated-first free-vars-first) (result-recur first-body)]) + #`(let ([,begin0-temp #,annotated-first]) + #,unrolled-rest)) + (let unroll-loop ([bodies-list (syntax->list #`(first-body . bodies-stx))] [outermost? #t]) + (cond [(null? bodies-list) + (error 'annotate "this case should have been handled by the zero-body annotation")] + [(null? (cdr bodies-list)) + (let*-2vals + ([(this-one free-vars-this) (non-tail-recur)]))])) (let*-2vals ([bodies (syntax->list (syntax bodies-stx))] [(annotated-first free-varrefs-first) @@ -832,13 +881,22 @@ (normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets)) (quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))] - ;; special case for the expansion of begin. - ;; more efficient, but disabled because of difficulties in threading it through the - ;; reconstruction. Easier to undo in the macro-unwind phase. - #;[(let-values () . bodies-stx) - (eq? (stepper-syntax-property exp 'stepper-hint) 'comes-from-begin) - (begin-abstraction (syntax->list #`bodies-stx))] + + ; + ; + ; ;;; ;;; + ; ; ; ; + ; ; ; ; + ; ; ;;; ;;;;; ; ; ;;;; ; ; ; ;;; ;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ;;;;; ; ;;;;; ; ; ; ; ; ; ; ;;;;; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; + ; ;;; ;;;; ;; ; ;; ; ;;; ;; ; ;;;; ;;; + ; + ; + ; [(let-values . _) (let-abstraction exp #`let-values diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index f2cd6ec814..03d2c842d6 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -772,44 +772,21 @@ ;; advanced-begin : okay, here comes advanced-begin. [(begin . terms) - ;; copied from app: - (error 'reconstruct/inner "how did we get here?") - - #;(attach-info - (let* ([sub-exprs (syntax->list (syntax terms))] - [arg-temps (build-list (length sub-exprs) get-arg-var)] - [arg-vals (map (lambda (arg-temp) - (lookup-binding mark-list arg-temp)) - arg-temps)]) - (case (mark-label (car mark-list)) - ((not-yet-called) - (let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*)) - (zip sub-exprs arg-vals))] - [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) - (if (null? unevaluated) - #`(#%app . #,rectified-evaluated) - #`(#%app - #,@rectified-evaluated - #,so-far - #,@(map recon-source-current-marks (cdr (map car unevaluated))))))) - ((called) - (if (eq? so-far nothing-so-far) - (datum->syntax-object #'here `(,#'#%app ...)) ; in unannotated code - (datum->syntax-object #'here `(,#'#%app ... ,so-far ...)))) - (else - (error "bad label in application mark in expr: ~a" exp)))) - exp)] + ;; even in advanced, begin expands into a let-values. + (error 'reconstruct/inner "begin in non-teaching-languages not implemented in reconstruct")] ; begin : in the current expansion of begin, there are only two-element begin's, one-element begins, and ;; zero-element begins; these arise as the expansion of ... ? - [(begin stx-a stx-b) + ;; these are all dead code, right? + + #;[(begin stx-a stx-b) (attach-info (if (eq? so-far nothing-so-far) #`(begin #,(recon-source-current-marks #`stx-a) #,(recon-source-current-marks #`stx-b)) #`(begin #,so-far #,(recon-source-current-marks #`stx-b))))] - [(begin clause) + #;[(begin clause) (attach-info (if (eq? so-far nothing-so-far) #`(begin #,(recon-source-current-marks (syntax clause))) @@ -818,7 +795,7 @@ "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp))) exp)] - [(begin) + #;[(begin) (attach-info (if (eq? so-far nothing-so-far) #`(begin) @@ -826,8 +803,13 @@ 'recon-inner "stepper-reconstruct: zero-clause begin appeared as context: ~a" (syntax-object->datum exp))))] - ; begin0 : may not occur directly except in advanced - #;[(begin0 )] + ; begin0 : + ;; one-body begin0: perhaps this will turn out to be a special case of the + ;; many-body case. + [(begin0 body) + (if (eq? so-far nothing-so-far) + (recon-source-current-marks exp) + (error 'recon-inner "one-body begin0 given as context: ~a" exp))] ; let-values diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index df7841edb4..056a9be429 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -21,18 +21,18 @@ (and (syntax? v) ((flat-contract-predicate (cons/c identifier? arglist?)) (syntax-e v))))) - (provide/contract - ;[varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)] - ;[binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)] - ;[binding-set-union (-> (listof binding-set?) binding-set?)] - ;[varref-set-union (-> (listof varref-set?) varref-set?)] - #;[skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)] - #;[in-closure-table (-> any/c boolean?)] - #;[sublist (-> number? number? list? list?)] - #;[attach-info (-> syntax? syntax? syntax?)] - #;[transfer-info (-> syntax? syntax? syntax?)] - #;[arglist->ilist (-> arglist? any)] - #;[arglist-flatten (-> arglist? (listof identifier?))]) + #;(provide/contract + [varref-set-remove-bindings (-> varref-set? varref-set? varref-set?)] + [binding-set-varref-set-intersect (-> binding-set? varref-set? binding-set?)] + [binding-set-union (-> (listof binding-set?) binding-set?)] + [varref-set-union (-> (listof varref-set?) varref-set?)] + [skipto/auto (syntax? (symbols 'rebuild 'discard) (syntax? . -> . syntax?) . -> . syntax?)] + [in-closure-table (-> any/c boolean?)] + [sublist (-> number? number? list? list?)] + [attach-info (-> syntax? syntax? syntax?)] + [transfer-info (-> syntax? syntax? syntax?)] + [arglist->ilist (-> arglist? any)] + [arglist-flatten (-> arglist? (listof identifier?))]) (provide skipto/auto @@ -66,6 +66,7 @@ closure-table-lookup get-lifted-var get-arg-var + begin0-temp zip let-counter syntax-pair-map @@ -174,6 +175,7 @@ ; (eq? arg2 arg2p) ; (not (eq? arg1 arg2p))))) + (define begin0-temp (create-bogus-binding "begin0-temp")) ; get-lifted-var maintains the mapping between let-bindings and the syntax object ; which is used to capture its index at runtime.