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
2011-04-05 17:29:34 -04:00 · 2011-04-05 17:29:34 -04:00 · c0f8f1cdb2
commit c0f8f1cdb2
parent 2227516673
5 changed files with 133 additions and 48 deletions
--- 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))
--- 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 
--- 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
+        ))
  
  
  
--- 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]
--- 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 (<delay#> n)
+     (string->symbol 
+      (string-append "<DelayedEvaluation#" (number->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) <DelayedEvaluation#0>)})
+      -> {(cons (+ 1 2) ,(<delay#> 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) <DelayedEvaluation#0>)})
-      :: {(second (cons (+ 1 2) (cons (+ 3 4) <DelayedEvaluation#1>)))}
+      -> (second {(cons (+ 1 2) ,(<delay#> 0))})
+      :: {(second (cons (+ 1 2) (cons (+ 3 4) ,(<delay#> 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) <DelayedEvaluation#1>))])
+          [arg-red `(cons (+ 3 4) (cons (+ 5 6) ,(<delay#> 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) <DelayedEvaluation#0>)}))
-        :: ,def ,(make-body `{(cdr (cons (+ 1 2) <DelayedEvaluation#0>))})
-        -> ,def ,(make-body `{<DelayedEvaluation#0>})
+        -> ,def ,(make-body `(cdr {(cons (+ 1 2) ,(<delay#> 0))}))
+        :: ,def ,(make-body `{(cdr (cons (+ 1 2) ,(<delay#> 0)))})
+        -> ,def ,(make-body `{,(<delay#> 0)})
        :: ,def (+ {(second ,arg-red)} (third ,arg-red))
        -> ,def (+ {(+ 5 6)} (third ,arg-red))
-        :: ,def (+ {(+ 5 6)} (third (cons (+ 3 4) (cons {(+ 5 6)} <DelayedEvaluation#1>))))
-        -> ,def (+ {11} (third (cons (+ 3 4) (cons {11} <DelayedEvaluation#1>))))
-        :: ,def (+ 11 {(third (cons (+ 3 4) (cons 11 <DelayedEvaluation#1>)))})
+        :: ,def (+ {(+ 5 6)} (third (cons (+ 3 4) (cons {(+ 5 6)} ,(<delay#> 1)))))
+        -> ,def (+ {11} (third (cons (+ 3 4) (cons {11} ,(<delay#> 1)))))
+        :: ,def (+ 11 {(third (cons (+ 3 4) (cons 11 ,(<delay#> 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 ,(<delay#> 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 ,(<delay#> 0))})))
+        (+ (second (cons 1 (map ,add1-lam {(cons 1 ,(<delay#> 0))}))) (third nats))
+        :: ,add1-def (define nats (cons 1 {(map ,add1-lam (cons 1 ,(<delay#> 0)))}))
+        (+ (second (cons 1 {(map ,add1-lam (cons 1 ,(<delay#> 0)))})) (third nats))
+        -> ,add1-def (define nats (cons 1 {(cons ,(<delay#> 1) ,(<delay#> 2))}))
+        (+ (second (cons 1 {(cons ,(<delay#> 1) ,(<delay#> 2))})) (third nats))
+        :: ,add1-def (define nats (cons 1 (cons ,(<delay#> 1) ,(<delay#> 2))))
+        (+ {(second (cons 1 (cons ,(<delay#> 1) ,(<delay#> 2))))} (third nats))
+        -> ,add1-def (define nats (cons 1 (cons ,(<delay#> 1) ,(<delay#> 2))))
+        (+ {,(<delay#> 1)} (third nats))
+        :: ,add1-def (define nats (cons 1 (cons {(+ 1 1)} ,(<delay#> 2))))
+        (+ {,(<delay#> 1)} (third nats))
+        -> ,add1-def (define nats (cons 1 (cons {(+ 1 1)} ,(<delay#> 2))))
+        (+ {(+ 1 1)} (third nats))
+        -> ,add1-def (define nats (cons 1 (cons {2} ,(<delay#> 2))))
+        (+ {2} (third nats))
+        :: ,add1-def (define nats (cons 1 (cons 2 ,(<delay#> 2))))
+        (+ 2 (third {nats}))
+        -> ,add1-def (define nats (cons 1 (cons 2 ,(<delay#> 2))))
+        (+ 2 (third {(cons 1 (cons 2 ,(<delay#> 2)))}))
+        :: ,add1-def (define nats (cons 1 (cons 2 ,(<delay#> 2))))
+        (+ 2 {(third (cons 1 (cons 2 ,(<delay#> 2))))})
+        -> ,add1-def (define nats (cons 1 (cons 2 (cons ,(<delay#> 3) ,(<delay#> 4)))))
+        (+ 2 {,(<delay#> 3)})
+        :: ,add1-def (define nats (cons 1 (cons 2 (cons {(+ 2 1)} ,(<delay#> 4)))))
+        (+ 2 {,(<delay#> 3)})
+        -> ,add1-def (define nats (cons 1 (cons 2 (cons {(+ 2 1)} ,(<delay#> 4)))))
+        (+ 2 {(+ 2 1)})
+        -> ,add1-def (define nats (cons 1 (cons 2 (cons {3} ,(<delay#> 4)))))
+        (+ 2 {3})
+        :: ,add1-def ,nats-def-expanded {(+ 2 3)}
+        -> ,add1-def ,nats-def-expanded {5}
+        ))
   
  #;
  (t1 'teachpack-callbacks