From 4ef7e1fae3a4af0231da79dd127bf67ba294428c Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Fri, 8 Apr 2011 18:01:03 -0400 Subject: [PATCH] improve lazy stepper recon of unannotated fn apps remove stepper/private/lazy-highlighting.rkt in stepper/private/macro-unwind.rkt: - in fall-through, add lazy-proc to lazy #%app special case in stepper/private/model.rkt - in send-step, dont use highlight-table, just match top called fn in mark-list instead in tests/stepper/ - add lazy stepper tests for filter and fold --- collects/stepper/private/macro-unwind.rkt | 14 +++---- collects/stepper/private/model.rkt | 46 +++++++++------------- collects/stepper/private/reconstruct.rkt | 2 - collects/tests/stepper/automatic-tests.rkt | 2 +- collects/tests/stepper/through-tests.rkt | 45 +++++++++++++++++++++ 5 files changed, 72 insertions(+), 37 deletions(-) diff --git a/collects/stepper/private/macro-unwind.rkt b/collects/stepper/private/macro-unwind.rkt index 3513bc10e3..1a61e925c6 100644 --- a/collects/stepper/private/macro-unwind.rkt +++ b/collects/stepper/private/macro-unwind.rkt @@ -68,13 +68,13 @@ (syntax-e (second (syntax-e #'proc-extract)))) procedure-extract-target)) (unwind #'p settings)] - ; lazy #%app special case: force - [(#%plain-app force arg) - (let ([force-fn (syntax->datum #'force)]) - (or (eq? force-fn 'force) - (eq? force-fn '!) (eq? force-fn '!!) - (eq? force-fn '!list) (eq? force-fn '!!list) - (equal? force-fn '(#%plain-app parameter-procedure)))) + ; lazy #%app special case: force and delay + [(#%plain-app f arg) + (let ([fn (syntax->datum #'f)]) + (or (eq? fn 'lazy-proc) + (eq? fn 'force) (eq? fn '!) (eq? fn '!!) + (eq? fn '!list) (eq? fn '!!list) + (equal? fn '(#%plain-app parameter-procedure)))) (unwind #'arg settings)] ; general lazy application [(#%plain-app diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index 7771c39787..ccebdd9328 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -54,8 +54,8 @@ ;; for breakpoint display ;; (commented out to allow nightly testing) #;"display-break-stuff.ss" - (for-syntax scheme/base) - "lazy-highlighting.rkt") + (for-syntax scheme/base)) + (define program-expander-contract ((-> void?) ; init @@ -128,31 +128,21 @@ ; # of skips depends on # of hidden !'s in fn def (define highlight-stack null) (define (highlight-stack-push mark-list) - (let* ([mark (find-first-called mark-list)] - [fn (object-name (lookup-binding (list mark) (get-arg-var 0)))] - [skips (hash-ref highlight-table fn)]) + (let ([top-called-fn (find-top-called-fn mark-list)]) (when DEBUG - (printf "skips for ~a = ~a\n" fn skips)) - (set! highlight-stack - (cons (cons lhs-recon-thunk skips) highlight-stack)))) - (define (find-first-called mark-list) + (printf "top called fn = ~a\n" top-called-fn)) + (set! highlight-stack + (cons (cons top-called-fn lhs-recon-thunk) highlight-stack)))) + (define (find-top-called-fn mark-list) (if (null? mark-list) #f (let ([top-mark (car mark-list)]) (if (eq? 'called (mark-label top-mark)) - top-mark - (find-first-called (cdr mark-list)))))) + (object-name (lookup-binding (list top-mark) (get-arg-var 0))) + (find-top-called-fn (cdr mark-list)))))) (define (highlight-stack-pop) (set! highlight-stack (cdr highlight-stack))) - (define (highlight-stack-decrement) - (let ([new-skips (sub1 (cdar highlight-stack))] - [thunk (caar highlight-stack)]) - (printf - "SKIPPING SKIP (decrementing top of highlight-stack, skips = ~a)\n" - new-skips) - (set! highlight-stack - (cons (cons thunk new-skips) - (cdr highlight-stack))))) + ;; highlight-mutated-expressions : @@ -322,20 +312,22 @@ (send-it) (when DEBUG (printf "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n")))] - ; if last-rhs != null, send step - ; else if skips = 0, send step - ; else skip + ; if top-called-fn = top of highlight stack, + ; then send step with lhs = lhs-thunk on highlight stack + ; else if last-rhs != null, send it, else skip [else - (let ([skips (cdar highlight-stack)] - [lhs-thunk (caar highlight-stack)]) - (if (or (zero? skips) (not (null? last-rhs-exps))) + (let ([top-called-fn (caar highlight-stack)] + [lhs-thunk (cdar highlight-stack)]) + (if (and (eq? (find-top-called-fn mark-list) top-called-fn) + (eq? break-kind 'result-value-break)) (begin (set! lhs-exps (lhs-thunk)) (set! lhs-finished-exps rhs-finished-exps) (when DEBUG (printf "Popping highlight-stack\n")) (highlight-stack-pop) (send-it)) - (highlight-stack-decrement)))])] + (when (not (null? last-rhs-exps)) + (send-it))))])] ; sending step [else (send-it)])) diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index 34c5849ddb..19d143c6c2 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -193,8 +193,6 @@ ; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket (define (extract-proc-if-struct f) (if (and (procedure? f) (not (annotated-proc? f))) - #;(let ([extracted (procedure-extract-target f)]) - (if extracted extracted f)) (or (procedure-extract-target f) f) f)) diff --git a/collects/tests/stepper/automatic-tests.rkt b/collects/tests/stepper/automatic-tests.rkt index f3b0be7f20..3d6bc9d14f 100644 --- a/collects/tests/stepper/automatic-tests.rkt +++ b/collects/tests/stepper/automatic-tests.rkt @@ -17,7 +17,7 @@ lazy-eq? lazy-eqv? lazy-equal? lazy-list?1 lazy-list?2 lazy-list?3 lazy-length lazy-list-ref lazy-list-tail lazy-append lazy-reverse lazy-empty? lazy-assoc lazy-assq lazy-assv lazy-cons? lazy-remove lazy-remq lazy-remv - lazy-member lazy-memq lazy-memv)) + lazy-member lazy-memq lazy-memv lazy-filter1 lazy-filter2 lazy-fold)) (let ((outer-namespace (current-namespace))) (parameterize ([display-only-errors #t] diff --git a/collects/tests/stepper/through-tests.rkt b/collects/tests/stepper/through-tests.rkt index e58c523367..7c38526de9 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -2075,7 +2075,52 @@ :: {(memv 1 (list 1 2))} -> {(list 1 2)}) + (t 'lazy-filter1 m:lazy + (third (filter (lambda (x) (>= x 3)) '(1 2 3 4 5))) + :: (third {(filter (lambda (x) (>= x 3)) (list 1 2 3 4 5))}) + -> (third (... {(>= 1 3)} ...)) + -> (third (... {false} ...)) + :: ... -> (third {,( 0)}) + :: ... -> (third {(>= 2 3)}) -> (third {false}) + :: ... -> (third {(>= 3 3)}) -> (third {true}) + :: ... -> (third (cons 3 {(>= 4 3)})) -> (third (cons 3 {true})) + :: ... -> (third (cons 3 (cons 4 {(>= 5 3)}))) + -> (third (cons 3 (cons 4 {true}))) + :: {(third (cons 3 (cons 4 (cons 5 ,( 1)))))} -> {5}) + ; same as lazy-filter1 except forcing of the list itself shows up as a step + ; only difference is in lazy-filter1 a quote (') is used while in lazy-filter2 + ; a list constructor is used + (t 'lazy-filter2 m:lazy + (third (filter (lambda (x) (>= x 3)) (list 1 2 3 4 5))) + :: (third {(filter (lambda (x) (>= x 3)) (list 1 2 3 4 5))}) + -> (third (... {(list 1 2 3 4 5)} ...)) + :: ... -> (third (... {(>= 1 3)} ...)) -> (third (... {false} ...)) + :: ... -> (third {,( 0)}) + :: ... -> (third {(>= 2 3)}) -> (third {false}) + :: ... -> (third {(>= 3 3)}) -> (third {true}) + :: ... -> (third (cons 3 {(>= 4 3)})) -> (third (cons 3 {true})) + :: ... -> (third (cons 3 (cons 4 {(>= 5 3)}))) + -> (third (cons 3 (cons 4 {true}))) + :: {(third (cons 3 (cons 4 (cons 5 ,( 1)))))} -> {5}) + + (t 'lazy-fold m:lazy + (+ (foldr (lambda (x y) (+ x y)) 0 '(1 2 3)) 1000) + :: (+ {(foldr (lambda (x y) (+ x y)) 0 (list 1 2 3))} 1000) + -> (+ {,( 0)} 1000) + :: ... -> (+ {(+ 1 ,( 1))} 1000) + :: ... -> (+ (+ 1 {(+ 2 ,( 2))}) 1000) + :: ... -> (+ (+ 1 (+ 2 {(+ 3 ,( 3))})) 1000) + :: (+ (+ 1 (+ 2 {(+ 3 0)})) 1000) + -> (+ (+ 1 (+ 2 {3})) 1000) + :: (+ (+ 1 {(+ 2 3)}) 1000) + -> (+ (+ 1 {5}) 1000) + :: (+ {(+ 1 5)} 1000) + -> (+ {6} 1000) + :: {(+ 6 1000)} -> {1006}) + + + #; (t1 'teachpack-callbacks