diff --git a/collects/stepper/private/lazy-highlighting.rkt b/collects/stepper/private/lazy-highlighting.rkt index a5273397ec..58a149b694 100644 --- a/collects/stepper/private/lazy-highlighting.rkt +++ b/collects/stepper/private/lazy-highlighting.rkt @@ -36,6 +36,7 @@ (cddadr . 1) (cdddar . 1) (cddddr . 0) + (first . 0) (second . 0) (third . 0) (fourth . 0) diff --git a/collects/stepper/private/model.rkt b/collects/stepper/private/model.rkt index b695dd6b74..b858cc430f 100644 --- a/collects/stepper/private/model.rkt +++ b/collects/stepper/private/model.rkt @@ -86,7 +86,7 @@ #:disable-error-handling? [disable-error-handling? #f] #:raw-step-receiver [raw-step-receiver #f]) - (define DEBUG #t) + (define DEBUG #f) ;; finished-exps: ;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) @@ -131,7 +131,8 @@ (let* ([mark (find-first-called mark-list)] [fn (object-name (lookup-binding (list mark) (get-arg-var 0)))] [skips (hash-ref highlight-table fn)]) - (printf "skips for ~a = ~a\n" fn skips) + (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) @@ -144,10 +145,14 @@ (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 (caar highlight-stack) - (sub1 (cdar highlight-stack))) - (cdr highlight-stack)))) + (cons (cons thunk new-skips) + (cdr highlight-stack))))) ;; highlight-mutated-expressions : @@ -296,7 +301,7 @@ "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n") (let ([skips (cdar highlight-stack)] [lhs-thunk (caar highlight-stack)]) - (if (zero? skips) + (if (or (zero? skips) (not (null? last-rhs-exps))) (begin (set! lhs-exps (lhs-thunk)) (set! lhs-finished-exps rhs-finished-exps) @@ -304,9 +309,7 @@ (highlight-stack-pop) "Popping highlight-stack\n") #f) - (with-DEBUG - (highlight-stack-decrement) - "SKIPPING SKIP (decrementing top of highlight-stack)\n")))))) + (highlight-stack-decrement)))))) (receive-result (make-before-after-result (append lhs-finished-exps lhs-exps) diff --git a/collects/stepper/private/reconstruct.rkt b/collects/stepper/private/reconstruct.rkt index 3681e362ff..d03a6aedd4 100644 --- a/collects/stepper/private/reconstruct.rkt +++ b/collects/stepper/private/reconstruct.rkt @@ -107,7 +107,7 @@ ; of a let, or unless there _is_ no name. (define recon-value - (opt-lambda (val render-settings [assigned-name #f]) + (opt-lambda (val render-settings [assigned-name #f] [current-so-far nothing-so-far]) (if (hash-ref finished-xml-box-table val (lambda () #f)) (stepper-syntax-property #`(quote #,val) 'stepper-xml-value-hint 'from-xml-box) (let* ([extracted-proc (unwrap-proc val)] @@ -140,24 +140,45 @@ ; can be an extra promise layer when dealing with lists (hash-ref partially-evaluated-promises-table (pref val) (λ () #f)))]) - (or partial-eval-promise - (if (promise-forced? val) - (recon-value (force val) render-settings assigned-name) - 'promise)))] + (cond [partial-eval-promise partial-eval-promise] + ; running promise not found by search in recon-inner + ; must be a nested running promise + [(and (nested-promise-running? val) + (not (eq? current-so-far nothing-so-far))) + (hash-set! partially-evaluated-promises-table + val current-so-far) + current-so-far] + ; promise is not running if we get here + [(promise-forced? val) + (recon-value (force val) render-settings assigned-name current-so-far)] + ; unknown promise: promise not in src code, created in library fn + [else + (let ([unknown-promise + (hash-ref unknown-promises-table + val (λ () #f))]) + (if unknown-promise + (render-unknown-promise unknown-promise) + ; else generate a fresh unknown promise + (begin0 + (render-unknown-promise next-unknown-promise) + (hash-set! unknown-promises-table + val next-unknown-promise) + (set! next-unknown-promise + (add1 next-unknown-promise)))))]))] ; STC: handle lists here, instead of deferring to render-to-sexp fn ; because there may be nested promises [(null? val) #'empty] [(list? val) (with-syntax ([(reconed-vals ...) - (map (lx (recon-value _ render-settings assigned-name)) val)]) + (map (lx (recon-value _ render-settings assigned-name current-so-far)) val)]) #'(#%plain-app list reconed-vals ...))] [(pair? val) (with-syntax ([reconed-car - (recon-value (car val) render-settings assigned-name)] + (recon-value (car val) render-settings assigned-name current-so-far)] [reconed-cdr - (recon-value (cdr val) render-settings assigned-name)]) + (recon-value (cdr val) render-settings assigned-name current-so-far)]) #'(#%plain-app cons reconed-car reconed-cdr))] [else (let* ([rendered @@ -166,7 +187,7 @@ #`#,rendered #`(quote #,rendered)))]))))) -; STC: helper fns to recon thunks in recon-value +; STC: helper fns for recon-value, to reconstruct promises ; extract-proc-if-struct : any -> procedure? or any ; Purpose: extracts closure from struct procedure, ie lazy-proc in lazy racket (define (extract-proc-if-struct f) @@ -203,6 +224,15 @@ ; - populated on each call to recon-inner (define partially-evaluated-promises-table null) + ; unknown-promises-table : keep track of unknown promises + ; ie, promises created from lib fns + (define unknown-promises-table null) + (define next-unknown-promise 0) + + ;; NaturalNumber -> syntax + (define (render-unknown-promise x) + #`(quote #,(string->symbol + (string-append "string x) ">")))) ; ; ;;; ; ; ; @@ -318,7 +348,9 @@ (define (reset-special-values) (set! special-list-value (find-special-value 'list '(3))) - (set! special-cons-value (find-special-value 'cons '(3 empty)))) + (set! special-cons-value (find-special-value 'cons '(3 empty))) + (set! unknown-promises-table (make-weak-hash)) + (set! next-unknown-promise 0)) (define (second-arg-is-list? mark-list) (let ([arg-val (lookup-binding mark-list (get-arg-var 2))]) @@ -795,7 +827,10 @@ (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) ; STC: cache any running promises in the top mark - ; means that promise is being evaluated + ; Means that promise is being evaluated. + ; NOTE: This wont wind running promises nested in another promise. + ; Those wont be detected until the outer promise is being + ; reconed, so we cant handle it until then. (let ([maybe-running-promise (findf (λ (f) (and (promise? f) (nested-promise-running? f))) (map mark-binding-value (mark-bindings top-mark)))]) @@ -846,7 +881,8 @@ arg-temps)] [(vector 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))]) + [rectified-evaluated (map (lx (recon-value _ render-settings #f so-far)) + (map cadr evaluated))]) (case (mark-label (car mark-list)) ((not-yet-called) (if (null? unevaluated) @@ -859,7 +895,7 @@ (stepper-syntax-property (if (eq? so-far nothing-so-far) (datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur? - ; dont show ellipses for force + ; dont show ellipses for force (and other lazy fns) ; object-name is good enough here, so dont need to add another "special val" (let ([obj-name (object-name (car arg-vals))]) (cond [(eq? obj-name 'force) so-far] @@ -868,9 +904,8 @@ '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - second third fourth fifth sixth seventh eighth)) - #`(#%plain-app #,(datum->syntax #'here obj-name) #,so-far)] - [(eq? obj-name 'take) #`(#%plain-app . #,rectified-evaluated)] + first second third fourth fifth sixth seventh eighth take)) + #`(#%plain-app . #,rectified-evaluated)] [else (datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))]))) 'stepper-args-of-call diff --git a/collects/tests/stepper/automatic-tests.rkt b/collects/tests/stepper/automatic-tests.rkt index ff92199015..0ec1b59bb0 100644 --- a/collects/tests/stepper/automatic-tests.rkt +++ b/collects/tests/stepper/automatic-tests.rkt @@ -13,7 +13,8 @@ lazy-cadddr lazy-cdaaar lazy-cdaadr lazy-cdadar lazy-cdaddr lazy-cddaar 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-if1 lazy-if2 lazy-take-0 lazy-take lazy-take-impl + lazy-unknown1 lazy-unknown2)) (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 53db91c106..4629d8986d 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -1747,17 +1747,125 @@ ,e :: {,e} -> {empty})) ; lazy-take - ; FIXME: when unknown promises implemented (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) promise)}) + -> {(cons (+ 1 2) )}) + + ; lazy-take-impl +; (define (take-n n lst) +; (if (= n 0) +; null +; (cons (first lst) +; (take-n (- n 1) (rest lst))))) +; (define (f lst) (+ (first lst) (second lst))) +; (f (take-n 3 (list 1 2 (/ 1 0) 4))) + (let* ([make-take-body + (λ (n lst) + `(if (= ,n 0) null + (cons (first ,lst) + (take-n (- ,n 1) (rest ,lst)))))] + [take-body (make-take-body 'n 'lst)] + [take-def `(define (take-n n lst) ,take-body)] + [take-lam `(lambda (n lst) ,take-body)] + [make-f-body (λ (lst) `(+ (first ,lst) (second ,lst)))] + [f-body (make-f-body 'lst)] + [f-def `(define (f lst) ,f-body)] + [f-lam `(lambda (lst) ,f-body)] + [lst-arg `(list (+ 1 2) (+ 3 4) ,err (+ 5 6))] + [lst-arg-red1 `(list 3 (+ 3 4) ,err (+ 5 6))] + [make-take-app (λ (n lst) `(take-n ,n ,lst))] + [take-arg (make-take-app 3 lst-arg)]) + (t 'lazy-take-impl m:lazy + ,take-def ,f-def (f ,take-arg) + :: ,take-def ,f-def ({f} ,take-arg) -> ,take-def ,f-def ({,f-lam} ,take-arg) + :: ,take-def ,f-def {(,f-lam ,take-arg)} -> ,take-def ,f-def {,(make-f-body take-arg)} + :: ,take-def ,f-def ,(make-f-body `({take-n} 3 ,lst-arg)) + -> ,take-def ,f-def ,(make-f-body `({,take-lam} 3 ,lst-arg)) + :: ,take-def ,f-def ,(make-f-body `{(,take-lam 3 ,lst-arg)}) + -> ,take-def ,f-def ,(make-f-body `{,(make-take-body 3 lst-arg)}) + :: ,take-def ,f-def ,(make-f-body `(if {(= 3 0)} null + (cons (first ,lst-arg) + (take-n (- 3 1) (rest ,lst-arg))))) + -> ,take-def ,f-def ,(make-f-body `(if {false} null + (cons (first ,lst-arg) + (take-n (- 3 1) (rest ,lst-arg))))) + :: ,take-def ,f-def ,(make-f-body `{(if false null + (cons (first ,lst-arg) + (take-n (- 3 1) (rest ,lst-arg))))}) + -> ,take-def ,f-def ,(make-f-body `{(cons (first ,lst-arg) ,(make-take-app '(- 3 1) `(rest ,lst-arg)))}) + :: ,take-def ,f-def (+ {(first (cons (first ,lst-arg) ,(make-take-app '(- 3 1) `(rest ,lst-arg))))} + (second (cons (first ,lst-arg) ,(make-take-app '(- 3 1) `(rest ,lst-arg))))) + -> ,take-def ,f-def (+ {(first ,lst-arg)} + (second (cons (first ,lst-arg) ,(make-take-app '(- 3 1) `(rest ,lst-arg))))) + :: ,take-def ,f-def (+ {(first ,lst-arg)} + (second (cons {(first ,lst-arg)} ,(make-take-app '(- 3 1) `(rest ,lst-arg))))) + -> ,take-def ,f-def (+ {(+ 1 2)} + (second (cons {(+ 1 2)} ,(make-take-app '(- 3 1) `(rest ,lst-arg))))) + :: ,take-def ,f-def (+ {(+ 1 2)} + (second (cons {(+ 1 2)} ,(make-take-app '(- 3 1) `(rest (list {(+ 1 2)} (+ 3 4) ,err (+ 5 6))))))) + -> ,take-def ,f-def (+ {3} + (second (cons {3} ,(make-take-app '(- 3 1) `(rest (list {3} (+ 3 4) ,err (+ 5 6))))))) + :: ,take-def ,f-def (+ 3 (second (cons 3 ({take-n} (- 3 1) (rest ,lst-arg-red1))))) + -> ,take-def ,f-def (+ 3 (second (cons 3 ({,take-lam} (- 3 1) (rest ,lst-arg-red1))))) + :: ,take-def ,f-def (+ 3 (second (cons 3 {(,take-lam (- 3 1) (rest ,lst-arg-red1))}))) + -> ,take-def ,f-def (+ 3 (second (cons 3 {,(make-take-body '(- 3 1) `(rest ,lst-arg-red1))}))) + :: ,take-def ,f-def (+ 3 (second (cons 3 ,(make-take-body '{(- 3 1)} `(rest ,lst-arg-red1))))) + -> ,take-def ,f-def (+ 3 (second (cons 3 ,(make-take-body '{2} `(rest ,lst-arg-red1))))) + :: ,take-def ,f-def (+ 3 (second (cons 3 (if {(= 2 0)} null (cons (first (rest ,lst-arg-red1)) + (take-n (- 2 1) (rest (rest ,lst-arg-red1)))))))) + -> ,take-def ,f-def (+ 3 (second (cons 3 (if {false} null (cons (first (rest ,lst-arg-red1)) + (take-n (- 2 1) (rest (rest ,lst-arg-red1)))))))) + :: ,take-def ,f-def (+ 3 (second (cons 3 {(if false null (cons (first (rest ,lst-arg-red1)) + (take-n (- 2 1) (rest (rest ,lst-arg-red1)))))}))) + -> ,take-def ,f-def (+ 3 (second (cons 3 {(cons (first (rest ,lst-arg-red1)) + (take-n (- 2 1) (rest (rest ,lst-arg-red1))))}))) + :: ,take-def ,f-def (+ 3 {(second (cons 3 (cons (first (rest ,lst-arg-red1)) + (take-n (- 2 1) (rest (rest ,lst-arg-red1))))))}) + -> ,take-def ,f-def (+ 3 {(first (rest ,lst-arg-red1))}) + :: ,take-def ,f-def (+ 3 (first {(rest ,lst-arg-red1)})) + -> ,take-def ,f-def (+ 3 (first {(list (+ 3 4) (/ 1 0) (+ 5 6))})) + :: ,take-def ,f-def (+ 3 {(first (list (+ 3 4) (/ 1 0) (+ 5 6)))}) + -> ,take-def ,f-def (+ 3 {(+ 3 4)}) -> ,take-def ,f-def (+ 3 {7}) + :: ,take-def ,f-def {(+ 3 7)} -> ,take-def ,f-def {10} + )) + ; lazy-unknown1 + (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) )))} + -> {(+ 3 4)} -> {7}) - - + ; lazy-unknown2 + (let* ([make-body (λ (x) `(+ (second ,x) (third ,x)))] + [body (make-body 'x)] + [def `(define (f x) ,body)] + [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) ))]) + (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 (+ {(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 (+ 11 {(+ 7 8)}) -> ,def (+ 11 {15}) + :: ,def {(+ 11 15)} -> ,def {26} + )) + + #; (t1 'teachpack-callbacks (test-teachpack-sequence