in stepper/private/reconstruct.rkt
- in recon-inner, called app case, add first fn to list of special lazy fns - in recon-value, add handling of running promises not found by recon-inner search - add optional so-far param to recon-value - add unknown-promises-table and add case in recon-value to handle in stepper/private/lazy-highlighting.rkt - add (first,0) pair in stepper/private/model.rkt - modify lazy fn "skipping" (from lazy-highlighting.rkt) to use the skips only when last-rhs-exp = null; o.w. skipping is handled solely by examining last-rhs-exp in tests/stepper/ - add take example from icfp paper - add tests for unknown promises
This commit is contained in:
Stephen Chang
parent
d04d3fadc3
commit
348a20c0e5
|
|
@ -36,6 +36,7 @@
|
|||
(cddadr . 1)
|
||||
(cdddar . 1)
|
||||
(cddddr . 0)
|
||||
(first . 0)
|
||||
(second . 0)
|
||||
(third . 0)
|
||||
(fourth . 0)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 "<DelayedEvaluation#" (number->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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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) <DelayedEvaluation#0>)})
|
||||
|
||||
; 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) <DelayedEvaluation#0>)})
|
||||
:: {(second (cons (+ 1 2) (cons (+ 3 4) <DelayedEvaluation#1>)))}
|
||||
-> {(+ 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) <DelayedEvaluation#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 (+ {(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 (+ 11 {(+ 7 8)}) -> ,def (+ 11 {15})
|
||||
:: ,def {(+ 11 15)} -> ,def {26}
|
||||
))
|
||||
|
||||
|
||||
#;
|
||||
(t1 'teachpack-callbacks
|
||||
(test-teachpack-sequence
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user