From 6921960c5ed42a68931f2d35c3f3a71db0b94f9f Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Sat, 2 Apr 2011 15:47:29 -0400 Subject: [PATCH] simple example working: (define (f x) (+ x x)) (f (+ 1 2)) in stepper/private/model.rkt - add debugging outputs - reformat code in stepper/private/macro-unwind.rkt: - in fall-through - add case for lazy racket app - add case for procedure-extract-target - in unwind, change recur procedure for fn hints to unwind (was recur-on-pieces) in racket/private/promise.rkt - add unwind fn as stepper-hint syntax property in stepper/private/reconstruct.rkt - add constructor application case back - in recon-inner - in app called case, dont show ellipses for force - initialize partially-eval-promise table - reformat answer code - add caching of running promises - in recon-value, add reconstructing of partially evaluated promises in stepper-private/annotate.rkt - in annotate/module-top-level, add lazy racket top level case - to hide top level forcer in lazy/lazy.rkt - use hidden-~ and hidden-! instead of ~ and ! --- collects/lazy/lazy.rkt | 78 +++++--- collects/racket/private/promise.rkt | 35 +++- collects/stepper/private/annotate.rkt | 24 +++ collects/stepper/private/macro-unwind.rkt | 75 +++++--- collects/stepper/private/model.rkt | 221 +++++++++++++++------- collects/stepper/private/reconstruct.rkt | 135 +++++++++---- 6 files changed, 403 insertions(+), 165 deletions(-) diff --git a/collects/lazy/lazy.rkt b/collects/lazy/lazy.rkt index 3460985bf8..138c735c71 100644 --- a/collects/lazy/lazy.rkt +++ b/collects/lazy/lazy.rkt @@ -55,6 +55,28 @@ (define-for-syntax strict-names (syntax->list #'(! !! !list !!list !values !!values))) + ;; -------------------------------------------------------------------------- + ;; Stepper utility fns + + (define-for-syntax (stepper-hide-operator stx) + (stepper-syntax-property stx 'stepper-skipto (append skipto/cdr skipto/second))) + + (define-syntax (hidden-car stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (car arg)))])) + + (define-syntax (hidden-cdr stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (cdr arg)))])) + + (define-syntax (hidden-! stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (! arg)))])) + + (define-syntax (hidden-~ stx) + (syntax-case stx () + [(_ arg) (stepper-hide-operator (syntax/loc stx (~ arg)))])) + ;; -------------------------------------------------------------------------- ;; Determine laziness @@ -107,7 +129,7 @@ ;; single expr [(expr) #`(begin #,@(reverse defs) expr)] [(expr ...) - #`(begin #,@(reverse defs) (~ (begin (! expr) ...)))]))])))) + #`(begin #,@(reverse defs) (hidden-~ (begin (hidden-! expr) ...)))]))])))) ;; redefined to use lazy-proc and ~begin (define-syntax (~lambda stx) @@ -161,7 +183,7 @@ (defsubst (~parameterize ([param val] ...) body ...) ;; like ~begin, delaying the whole thing is necessary to tie the evaluation ;; to whenever the value is actually forced - (~ (parameterize ([param (! val)] ...) (~begin body ...)))) + (hidden-~ (parameterize ([param (hidden-! val)] ...) (~begin body ...)))) ;; Multiple values are problematic: Racket promises can use multiple ;; values, but to carry that out `call-with-values' should be used in all @@ -222,12 +244,6 @@ ;; `!apply': provided as `apply' (no need to provide `~!apply', since all ;; function calls are delayed by `#%app') - (define-syntax (hidden-! stx) - (syntax-case stx (!) - [(_ arg) (syntax/loc stx (! arg)) - #;(stepper-syntax-property #'(! arg) 'stepper-skipto - (append skipto/cdr skipto/second))])) - (define-syntax (!*app stx) (syntax-case stx () [(_ f x ...) @@ -256,8 +272,8 @@ (if (lazy? p) lazy strict))))))])) (defsubst (!app f x ...) (!*app (hidden-! f) x ...)) - (defsubst (~!*app f x ...) (~ (!*app f x ...))) - (defsubst (~!app f x ...) (~ (!app f x ...))) + (defsubst (~!*app f x ...) (hidden-~ (!*app f x ...))) + (defsubst (~!app f x ...) (hidden-~ (!app f x ...))) (define-for-syntax (toplevel?) (memq (syntax-local-context) @@ -269,12 +285,12 @@ (provide (rename ~!%app #%app)) ; all applications are delayed (define-syntax (~!%app stx) ; provided as #%app - (define (unwinder stx rec) + #;(define (unwinder stx rec) (syntax-case stx (!) [(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body) (with-syntax ([(f x ...) (rec #'(f x ...))]) #'(f x ...))])) - (define (stepper-annotate stx) + #;(define (stepper-annotate stx) (let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)] [stx (stepper-syntax-property stx 'stepper-skip-double-break #t)]) stx)) @@ -300,8 +316,8 @@ (define* (!apply f . xs) (let ([f (! f)] [xs (!list (apply list* xs))]) (apply f (if (lazy? f) xs (map ! xs))))) - (defsubst (~!*apply f . xs) (~ (!*apply f . xs))) - (defsubst (~!apply f . xs) (~ (!apply f . xs))) + (defsubst (~!*apply f . xs) (hidden-~ (!*apply f . xs))) + (defsubst (~!apply f . xs) (hidden-~ (!apply f . xs))) (provide (rename !apply apply)) ; can only be used through #%app => delayed @@ -312,8 +328,8 @@ [(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))])) ;; used for explicitly strict/lazy calls - (defsubst (strict-call f x ...) (~ (f (! x) ...))) - (defsubst (lazy-call f x ...) (~ (f x ...))) + (defsubst (strict-call f x ...) (hidden-~ (f (! x) ...))) + (defsubst (lazy-call f x ...) (hidden-~ (f x ...))) ;; -------------------------------------------------------------------------- ;; Special forms that are now functions @@ -324,8 +340,8 @@ (define* *if (case-lambda [(e1 e2 e3) (if (! e1) e2 e3)] [(e1 e2 ) (if (! e1) e2 )])) - (defsubst (~if e1 e2 e3) (~ (if (! e1) e2 e3)) - (~if e1 e2 ) (~ (if (! e1) e2 )) + (defsubst (~if e1 e2 e3) (hidden-~ (if (hidden-! e1) e2 e3)) + (~if e1 e2 ) (hidden-~ (if (hidden-! e1) e2 )) ~if *if) (define* (*and . xs) @@ -333,29 +349,29 @@ (or (null? xs) (let loop ([x (car xs)] [xs (cdr xs)]) (if (null? xs) x (and (! x) (loop (car xs) (cdr xs)))))))) - (defsubst (~and x ...) (~ (and (! x) ...)) ~and *and) + (defsubst (~and x ...) (hidden-~ (and (hidden-! x) ...)) ~and *and) (define* (*or . xs) (let ([xs (!list xs)]) (and (pair? xs) (let loop ([x (car xs)] [xs (cdr xs)]) (if (null? xs) x (or (! x) (loop (car xs) (cdr xs)))))))) - (defsubst (~or x ...) (~ (or (! x) ...)) ~or *or) + (defsubst (~or x ...) (hidden-~ (or (hidden-! x) ...)) ~or *or) ;; -------------------------------------------------------------------------- ;; Special forms that are still special forms since they use ~begin (defsubst (~begin0 x y ...) ; not using ~begin, but equivalent - (~ (let ([val (! x)]) (! y) ... val))) + (hidden-~ (let ([val (hidden-! x)]) (hidden-! y) ... val))) - (defsubst (~when e x ...) (~ (when (! e) (~begin x ...)))) - (defsubst (~unless e x ...) (~ (unless (! e) (~begin x ...)))) + (defsubst (~when e x ...) (hidden-~ (when (hidden-! e) (~begin x ...)))) + (defsubst (~unless e x ...) (hidden-~ (unless (hidden-! e) (~begin x ...)))) ;; -------------------------------------------------------------------------- ;; Misc stuff ;; Just for fun... - (defsubst (~set! id expr) (~ (set! id (! expr)))) + (defsubst (~set! id expr) (hidden-~ (set! id (hidden-! expr)))) ;; The last ! above is needed -- without it: ;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a) ;; goes into an infinite loop. (Thanks to Jos Koot) @@ -373,11 +389,11 @@ ;; avoid forcing an `else' keyword (map (lambda (stx) (syntax-case stx (else) - [else stx] [x #'(! x)])) + [else stx] [x #'(hidden-! x)])) (syntax->list #'(test ...)))]) - #'(~ (cond [test (~begin body ...)] ...)))])) + #'(hidden-~ (cond [test (~begin body ...)] ...)))])) (defsubst (~case v [keys body ...] ...) - (~ (case (! v) [keys (~begin body ...)] ...))) + (hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...))) ;; Doing this will print the whole thing, but problems with infinite things (define* (~error . args) (apply error (!! args))) @@ -525,14 +541,14 @@ #'(define* ?~name (case-lambda [(?proc ?args ... ?l) - (let ([?proc (! ?proc)]) - (let ?loop ([?l (! ?l)] [?var ?init] ...) + (let ([?proc (hidden-! ?proc)]) + (let ?loop ([?l (hidden-! ?l)] [?var ?init] ...) (if (null? ?l) ?base ?step-single)))] [(?proc ?args ... ?l . ?ls) - (let ([?proc (! ?proc)]) - (let ?loop ([?ls (cons (! ?l) (!!list ?ls))] [?var ?init] ...) + (let ([?proc (hidden-! ?proc)]) + (let ?loop ([?ls (cons (hidden-! ?l) (!!list ?ls))] [?var ?init] ...) (if (ormap null? ?ls) (if (andmap null? ?ls) ?base diff --git a/collects/racket/private/promise.rkt b/collects/racket/private/promise.rkt index 800b2a66a3..ead71b3099 100644 --- a/collects/racket/private/promise.rkt +++ b/collects/racket/private/promise.rkt @@ -171,6 +171,26 @@ (define-struct (composable-promise promise) () #:property prop:force force/composable) + ;; stepper-syntax-property : like syntax property, but adds properties to an + ;; association list associated with the syntax property 'stepper-properties + ;; Had to re-define this because of circular dependencies + ;; (also defined in stepper/private/shared.rkt) + (define-for-syntax stepper-syntax-property + (case-lambda + [(stx tag) + (letrec-values ([(stepper-props) (syntax-property stx 'stepper-properties)]) + (if stepper-props + (letrec-values ([(table-lookup) (assq tag stepper-props)]) + (if table-lookup + (cadr table-lookup) + #f)) + #f))] + [(stx tag new-val) + (letrec-values ([(stepper-props) (syntax-property stx 'stepper-properties)]) + (syntax-property stx 'stepper-properties + (cons (list tag new-val) + (if stepper-props stepper-props '()))))])) + ;; template for all delay-like constructs ;; (with simple keyword matching: keywords is an alist with default exprs) (define-for-syntax (make-delayer stx maker keywords) @@ -203,14 +223,21 @@ ;; work well with identifiers, so turn the name into a symbol to work ;; around this for now [(name0) (syntax-local-infer-name stx)] - [(name) (if (syntax? name0) (syntax-e name0) name0)]) + [(name) (if (syntax? name0) (syntax-e name0) name0)] + [(unwind-promise) + (lambda (stx unwind-recur) + (syntax-case stx () + [(#%plain-lambda () body) (unwind-recur #'body)]))]) (syntax-case stx () [_ (pair? exprs) ; throw a syntax error if anything is wrong (with-syntax ([(expr ...) exprs] [(kwd-arg ...) kwd-args]) - (with-syntax ([proc (syntax-property - (syntax/loc stx (lambda () expr ...)) - 'inferred-name name)] + (with-syntax ([proc + (stepper-syntax-property + (syntax-property + (syntax/loc stx (lambda () expr ...)) + 'inferred-name name) + 'stepper-hint unwind-promise)] [make maker]) (syntax/loc stx (make proc kwd-arg ...))))]))) diff --git a/collects/stepper/private/annotate.rkt b/collects/stepper/private/annotate.rkt index e4843ec1fd..f6889707c5 100644 --- a/collects/stepper/private/annotate.rkt +++ b/collects/stepper/private/annotate.rkt @@ -1281,6 +1281,30 @@ call-with-values (#%plain-lambda () vals) print-values)))) exp))] + ; STC: for lazy racket + ; This is similar to app case above, but with toplevel-forcer + [(#%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)] diff --git a/collects/stepper/private/macro-unwind.rkt b/collects/stepper/private/macro-unwind.rkt index f22d813b51..b418b57ab6 100644 --- a/collects/stepper/private/macro-unwind.rkt +++ b/collects/stepper/private/macro-unwind.rkt @@ -50,39 +50,56 @@ stx (syntax-pair-map (syntax-e stx) (lambda (stx) (unwind stx settings))) stx stx) stx)) - (define (fall-through stx settings) - (kernel-syntax-case stx #f - [id - (identifier? stx) - (or (stepper-syntax-property stx 'stepper-lifted-name) - stx)] - [(define-values dc ...) - (unwind-define stx settings)] - [(#%plain-app exp ...) - (recur-on-pieces #'(exp ...) settings)] - [(quote datum) - (if (symbol? #'datum) - stx - #'datum)] - [(let-values . rest) - (unwind-mz-let stx settings)] - [(letrec-values . rest) - (unwind-mz-let stx settings)] - [(#%plain-lambda . rest) - (recur-on-pieces #'(lambda . rest) settings)] - [(set! var rhs) - (with-syntax ([unwound-var (or (stepper-syntax-property - #`var 'stepper-lifted-name) - #`var)] - [unwound-body (unwind #`rhs settings)]) - #`(set! unwound-var unwound-body))] - [else (recur-on-pieces stx settings)])) - + (define (fall-through stx settings) + (kernel-syntax-case stx #f + [id + (identifier? stx) + (or (stepper-syntax-property stx 'stepper-lifted-name) + stx)] + [(define-values dc ...) + (unwind-define stx settings)] + ; STC: app special cases from lazy racket + ; procedure-extract-target - can't hide this in lazy.rkt bc it's needed + ; to distinguish the general lazy application + [(#%plain-app proc-extract p) + (eq? (syntax->datum #'proc-extract) 'procedure-extract-target) + (unwind #'p settings)] + ; general lazy application + [(#%plain-app + (#%plain-lambda args1 (#%plain-app (#%plain-app proc p) . args2)) + . args3) + (and (eq? (syntax->datum #'proc) 'procedure-extract-target) + (equal? (syntax->datum (cdr (syntax-e #'args1))) + (syntax->datum #'args2))) + (recur-on-pieces #'args3 settings)] + [(#%plain-app exp ...) + (recur-on-pieces #'(exp ...) settings)] + [(quote datum) + (if (symbol? #'datum) + stx + #'datum)] + [(let-values . rest) + (unwind-mz-let stx settings)] + [(letrec-values . rest) + (unwind-mz-let stx settings)] + [(#%plain-lambda . rest) + (recur-on-pieces #'(lambda . rest) settings)] + [(set! var rhs) + (with-syntax ([unwound-var (or (stepper-syntax-property + #`var 'stepper-lifted-name) + #`var)] + [unwound-body (unwind #`rhs settings)]) + #`(set! unwound-var unwound-body))] + [else (recur-on-pieces stx settings)])) + (define (unwind stx settings) (transfer-info (let ([hint (stepper-syntax-property stx 'stepper-hint)]) (if (procedure? hint) - (hint stx (lambda (stx) (recur-on-pieces stx settings))) + ; STC: For fn hints, I changed the recur procedure to unwind + ; (was recur-on-pieces). This should not affect the non-lazy + ; stepper since it doesnt seem to use any fn hints. + (hint stx (lambda (stx) (unwind stx settings))) (let ([process (case hint [(comes-from-cond) unwind-cond] [(comes-from-and) (unwind-and/or 'and)] diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index 083c65049a..1eaf54d619 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -84,6 +84,8 @@ #:disable-error-handling? [disable-error-handling? #f] #:raw-step-receiver [raw-step-receiver #f]) + (define DEBUG #f) + ;; finished-exps: ;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) ;; because of mutation, these cannot be fixed renderings, but must be @@ -104,6 +106,14 @@ (define held-finished-list null) + (define (reset-held-exp-list) + (set! held-exp-list the-no-sexp) + (set! held-finished-list null)) + + ; used when determining whether to skip step with ellipses on LHS + (define last-rhs-exps null) + + ;; highlight-mutated-expressions : ;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) ;; -> (list/c (listof syntax?) (listof syntax?))) @@ -164,6 +174,8 @@ (define break (lambda (mark-set break-kind [returned-value-list #f]) + (when DEBUG + (printf "\n---------- BREAK TYPE = ~a ----------\n" break-kind)) (set! steps-received (+ steps-received 1)) ;; have to be careful else this won't be looked up right away: @@ -176,8 +188,14 @@ steps-received/current mark-set break-kind returned-value-list))))) - (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) - + (let* ([mark-list (and mark-set (extract-mark-list mark-set))] + [dump-marks + (when DEBUG + (printf "MARKLIST:\n") + (and mark-set + (map (λ (x) (printf "~a\n" (display-mark x))) mark-list)) + (printf "RETURNED VALUE LIST: ~a\n" returned-value-list))]) + (define (reconstruct-all-completed) (filter-map (match-lambda @@ -192,91 +210,138 @@ [(vector exp #t) exp])))]) finished-exps)) + (define (compute-posn-info) + (mark-list->posn-info mark-list)) + + (define (compute-step-was-app?) + (r:step-was-app? mark-list)) + + (define (compute-step-kind held-step-was-app?) + (if (and held-step-was-app? + (eq? break-kind 'result-exp-break)) + 'user-application + 'normal)) + + (define (create-held exps) + (make-held exps (compute-step-was-app?) (compute-posn-info))) + + ; sends a step to the stepper, except if + ; - lhs = rhs + ; - lhs = ellipses, rhs = last-rhs + (define (send-step lhs-exps lhs-finished-exps + rhs-exps rhs-finished-exps + step-kind lhs-posn-info rhs-posn-info) + (when DEBUG + (printf "maybe sending step ... \n") + (printf "LHS = ~a\n" (map syntax->hilite-datum lhs-exps)) + (printf "RHS = ~a\n" (map syntax->hilite-datum rhs-exps))) + (unless (or (and (step=? lhs-exps rhs-exps) + (when DEBUG (printf "LHS = RHS, so skipping\n"))) + (and (step=? lhs-exps (list #'(... ...))) + (step=? rhs-exps last-rhs-exps) + (when DEBUG + (printf "LHS = ..., RHS = last RHS, so skipping\n")))) + (receive-result + (make-before-after-result + (append lhs-finished-exps lhs-exps) + (append rhs-finished-exps rhs-exps) + step-kind + lhs-posn-info rhs-posn-info)) + (when DEBUG (printf "step sent\n")) + (set! last-rhs-exps rhs-exps))) + + ; compares the lhs and rhs of a step (lists of syntaxes) + ; and returns true if the underlying datums are equal + (define (step=? lhs rhs) + (equal? (map syntax->datum lhs) + (map syntax->datum rhs))) + #;(>>> break-kind) #;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind) (if (r:skip-step? break-kind mark-list render-settings) (begin - #;(fprintf (current-error-port) " but it was skipped!\n") + (when DEBUG (printf "skipped step\n")) (when (or (eq? break-kind 'normal-break) ;; not sure about this... (eq? break-kind 'nomal-break/values)) (set! held-exp-list the-skipped-step))) (begin - #;(fprintf (current-error-port) "and it wasn't skipped.\n") (case break-kind + ; CASE: normal-break or normal-break/values ------------------- [(normal-break normal-break/values) (begin (when (and (eq? break-kind 'normal-break) returned-value-list) (error 'break "broken invariant: normal-break can't have returned values")) - (set! held-finished-list (reconstruct-all-completed)) - (set! held-exp-list - (make-held - (map (lambda (exp) - (unwind exp render-settings)) - (maybe-lift - (r:reconstruct-left-side - mark-list returned-value-list render-settings) - #f)) - (r:step-was-app? mark-list) - (mark-list->posn-info mark-list))))] + (let* + ([lhs-reconstructed + (r:reconstruct-left-side + mark-list returned-value-list render-settings)] + [print-lhs-recon + (when DEBUG + (printf "LHS (pre-unwound):\n ~a\n" + (syntax->hilite-datum lhs-reconstructed)))] + [lhs-unwound + (map (λ (exp) (unwind exp render-settings)) + (maybe-lift lhs-reconstructed #f))] + [print-lhs-unwound + (when DEBUG + (for-each + (λ (x) (printf "LHS (unwound): ~a\n" + (syntax->hilite-datum x))) + lhs-unwound))] + [lhs-finished-exps (reconstruct-all-completed)]) + (set! held-finished-list lhs-finished-exps) + (set! held-exp-list (create-held lhs-unwound))))] + ; CASE: result-exp-break or result-value-break ---------------- [(result-exp-break result-value-break) - (let ([reconstruct + (let ([reconstruct (lambda () - (map (lambda (exp) - (unwind exp render-settings)) - (maybe-lift - (r:reconstruct-right-side - mark-list returned-value-list render-settings) - #f)))] - [send-result (lambda (result) - (set! held-exp-list the-no-sexp) - (receive-result result))]) + (let* ([rhs-reconstructed + (r:reconstruct-right-side + mark-list returned-value-list render-settings)] + [print-rhs-recon + (when DEBUG + (printf "RHS (pre-unwound):\n ~a\n" + (syntax->hilite-datum rhs-reconstructed)))] + [rhs-unwound + (map (λ (exp) (unwind exp render-settings)) + (maybe-lift rhs-reconstructed #f))] + [print-rhs-unwound + (when DEBUG + (for-each + (λ (x) (printf "RHS (unwound): ~a\n" + (syntax->hilite-datum x))) + rhs-unwound))]) + rhs-unwound))]) (match held-exp-list [(struct skipped-step ()) + (when DEBUG (printf "LHS = skipped, so skipping RHS\n")) ;; don't render if before step was a skipped-step - (set! held-exp-list the-no-sexp)] + (reset-held-exp-list)] [(struct no-sexp ()) + (when DEBUG (printf "LHS = none\n")) ;; in this case, there was no "before" step, due ;; to unannotated code. In this case, we make the ;; optimistic guess that none of the finished ;; expressions were mutated. It would be somewhat ;; painful to do a better job, and the stepper ;; makes no guarantees in this case. - (send-result - (make-before-after-result - ;; NB: this (... ...) IS UNRELATED TO - ;; THE MACRO IDIOM OF THE SAME NAME - (list #`(... ...)) - (append (reconstruct-all-completed) (reconstruct)) - 'normal - #f #f))] + (send-step (list #'(... ...)) '() ; lhs + (reconstruct) (reconstruct-all-completed) ; rhs + 'normal #f #f) + (reset-held-exp-list)] [(struct held (held-exps held-step-was-app? held-posn-info)) - (let*-values - ([(step-kind) - (if (and held-step-was-app? - (eq? break-kind 'result-exp-break)) - 'user-application - 'normal)] - [(left-exps right-exps) - ;; write this later: - ;; (identify-changed - ;; (append held-finished-list held-exps) - ;; (append new-finished-list reconstructed)) - (values (append held-finished-list - held-exps) - (append (reconstruct-all-completed) - (reconstruct)))]) - - (send-result - (make-before-after-result - left-exps right-exps step-kind - held-posn-info - (mark-list->posn-info mark-list))))]))] + (send-step held-exps held-finished-list + (reconstruct) (reconstruct-all-completed) + (compute-step-kind held-step-was-app?) + held-posn-info (compute-posn-info)) + (reset-held-exp-list)]))] + ; CASE: double-break ------------------------------------------ [(double-break) ;; a double-break occurs at the beginning of a let's ;; evaluation. @@ -287,19 +352,30 @@ (let* ([new-finished-list (reconstruct-all-completed)] [reconstruct-result (r:reconstruct-double-break mark-list render-settings)] - [left-side (map (lambda (exp) (unwind exp render-settings)) - (maybe-lift (car reconstruct-result) #f))] - [right-side (map (lambda (exp) (unwind exp render-settings)) - (maybe-lift (cadr reconstruct-result) #t))]) - (let ([posn-info (mark-list->posn-info mark-list)]) - (receive-result - (make-before-after-result - (append new-finished-list left-side) - (append new-finished-list right-side) - 'normal - posn-info - posn-info))))] + [print-recon + (when DEBUG + (printf "LHS (pre-unwound):\n ~a\n" + (syntax->hilite-datum (car reconstruct-result))) + (printf "RHS (pre-unwound):\n ~a\n" + (syntax->hilite-datum (cadr reconstruct-result))))] + [lhs-unwound (map (lambda (exp) (unwind exp render-settings)) + (maybe-lift (car reconstruct-result) #f))] + [rhs-unwound (map (lambda (exp) (unwind exp render-settings)) + (maybe-lift (cadr reconstruct-result) #t))] + [print-unwound + (when DEBUG + (for-each (λ (x) (printf "LHS (unwound):\n ~a\n" + (syntax->hilite-datum x))) + lhs-unwound) + (for-each (λ (x) (printf "right side (unwound):\n ~a\n" + (syntax->hilite-datum x))) + rhs-unwound))]) + (send-step lhs-unwound new-finished-list + rhs-unwound new-finished-list + 'normal + (compute-posn-info) (compute-posn-info)))] + ; CASE: expr-finished-break ----------------------------------- [(expr-finished-break) (unless (not mark-list) (error 'break @@ -308,6 +384,17 @@ ;; (list/c source lifting-index getter)) this will now include ;; define-struct breaks, for which the source is the source ;; and the getter causes an error. + (when DEBUG + (for-each + (λ (x) + (printf "add to finished:\n") + (printf " source: ~a\n" (syntax->hilite-datum ((car x)))) + (printf " index: ~a\n" (second x)) + (printf " getter: ") + (if (stepper-syntax-property ((car x)) 'stepper-define-struct-hint) + (printf "no getter for term with stepper-define-struct-hint property\n") + (printf "~a\n" ((third x))))) + returned-value-list)) (for-each (lambda (source/index/getter) (apply add-to-finished source/index/getter)) returned-value-list)] diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index 6b49347995..2b3d0e9533 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -131,6 +131,16 @@ #`#,name)) (recon-source-expr (mark-source mark) (list mark) null null render-settings)))] + ; promise does not have annotation info, + ; must be from library code, or it's a running promise + [(promise? val) + (let ([partial-eval-promise + (hash-ref partially-evaluated-promises-table + val (λ () #f))]) + (or partial-eval-promise + (if (promise-forced? val) + (recon-value (force val) render-settings assigned-name) + 'promise)))] [else (let* ([rendered ((render-settings-render-to-sexp render-settings) val)]) @@ -156,6 +166,24 @@ ; unwraps struct or promise around procedure (define (unwrap-proc f) (extract-proc-if-promise (extract-proc-if-struct f))) + + ; nested-promise-running? : Indicates whether a promise is in the "running" + ; state. promise-running? in racket/private/promise.rkt only looks down + ; one level for a running promise + (define (nested-promise-running? p) + (if (promise? p) + (let ([v (pref p)]) + (or (running? v) + (and (promise? v) + (nested-promise-running? v)))) + (raise-type-error 'nested-promise-running? "promise" p))) + + ; weak hash table to keep track of partially evaluated promises + ; where keys = promises, values = syntax + ; - initialized on each call to reconstruct-current + ; (ie - each half-step reconstruction) + ; - populated on each call to recon-inner + (define partially-evaluated-promises-table null) ; ; ;;; @@ -226,9 +254,7 @@ (varref-skip-step? expr)])] [(#%top . id-stx) (varref-skip-step? #`id-stx)] - ; STC: this case can be removed if stepper automatically skips - ; duplicate steps - #;[(#%plain-app . terms) + [(#%plain-app . terms) ; don't halt for proper applications of constructors (let ([fun-val (lookup-binding mark-list (get-arg-var 0))]) (and (procedure? fun-val) @@ -264,7 +290,7 @@ (eq? (syntax->datum #'force) '!)) #'fn] [(#%plain-app fn . rest) #`fn] - [else (error 'find-special-name "couldn't find expanded name for ~a" name)])]) + [else (error 'find-special-name "couldn't find expanded name for ~a" name)])]) (eval (syntax-recertify just-the-fn expanded-application (current-code-inspector) #f)))) ;; these are delayed so that they use the userspace expander. I'm sure @@ -681,7 +707,7 @@ [top-mark (car mark-list)] [exp (mark-source top-mark)] [iota (lambda (x) (build-list x (lambda (x) x)))] - + [recon-let (lambda () (with-syntax ([(label ((vars rhs) ...) . bodies) exp]) @@ -749,6 +775,19 @@ bodies (iota (length bodies)))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) + + ; STC: cache any running promises in the top mark + ; means that promise is being evaluated + (let ([maybe-running-promise + (findf (λ (f) (and (promise? f) (nested-promise-running? f))) + (map mark-binding-value (mark-bindings top-mark)))]) + (when (and maybe-running-promise + (not (hash-has-key? partially-evaluated-promises-table + maybe-running-promise)) + (not (eq? so-far nothing-so-far))) + (hash-set! partially-evaluated-promises-table + maybe-running-promise so-far))) + (if (stepper-syntax-property exp 'stepper-fake-exp) (kernel:kernel-syntax-case exp #f @@ -802,7 +841,11 @@ (stepper-syntax-property (if (eq? so-far nothing-so-far) (datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur? - (datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))) + ; dont show ellipses for force + ; object-name is good enough here, so dont need to add another "special val" + (if (eq? (object-name (car arg-vals)) 'force) + so-far + (datum->syntax #'here `(,#'#%plain-app ... ,so-far ...)))) 'stepper-args-of-call rectified-evaluated)) (else @@ -948,34 +991,58 @@ returned-value-list)) (define answer - (case break-kind - ((left-side) - (let* ([innermost (if returned-value-list ; is it a normal-break/values? - (begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) - (error 'reconstruct "context expected one value, given ~v" returned-value-list)) - (recon-value (car returned-value-list) render-settings)) - nothing-so-far)]) - (recon innermost mark-list #t))) - ((right-side) - (let* ([innermost (if returned-value-list ; is it an expr -> value reduction? - (begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) - (error 'reconstruct "context expected one value, given ~v" returned-value-list)) - (recon-value (car returned-value-list) render-settings)) - (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))]) - (recon (mark-as-highlight innermost) (cdr mark-list) #f))) - ((double-break) - (let* ([source-expr (mark-source (car mark-list))] - [innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))] - [newly-lifted-bindings (syntax-case source-expr (letrec-values) - [(letrec-values ([vars . rest] ...) . bodies) - (apply append (map syntax->list (syntax->list #`(vars ...))))] - [(let-values ([vars . rest] ...) . bodies) - (apply append (map syntax->list (syntax->list #`(vars ...))))] - [else (error 'reconstruct "expected a let-values as source for a double-break, got: ~.s" - (syntax->datum source-expr))])] - [innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))]) - (list (recon innermost-before (cdr mark-list) #f) - (recon innermost-after (cdr mark-list) #f)))))) + (begin + ; STC: reset partial-eval-promise table on each call to recon + (set! partially-evaluated-promises-table (make-weak-hash)) + + (case break-kind + ((left-side) + (let* ([innermost + (if returned-value-list ; is it a normal-break/values? + (begin + (unless (and (pair? returned-value-list) + (null? (cdr returned-value-list))) + (error 'reconstruct + "context expected one value, given ~v" + returned-value-list)) + (recon-value (car returned-value-list) render-settings)) + nothing-so-far)]) + (recon innermost mark-list #t))) + ((right-side) + (let* ([innermost + (if returned-value-list ; is it an expr -> value reduction? + (begin + (unless (and (pair? returned-value-list) + (null? (cdr returned-value-list))) + (error 'reconstruct + "context expected one value, given ~v" + returned-value-list)) + (recon-value (car returned-value-list) render-settings)) + (recon-source-expr (mark-source (car mark-list)) + mark-list null null render-settings))]) + (recon (mark-as-highlight innermost) (cdr mark-list) #f))) + ((double-break) + (let* ([source-expr (mark-source (car mark-list))] + [innermost-before + (mark-as-highlight + (recon-source-expr source-expr mark-list null null render-settings))] + [newly-lifted-bindings + (syntax-case source-expr (letrec-values) + [(letrec-values ([vars . rest] ...) . bodies) + (apply append (map syntax->list (syntax->list #`(vars ...))))] + [(let-values ([vars . rest] ...) . bodies) + (apply append (map syntax->list (syntax->list #`(vars ...))))] + [else (error + 'reconstruct + "expected a let-values as source for a double-break, got: ~.s" + (syntax->datum source-expr))])] + [innermost-after + (mark-as-highlight + (recon-source-expr + (mark-source (car mark-list)) + mark-list null newly-lifted-bindings render-settings))]) + (list (recon innermost-before (cdr mark-list) #f) + (recon innermost-after (cdr mark-list) #f))))))) )