From c0f8f1cdb241953e997a49d2e4135cc238ec1ce4 Mon Sep 17 00:00:00 2001 From: Stephen Chang Date: Tue, 5 Apr 2011 17:29:34 -0400 Subject: [PATCH] lazy stepper working with infinite lists in stepper/private/marks.rkt - in mark-binding-value, add exception handler to catch undefined vars, so display-mark in break works with recursive fns in /tests/stepper/automatic-tests.rkt through-tests.rkt - add inf list example from icfp paper in stepper/private/model.rkt - refactor send-step to use cond instead of unless - in send-step, when highlight-stack = null and last-rhs != null (and lhs != last-rhs), send a step with lhs = last-rhs (previously skipped whenever highlight-stack = null) - basic filter example wasnt showing result without this - in icfp inf list example, this shows some intermediate forcing states - all other existing tests passed --- collects/stepper/private/marks.rkt | 3 +- collects/stepper/private/model.rkt | 93 ++++++++++++++-------- collects/stepper/private/reconstruct.rkt | 7 +- collects/tests/stepper/automatic-tests.rkt | 2 +- collects/tests/stepper/through-tests.rkt | 76 +++++++++++++++--- 5 files changed, 133 insertions(+), 48 deletions(-) diff --git a/collects/stepper/private/marks.rkt b/collects/stepper/private/marks.rkt index 6c26f3fef2..e56812d67c 100644 --- a/collects/stepper/private/marks.rkt +++ b/collects/stepper/private/marks.rkt @@ -90,7 +90,8 @@ (full-mark-struct-label (mark))) (define (mark-binding-value mark-binding) - ((cadr mark-binding))) + (with-handlers ([(λ (e) #t) (λ (e) "--- undefined ---")]) + ((cadr mark-binding)))) (define (mark-binding-binding mark-binding) (car mark-binding)) diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index b858cc430f..a2250c2b77 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -279,45 +279,68 @@ (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 (with-DEBUG - (and (step=? lhs-exps rhs-exps) - (when (not (step-and-highlight=? lhs-exps rhs-exps)) - (when DEBUG - (printf "Pushing onto highlight-stack:\n ~a thunk\n" - (syntax->hilite-datum (car lhs-exps)))) - (highlight-stack-push mark-list))) - "SKIPPING STEP (LHS = RHS)\n") - (and (step=? lhs-exps (list #'(... ...))) - (or (with-DEBUG - (step=? rhs-exps last-rhs-exps) - "SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n") - (with-DEBUG - (null? highlight-stack) - "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n") - (let ([skips (cdar highlight-stack)] - [lhs-thunk (caar highlight-stack)]) - (if (or (zero? skips) (not (null? last-rhs-exps))) - (begin - (set! lhs-exps (lhs-thunk)) - (set! lhs-finished-exps rhs-finished-exps) - (with-DEBUG - (highlight-stack-pop) - "Popping highlight-stack\n") - #f) - (highlight-stack-decrement)))))) + + (define (send-it) (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))) + (when DEBUG + (printf "step sent:\n") + (printf "LHS = ~a\n" (map syntax->hilite-datum lhs-exps)) + (printf "RHS = ~a\n" (map syntax->hilite-datum rhs-exps))) + (set! last-rhs-exps rhs-exps)) + + (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))) + + (cond + ; SKIPPING step, lhs = rhs + ; if highlights differ, push highlight-stack and set last-rhs-exp + [(step=? lhs-exps rhs-exps) + (when DEBUG (printf "SKIPPING STEP (LHS = RHS)\n")) + (when (not (step-and-highlight=? lhs-exps rhs-exps)) + (when DEBUG + (printf "Pushing onto highlight-stack:\n ~a thunk\n" + (syntax->hilite-datum (car lhs-exps)))) + (highlight-stack-push mark-list) + (set! last-rhs-exps rhs-exps))] + [(step=? lhs-exps (list #'(... ...))) + (cond + ; SKIPPING step, lhs = ellipses and rhs = last-rhs-exps + [(step=? rhs-exps last-rhs-exps) + (when DEBUG + (printf "SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n"))] + ; SKIPPING step, lhs = ellipses and highlight-stack = null and last-rhs = null + ; if last-rhs != null, send step + [(null? highlight-stack) + (if (not (null? last-rhs-exps)) + (begin + (set! lhs-exps last-rhs-exps) + (set! lhs-finished-exps rhs-finished-exps) + (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 + [else + (let ([skips (cdar highlight-stack)] + [lhs-thunk (caar highlight-stack)]) + (if (or (zero? skips) (not (null? last-rhs-exps))) + (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)))])] + ; sending step + [else (send-it)])) ; compares the lhs and rhs of a step (lists of syntaxes) ; and returns true if the underlying datums are equal @@ -369,6 +392,10 @@ (set! held-exp-list (create-held lhs-unwound)) (set! lhs-recon-thunk (λ () + (when DEBUG + (printf "\nforcing saved MARKLIST\n") + (for-each (λ (x) (printf "~a\n" (display-mark x))) mark-list) + (printf "saved RETURNED VALUE LIST: ~a\n" returned-value-list)) (map (λ (exp) (unwind exp render-settings)) (maybe-lift (r:reconstruct-left-side diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index 5015680f30..d760629627 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -149,7 +149,8 @@ val current-so-far) current-so-far] ; promise is not running if we get here - [(promise-forced? val) + [(and (promise-forced? val) + (not (nested-promise-running? val))) (recon-value (force val) render-settings assigned-name current-so-far)] ; unknown promise: promise not in src code, created in library fn [else @@ -1105,10 +1106,10 @@ mark-list null newly-lifted-bindings render-settings))]) (list (recon innermost-before (cdr mark-list) #f) (recon innermost-after (cdr mark-list) #f))))))) - ) - answer)) + answer + )) diff --git a/collects/tests/stepper/automatic-tests.rkt b/collects/tests/stepper/automatic-tests.rkt index 0ec1b59bb0..798206ef89 100644 --- a/collects/tests/stepper/automatic-tests.rkt +++ b/collects/tests/stepper/automatic-tests.rkt @@ -14,7 +14,7 @@ lazy-cddadr lazy-cdddar lazy-cddddr lazy-second lazy-third lazy-fourth lazy-fifth lazy-sixth lazy-seventh lazy-eighth lazy-if1 lazy-if2 lazy-take-0 lazy-take lazy-take-impl - lazy-unknown1 lazy-unknown2)) + lazy-unknown1 lazy-unknown2 lazy-inf-list1)) (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 4629d8986d..745717fbbd 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -1746,13 +1746,17 @@ (t 'lazy-take-0 m:lazy ,e :: {,e} -> {empty})) + (define ( n) + (string->symbol + (string-append "string n) ">"))) + ; lazy-take (t 'lazy-take m:lazy (take (+ 0 2) (list (+ 1 2) (+ 3 4) (/ 1 0))) :: (take {(+ 0 2)} (list (+ 1 2) (+ 3 4) (/ 1 0))) -> (take {2} (list (+ 1 2) (+ 3 4) (/ 1 0))) :: {(take 2 (list (+ 1 2) (+ 3 4) (/ 1 0)))} - -> {(cons (+ 1 2) )}) + -> {(cons (+ 1 2) ,( 0))}) ; lazy-take-impl ; (define (take-n n lst) @@ -1836,8 +1840,8 @@ (t 'lazy-unknown1 m:lazy (second (take 3 (list (+ 1 2) (+ 3 4) (/ 1 0)))) :: (second {(take 3 (list (+ 1 2) (+ 3 4) (/ 1 0)))}) - -> (second {(cons (+ 1 2) )}) - :: {(second (cons (+ 1 2) (cons (+ 3 4) )))} + -> (second {(cons (+ 1 2) ,( 0))}) + :: {(second (cons (+ 1 2) (cons (+ 3 4) ,( 1))))} -> {(+ 3 4)} -> {7}) ; lazy-unknown2 @@ -1847,24 +1851,76 @@ [lam `(lambda (x) ,body)] [subarg `(take 4 (list (+ 1 2) (+ 3 4) (+ 5 6) (+ 7 8) (/ 1 0)))] [arg `(cdr ,subarg)] - [arg-red '(cons (+ 3 4) (cons (+ 5 6) ))]) + [arg-red `(cons (+ 3 4) (cons (+ 5 6) ,( 1)))]) (t 'lazy-unknown2 m:lazy ,def (f ,arg) :: ,def ({f} ,arg) -> ,def ({,lam} ,arg) :: ,def {(,lam ,arg)} -> ,def {,(make-body arg)} :: ,def ,(make-body `(cdr {,subarg})) - -> ,def ,(make-body `(cdr {(cons (+ 1 2) )})) - :: ,def ,(make-body `{(cdr (cons (+ 1 2) ))}) - -> ,def ,(make-body `{}) + -> ,def ,(make-body `(cdr {(cons (+ 1 2) ,( 0))})) + :: ,def ,(make-body `{(cdr (cons (+ 1 2) ,( 0)))}) + -> ,def ,(make-body `{,( 0)}) :: ,def (+ {(second ,arg-red)} (third ,arg-red)) -> ,def (+ {(+ 5 6)} (third ,arg-red)) - :: ,def (+ {(+ 5 6)} (third (cons (+ 3 4) (cons {(+ 5 6)} )))) - -> ,def (+ {11} (third (cons (+ 3 4) (cons {11} )))) - :: ,def (+ 11 {(third (cons (+ 3 4) (cons 11 )))}) + :: ,def (+ {(+ 5 6)} (third (cons (+ 3 4) (cons {(+ 5 6)} ,( 1))))) + -> ,def (+ {11} (third (cons (+ 3 4) (cons {11} ,( 1))))) + :: ,def (+ 11 {(third (cons (+ 3 4) (cons 11 ,( 1))))}) -> ,def (+ 11 {(+ 7 8)}) -> ,def (+ 11 {15}) :: ,def {(+ 11 15)} -> ,def {26} )) + ; lazy-inf-list1 +; (define (add-one x) (+ x 1)) +; (define nats (cons 1 (map add-one nats))) +; (+ (second nats) (third nats)) + (let* ([add1-body '(+ x 1)] + [add1-def `(define (add-one x) ,add1-body)] + [add1-lam `(lambda (x) ,add1-body)] + [nats-def '(define nats (cons 1 (map add-one nats)))] + [nats-def-expanded `(define nats (cons 1 (cons 2 (cons 3 ,( 4)))))]) + (t 'lazy-inf-list1 m:lazy + ,add1-def ,nats-def (+ (second nats) (third nats)) + :: ,add1-def ,nats-def (+ (second {nats}) (third nats)) + -> ,add1-def ,nats-def (+ (second {(cons 1 (map add-one nats))}) (third nats)) + :: ,add1-def (define nats (cons 1 (map {add-one} nats))) + (+ (second (cons 1 (map {add-one} nats))) (third nats)) + -> ,add1-def (define nats (cons 1 (map {,add1-lam} nats))) + (+ (second (cons 1 (map {,add1-lam} nats))) (third nats)) + :: ,add1-def (define nats (cons 1 (map ,add1-lam {nats}))) + (+ (second (cons 1 (map ,add1-lam {nats}))) (third nats)) + -> ,add1-def (define nats (cons 1 (map ,add1-lam {(cons 1 ,( 0))}))) + (+ (second (cons 1 (map ,add1-lam {(cons 1 ,( 0))}))) (third nats)) + :: ,add1-def (define nats (cons 1 {(map ,add1-lam (cons 1 ,( 0)))})) + (+ (second (cons 1 {(map ,add1-lam (cons 1 ,( 0)))})) (third nats)) + -> ,add1-def (define nats (cons 1 {(cons ,( 1) ,( 2))})) + (+ (second (cons 1 {(cons ,( 1) ,( 2))})) (third nats)) + :: ,add1-def (define nats (cons 1 (cons ,( 1) ,( 2)))) + (+ {(second (cons 1 (cons ,( 1) ,( 2))))} (third nats)) + -> ,add1-def (define nats (cons 1 (cons ,( 1) ,( 2)))) + (+ {,( 1)} (third nats)) + :: ,add1-def (define nats (cons 1 (cons {(+ 1 1)} ,( 2)))) + (+ {,( 1)} (third nats)) + -> ,add1-def (define nats (cons 1 (cons {(+ 1 1)} ,( 2)))) + (+ {(+ 1 1)} (third nats)) + -> ,add1-def (define nats (cons 1 (cons {2} ,( 2)))) + (+ {2} (third nats)) + :: ,add1-def (define nats (cons 1 (cons 2 ,( 2)))) + (+ 2 (third {nats})) + -> ,add1-def (define nats (cons 1 (cons 2 ,( 2)))) + (+ 2 (third {(cons 1 (cons 2 ,( 2)))})) + :: ,add1-def (define nats (cons 1 (cons 2 ,( 2)))) + (+ 2 {(third (cons 1 (cons 2 ,( 2))))}) + -> ,add1-def (define nats (cons 1 (cons 2 (cons ,( 3) ,( 4))))) + (+ 2 {,( 3)}) + :: ,add1-def (define nats (cons 1 (cons 2 (cons {(+ 2 1)} ,( 4))))) + (+ 2 {,( 3)}) + -> ,add1-def (define nats (cons 1 (cons 2 (cons {(+ 2 1)} ,( 4))))) + (+ 2 {(+ 2 1)}) + -> ,add1-def (define nats (cons 1 (cons 2 (cons {3} ,( 4))))) + (+ 2 {3}) + :: ,add1-def ,nats-def-expanded {(+ 2 3)} + -> ,add1-def ,nats-def-expanded {5} + )) #; (t1 'teachpack-callbacks