suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve lazy stepper recon of unannotated fn apps

Browse Source 
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
This commit is contained in:
Stephen Chang 2011-04-08 18:01:03 -04:00
parent 1028c669b7
commit 4ef7e1fae3
5 changed files with 72 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/stepper/private/macro-unwind.rkt
View File

@ -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

46
collects/stepper/private/model.rkt
View File

@ -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)]))

2
collects/stepper/private/reconstruct.rkt
View File

@ -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))

2
collects/tests/stepper/automatic-tests.rkt
View File

@ -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]

45
collects/tests/stepper/through-tests.rkt
View File

@ -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 {,(<delay#> 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 ,(<delay#> 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 {,(<delay#> 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 ,(<delay#> 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)
-> (+ {,(<delay#> 0)} 1000)
:: ... -> (+ {(+ 1 ,(<delay#> 1))} 1000)
:: ... -> (+ (+ 1 {(+ 2 ,(<delay#> 2))}) 1000)
:: ... -> (+ (+ 1 (+ 2 {(+ 3 ,(<delay#> 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