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

simple example working: (define (f x) (+ x x)) (f (+ 1 2))

Browse Source 
in stepper/private/model.rkt
- add debugging outputs
- reformat code

in stepper/private/macro-unwind.rkt:
- in fall-through
  - add case for lazy racket app
  - add case for procedure-extract-target
- in unwind, change recur procedure for fn hints to unwind
  (was recur-on-pieces)

in racket/private/promise.rkt
- add unwind fn as stepper-hint syntax property

in stepper/private/reconstruct.rkt
- add constructor application case back
- in recon-inner
  - in app called case, dont show ellipses for force
  - initialize partially-eval-promise table
  - reformat answer code
  - add caching of running promises
- in recon-value, add reconstructing of partially evaluated promises

in stepper-private/annotate.rkt
- in annotate/module-top-level, add lazy racket top level case - to hide top
  level forcer

in lazy/lazy.rkt
- use hidden-~ and hidden-! instead of ~ and !
This commit is contained in:
Stephen Chang 2011-04-02 15:47:29 -04:00
parent 2d204dc6ea
commit 6921960c5e
6 changed files with 403 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
collects/lazy/lazy.rkt
View File

@ -55,6 +55,28 @@
(define-for-syntax strict-names (define-for-syntax strict-names
(syntax->list #'(! !! !list !!list !values !!values))) (syntax->list #'(! !! !list !!list !values !!values)))
;; --------------------------------------------------------------------------
;; Stepper utility fns
(define-for-syntax (stepper-hide-operator stx)
(stepper-syntax-property stx 'stepper-skipto (append skipto/cdr skipto/second)))
(define-syntax (hidden-car stx)
(syntax-case stx ()
[(_ arg) (stepper-hide-operator (syntax/loc stx (car arg)))]))
(define-syntax (hidden-cdr stx)
(syntax-case stx ()
[(_ arg) (stepper-hide-operator (syntax/loc stx (cdr arg)))]))
(define-syntax (hidden-! stx)
(syntax-case stx ()
[(_ arg) (stepper-hide-operator (syntax/loc stx (! arg)))]))
(define-syntax (hidden-~ stx)
(syntax-case stx ()
[(_ arg) (stepper-hide-operator (syntax/loc stx (~ arg)))]))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Determine laziness ;; Determine laziness
@ -107,7 +129,7 @@
;; single expr ;; single expr
[(expr) #`(begin #,@(reverse defs) expr)] [(expr) #`(begin #,@(reverse defs) expr)]
[(expr ...) [(expr ...)
#`(begin #,@(reverse defs) (~ (begin (! expr) ...)))]))])))) #`(begin #,@(reverse defs) (hidden-~ (begin (hidden-! expr) ...)))]))]))))
;; redefined to use lazy-proc and ~begin ;; redefined to use lazy-proc and ~begin
(define-syntax (~lambda stx) (define-syntax (~lambda stx)
@ -161,7 +183,7 @@
(defsubst (~parameterize ([param val] ...) body ...) (defsubst (~parameterize ([param val] ...) body ...)
;; like ~begin, delaying the whole thing is necessary to tie the evaluation ;; like ~begin, delaying the whole thing is necessary to tie the evaluation
;; to whenever the value is actually forced ;; to whenever the value is actually forced
(~ (parameterize ([param (! val)] ...) (~begin body ...)))) (hidden-~ (parameterize ([param (hidden-! val)] ...) (~begin body ...))))
;; Multiple values are problematic: Racket promises can use multiple ;; Multiple values are problematic: Racket promises can use multiple
;; values, but to carry that out `call-with-values' should be used in all ;; values, but to carry that out `call-with-values' should be used in all
@ -222,12 +244,6 @@
;; `!apply': provided as `apply' (no need to provide `~!apply', since all ;; `!apply': provided as `apply' (no need to provide `~!apply', since all
;; function calls are delayed by `#%app') ;; function calls are delayed by `#%app')
(define-syntax (hidden-! stx)
(syntax-case stx (!)
[(_ arg) (syntax/loc stx (! arg))
#;(stepper-syntax-property #'(! arg) 'stepper-skipto
(append skipto/cdr skipto/second))]))
(define-syntax (!*app stx) (define-syntax (!*app stx)
(syntax-case stx () (syntax-case stx ()
[(_ f x ...) [(_ f x ...)
@ -256,8 +272,8 @@
(if (lazy? p) lazy strict))))))])) (if (lazy? p) lazy strict))))))]))
(defsubst (!app f x ...) (!*app (hidden-! f) x ...)) (defsubst (!app f x ...) (!*app (hidden-! f) x ...))
(defsubst (~!*app f x ...) (~ (!*app f x ...))) (defsubst (~!*app f x ...) (hidden-~ (!*app f x ...)))
(defsubst (~!app f x ...) (~ (!app f x ...))) (defsubst (~!app f x ...) (hidden-~ (!app f x ...)))
(define-for-syntax (toplevel?) (define-for-syntax (toplevel?)
(memq (syntax-local-context) (memq (syntax-local-context)
@ -269,12 +285,12 @@
(provide (rename ~!%app #%app)) ; all applications are delayed (provide (rename ~!%app #%app)) ; all applications are delayed
(define-syntax (~!%app stx) ; provided as #%app (define-syntax (~!%app stx) ; provided as #%app
(define (unwinder stx rec) #;(define (unwinder stx rec)
(syntax-case stx (!) (syntax-case stx (!)
[(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body) [(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body)
(with-syntax ([(f x ...) (rec #'(f x ...))]) (with-syntax ([(f x ...) (rec #'(f x ...))])
#'(f x ...))])) #'(f x ...))]))
(define (stepper-annotate stx) #;(define (stepper-annotate stx)
(let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)] (let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)]
[stx (stepper-syntax-property stx 'stepper-skip-double-break #t)]) [stx (stepper-syntax-property stx 'stepper-skip-double-break #t)])
stx)) stx))
@ -300,8 +316,8 @@
(define* (!apply f . xs) (define* (!apply f . xs)
(let ([f (! f)] [xs (!list (apply list* xs))]) (let ([f (! f)] [xs (!list (apply list* xs))])
(apply f (if (lazy? f) xs (map ! xs))))) (apply f (if (lazy? f) xs (map ! xs)))))
(defsubst (~!*apply f . xs) (~ (!*apply f . xs))) (defsubst (~!*apply f . xs) (hidden-~ (!*apply f . xs)))
(defsubst (~!apply f . xs) (~ (!apply f . xs))) (defsubst (~!apply f . xs) (hidden-~ (!apply f . xs)))
(provide (rename !apply apply)) ; can only be used through #%app => delayed (provide (rename !apply apply)) ; can only be used through #%app => delayed
@ -312,8 +328,8 @@
[(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))])) [(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))]))
;; used for explicitly strict/lazy calls ;; used for explicitly strict/lazy calls
(defsubst (strict-call f x ...) (~ (f (! x) ...))) (defsubst (strict-call f x ...) (hidden-~ (f (! x) ...)))
(defsubst (lazy-call f x ...) (~ (f x ...))) (defsubst (lazy-call f x ...) (hidden-~ (f x ...)))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Special forms that are now functions ;; Special forms that are now functions
@ -324,8 +340,8 @@
(define* *if (define* *if
(case-lambda [(e1 e2 e3) (if (! e1) e2 e3)] (case-lambda [(e1 e2 e3) (if (! e1) e2 e3)]
[(e1 e2 ) (if (! e1) e2 )])) [(e1 e2 ) (if (! e1) e2 )]))
(defsubst (~if e1 e2 e3) (~ (if (! e1) e2 e3)) (defsubst (~if e1 e2 e3) (hidden-~ (if (hidden-! e1) e2 e3))
(~if e1 e2 ) (~ (if (! e1) e2 )) (~if e1 e2 ) (hidden-~ (if (hidden-! e1) e2 ))
~if *if) ~if *if)
(define* (*and . xs) (define* (*and . xs)
@ -333,29 +349,29 @@
(or (null? xs) (or (null? xs)
(let loop ([x (car xs)] [xs (cdr xs)]) (let loop ([x (car xs)] [xs (cdr xs)])
(if (null? xs) x (and (! x) (loop (car xs) (cdr xs)))))))) (if (null? xs) x (and (! x) (loop (car xs) (cdr xs))))))))
(defsubst (~and x ...) (~ (and (! x) ...)) ~and *and) (defsubst (~and x ...) (hidden-~ (and (hidden-! x) ...)) ~and *and)
(define* (*or . xs) (define* (*or . xs)
(let ([xs (!list xs)]) (let ([xs (!list xs)])
(and (pair? xs) (and (pair? xs)
(let loop ([x (car xs)] [xs (cdr xs)]) (let loop ([x (car xs)] [xs (cdr xs)])
(if (null? xs) x (or (! x) (loop (car xs) (cdr xs)))))))) (if (null? xs) x (or (! x) (loop (car xs) (cdr xs))))))))
(defsubst (~or x ...) (~ (or (! x) ...)) ~or *or) (defsubst (~or x ...) (hidden-~ (or (hidden-! x) ...)) ~or *or)
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Special forms that are still special forms since they use ~begin ;; Special forms that are still special forms since they use ~begin
(defsubst (~begin0 x y ...) ; not using ~begin, but equivalent (defsubst (~begin0 x y ...) ; not using ~begin, but equivalent
(~ (let ([val (! x)]) (! y) ... val))) (hidden-~ (let ([val (hidden-! x)]) (hidden-! y) ... val)))
(defsubst (~when e x ...) (~ (when (! e) (~begin x ...)))) (defsubst (~when e x ...) (hidden-~ (when (hidden-! e) (~begin x ...))))
(defsubst (~unless e x ...) (~ (unless (! e) (~begin x ...)))) (defsubst (~unless e x ...) (hidden-~ (unless (hidden-! e) (~begin x ...))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Misc stuff ;; Misc stuff
;; Just for fun... ;; Just for fun...
(defsubst (~set! id expr) (~ (set! id (! expr)))) (defsubst (~set! id expr) (hidden-~ (set! id (hidden-! expr))))
;; The last ! above is needed -- without it: ;; The last ! above is needed -- without it:
;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a) ;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a)
;; goes into an infinite loop. (Thanks to Jos Koot) ;; goes into an infinite loop. (Thanks to Jos Koot)
@ -373,11 +389,11 @@
;; avoid forcing an `else' keyword ;; avoid forcing an `else' keyword
(map (lambda (stx) (map (lambda (stx)
(syntax-case stx (else) (syntax-case stx (else)
[else stx] [x #'(! x)])) [else stx] [x #'(hidden-! x)]))
(syntax->list #'(test ...)))]) (syntax->list #'(test ...)))])
#'(~ (cond [test (~begin body ...)] ...)))])) #'(hidden-~ (cond [test (~begin body ...)] ...)))]))
(defsubst (~case v [keys body ...] ...) (defsubst (~case v [keys body ...] ...)
(~ (case (! v) [keys (~begin body ...)] ...))) (hidden-~ (case (hidden-! v) [keys (~begin body ...)] ...)))
;; Doing this will print the whole thing, but problems with infinite things ;; Doing this will print the whole thing, but problems with infinite things
(define* (~error . args) (apply error (!! args))) (define* (~error . args) (apply error (!! args)))
@ -525,14 +541,14 @@
#'(define* ?~name #'(define* ?~name
(case-lambda (case-lambda
[(?proc ?args ... ?l) [(?proc ?args ... ?l)
(let ([?proc (! ?proc)]) (let ([?proc (hidden-! ?proc)])
(let ?loop ([?l (! ?l)] [?var ?init] ...) (let ?loop ([?l (hidden-! ?l)] [?var ?init] ...)
(if (null? ?l) (if (null? ?l)
?base ?base
?step-single)))] ?step-single)))]
[(?proc ?args ... ?l . ?ls) [(?proc ?args ... ?l . ?ls)
(let ([?proc (! ?proc)]) (let ([?proc (hidden-! ?proc)])
(let ?loop ([?ls (cons (! ?l) (!!list ?ls))] [?var ?init] ...) (let ?loop ([?ls (cons (hidden-! ?l) (!!list ?ls))] [?var ?init] ...)
(if (ormap null? ?ls) (if (ormap null? ?ls)
(if (andmap null? ?ls) (if (andmap null? ?ls)
?base ?base

33
collects/racket/private/promise.rkt
View File

@ -171,6 +171,26 @@
(define-struct (composable-promise promise) () (define-struct (composable-promise promise) ()
#:property prop:force force/composable) #:property prop:force force/composable)
;; stepper-syntax-property : like syntax property, but adds properties to an
;; association list associated with the syntax property 'stepper-properties
;; Had to re-define this because of circular dependencies
;; (also defined in stepper/private/shared.rkt)
(define-for-syntax stepper-syntax-property
(case-lambda
[(stx tag)
(letrec-values ([(stepper-props) (syntax-property stx 'stepper-properties)])
(if stepper-props
(letrec-values ([(table-lookup) (assq tag stepper-props)])
(if table-lookup
(cadr table-lookup)
#f))
#f))]
[(stx tag new-val)
(letrec-values ([(stepper-props) (syntax-property stx 'stepper-properties)])
(syntax-property stx 'stepper-properties
(cons (list tag new-val)
(if stepper-props stepper-props '()))))]))
;; template for all delay-like constructs ;; template for all delay-like constructs
;; (with simple keyword matching: keywords is an alist with default exprs) ;; (with simple keyword matching: keywords is an alist with default exprs)
(define-for-syntax (make-delayer stx maker keywords) (define-for-syntax (make-delayer stx maker keywords)
@ -203,14 +223,21 @@
;; work well with identifiers, so turn the name into a symbol to work ;; work well with identifiers, so turn the name into a symbol to work
;; around this for now ;; around this for now
[(name0) (syntax-local-infer-name stx)] [(name0) (syntax-local-infer-name stx)]
[(name) (if (syntax? name0) (syntax-e name0) name0)]) [(name) (if (syntax? name0) (syntax-e name0) name0)]
[(unwind-promise)
(lambda (stx unwind-recur)
(syntax-case stx ()
[(#%plain-lambda () body) (unwind-recur #'body)]))])
(syntax-case stx () (syntax-case stx ()
[_ (pair? exprs) ; throw a syntax error if anything is wrong [_ (pair? exprs) ; throw a syntax error if anything is wrong
(with-syntax ([(expr ...) exprs] (with-syntax ([(expr ...) exprs]
[(kwd-arg ...) kwd-args]) [(kwd-arg ...) kwd-args])
(with-syntax ([proc (syntax-property (with-syntax ([proc
(stepper-syntax-property
(syntax-property
(syntax/loc stx (lambda () expr ...)) (syntax/loc stx (lambda () expr ...))
'inferred-name name)] 'inferred-name name)
'stepper-hint unwind-promise)]
[make maker]) [make maker])
(syntax/loc stx (make proc kwd-arg ...))))]))) (syntax/loc stx (make proc kwd-arg ...))))])))

24
collects/stepper/private/annotate.rkt
View File

@ -1281,6 +1281,30 @@
call-with-values (#%plain-lambda () vals) call-with-values (#%plain-lambda () vals)
print-values)))) print-values))))
exp))] exp))]
; STC: for lazy racket
; This is similar to app case above, but with toplevel-forcer
[(#%plain-app (#%plain-app toplevel-forcer) operand)
(stepper-recertify
#`(#%plain-app
call-with-values
(#%plain-lambda
()
(#%plain-app
(#%plain-app toplevel-forcer)
#,(top-level-annotate/inner (top-level-rewrite #'operand) exp #f)))
(#%plain-lambda
vals
(begin
(#,exp-finished-break
(#%plain-app
list
(#%plain-app
list
#,(lambda () exp) #f (#%plain-lambda () vals))))
(#%plain-app
call-with-values
(#%plain-lambda () vals) values))))
exp)]
[any [any
(stepper-syntax-property exp 'stepper-test-suite-hint) (stepper-syntax-property exp 'stepper-test-suite-hint)
(top-level-annotate/inner (top-level-rewrite exp) exp #f)] (top-level-annotate/inner (top-level-rewrite exp) exp #f)]

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

@ -58,6 +58,20 @@
stx)] stx)]
[(define-values dc ...) [(define-values dc ...)
(unwind-define stx settings)] (unwind-define stx settings)]
; STC: app special cases from lazy racket
; procedure-extract-target - can't hide this in lazy.rkt bc it's needed
; to distinguish the general lazy application
[(#%plain-app proc-extract p)
(eq? (syntax->datum #'proc-extract) 'procedure-extract-target)
(unwind #'p settings)]
; general lazy application
[(#%plain-app
(#%plain-lambda args1 (#%plain-app (#%plain-app proc p) . args2))
. args3)
(and (eq? (syntax->datum #'proc) 'procedure-extract-target)
(equal? (syntax->datum (cdr (syntax-e #'args1)))
(syntax->datum #'args2)))
(recur-on-pieces #'args3 settings)]
[(#%plain-app exp ...) [(#%plain-app exp ...)
(recur-on-pieces #'(exp ...) settings)] (recur-on-pieces #'(exp ...) settings)]
[(quote datum) [(quote datum)
@ -82,7 +96,10 @@
(transfer-info (transfer-info
(let ([hint (stepper-syntax-property stx 'stepper-hint)]) (let ([hint (stepper-syntax-property stx 'stepper-hint)])
(if (procedure? hint) (if (procedure? hint)
(hint stx (lambda (stx) (recur-on-pieces stx settings))) ; STC: For fn hints, I changed the recur procedure to unwind
; (was recur-on-pieces). This should not affect the non-lazy
; stepper since it doesnt seem to use any fn hints.
(hint stx (lambda (stx) (unwind stx settings)))
(let ([process (case hint (let ([process (case hint
[(comes-from-cond) unwind-cond] [(comes-from-cond) unwind-cond]
[(comes-from-and) (unwind-and/or 'and)] [(comes-from-and) (unwind-and/or 'and)]

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

@ -84,6 +84,8 @@
#:disable-error-handling? [disable-error-handling? #f] #:disable-error-handling? [disable-error-handling? #f]
#:raw-step-receiver [raw-step-receiver #f]) #:raw-step-receiver [raw-step-receiver #f])
(define DEBUG #f)
;; finished-exps: ;; finished-exps:
;; (listof (list/c syntax-object? (or/c number? false?)( -> any))) ;; (listof (list/c syntax-object? (or/c number? false?)( -> any)))
;; because of mutation, these cannot be fixed renderings, but must be ;; because of mutation, these cannot be fixed renderings, but must be
@ -104,6 +106,14 @@
(define held-finished-list null) (define held-finished-list null)
(define (reset-held-exp-list)
(set! held-exp-list the-no-sexp)
(set! held-finished-list null))
; used when determining whether to skip step with ellipses on LHS
(define last-rhs-exps null)
;; highlight-mutated-expressions : ;; highlight-mutated-expressions :
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) ;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?))
;; -> (list/c (listof syntax?) (listof syntax?))) ;; -> (list/c (listof syntax?) (listof syntax?)))
@ -164,6 +174,8 @@
(define break (define break
(lambda (mark-set break-kind [returned-value-list #f]) (lambda (mark-set break-kind [returned-value-list #f])
(when DEBUG
(printf "\n---------- BREAK TYPE = ~a ----------\n" break-kind))
(set! steps-received (+ steps-received 1)) (set! steps-received (+ steps-received 1))
;; have to be careful else this won't be looked up right away: ;; have to be careful else this won't be looked up right away:
@ -176,7 +188,13 @@
steps-received/current steps-received/current
mark-set break-kind returned-value-list))))) mark-set break-kind returned-value-list)))))
(let* ([mark-list (and mark-set (extract-mark-list mark-set))]) (let* ([mark-list (and mark-set (extract-mark-list mark-set))]
[dump-marks
(when DEBUG
(printf "MARKLIST:\n")
(and mark-set
(map (λ (x) (printf "~a\n" (display-mark x))) mark-list))
(printf "RETURNED VALUE LIST: ~a\n" returned-value-list))])
(define (reconstruct-all-completed) (define (reconstruct-all-completed)
(filter-map (filter-map
@ -192,91 +210,138 @@
[(vector exp #t) exp])))]) [(vector exp #t) exp])))])
finished-exps)) finished-exps))
(define (compute-posn-info)
(mark-list->posn-info mark-list))
(define (compute-step-was-app?)
(r:step-was-app? mark-list))
(define (compute-step-kind held-step-was-app?)
(if (and held-step-was-app?
(eq? break-kind 'result-exp-break))
'user-application
'normal))
(define (create-held exps)
(make-held exps (compute-step-was-app?) (compute-posn-info)))
; sends a step to the stepper, except if
; - lhs = rhs
; - lhs = ellipses, rhs = last-rhs
(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 (and (step=? lhs-exps rhs-exps)
(when DEBUG (printf "LHS = RHS, so skipping\n")))
(and (step=? lhs-exps (list #'(... ...)))
(step=? rhs-exps last-rhs-exps)
(when DEBUG
(printf "LHS = ..., RHS = last RHS, so skipping\n"))))
(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)))
; compares the lhs and rhs of a step (lists of syntaxes)
; and returns true if the underlying datums are equal
(define (step=? lhs rhs)
(equal? (map syntax->datum lhs)
(map syntax->datum rhs)))
#;(>>> break-kind) #;(>>> break-kind)
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind) #;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
(if (r:skip-step? break-kind mark-list render-settings) (if (r:skip-step? break-kind mark-list render-settings)
(begin (begin
#;(fprintf (current-error-port) " but it was skipped!\n") (when DEBUG (printf "skipped step\n"))
(when (or (eq? break-kind 'normal-break) (when (or (eq? break-kind 'normal-break)
;; not sure about this... ;; not sure about this...
(eq? break-kind 'nomal-break/values)) (eq? break-kind 'nomal-break/values))
(set! held-exp-list the-skipped-step))) (set! held-exp-list the-skipped-step)))
(begin (begin
#;(fprintf (current-error-port) "and it wasn't skipped.\n")
(case break-kind (case break-kind
; CASE: normal-break or normal-break/values -------------------
[(normal-break normal-break/values) [(normal-break normal-break/values)
(begin (begin
(when (and (eq? break-kind 'normal-break) (when (and (eq? break-kind 'normal-break)
returned-value-list) returned-value-list)
(error 'break (error 'break
"broken invariant: normal-break can't have returned values")) "broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed)) (let*
(set! held-exp-list ([lhs-reconstructed
(make-held
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-left-side (r:reconstruct-left-side
mark-list returned-value-list render-settings) mark-list returned-value-list render-settings)]
#f)) [print-lhs-recon
(r:step-was-app? mark-list) (when DEBUG
(mark-list->posn-info mark-list))))] (printf "LHS (pre-unwound):\n ~a\n"
(syntax->hilite-datum lhs-reconstructed)))]
[lhs-unwound
(map (λ (exp) (unwind exp render-settings))
(maybe-lift lhs-reconstructed #f))]
[print-lhs-unwound
(when DEBUG
(for-each
(λ (x) (printf "LHS (unwound): ~a\n"
(syntax->hilite-datum x)))
lhs-unwound))]
[lhs-finished-exps (reconstruct-all-completed)])
(set! held-finished-list lhs-finished-exps)
(set! held-exp-list (create-held lhs-unwound))))]
; CASE: result-exp-break or result-value-break ----------------
[(result-exp-break result-value-break) [(result-exp-break result-value-break)
(let ([reconstruct (let ([reconstruct
(lambda () (lambda ()
(map (lambda (exp) (let* ([rhs-reconstructed
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-right-side (r:reconstruct-right-side
mark-list returned-value-list render-settings) mark-list returned-value-list render-settings)]
#f)))] [print-rhs-recon
[send-result (lambda (result) (when DEBUG
(set! held-exp-list the-no-sexp) (printf "RHS (pre-unwound):\n ~a\n"
(receive-result result))]) (syntax->hilite-datum rhs-reconstructed)))]
[rhs-unwound
(map (λ (exp) (unwind exp render-settings))
(maybe-lift rhs-reconstructed #f))]
[print-rhs-unwound
(when DEBUG
(for-each
(λ (x) (printf "RHS (unwound): ~a\n"
(syntax->hilite-datum x)))
rhs-unwound))])
rhs-unwound))])
(match held-exp-list (match held-exp-list
[(struct skipped-step ()) [(struct skipped-step ())
(when DEBUG (printf "LHS = skipped, so skipping RHS\n"))
;; don't render if before step was a skipped-step ;; don't render if before step was a skipped-step
(set! held-exp-list the-no-sexp)] (reset-held-exp-list)]
[(struct no-sexp ()) [(struct no-sexp ())
(when DEBUG (printf "LHS = none\n"))
;; in this case, there was no "before" step, due ;; in this case, there was no "before" step, due
;; to unannotated code. In this case, we make the ;; to unannotated code. In this case, we make the
;; optimistic guess that none of the finished ;; optimistic guess that none of the finished
;; expressions were mutated. It would be somewhat ;; expressions were mutated. It would be somewhat
;; painful to do a better job, and the stepper ;; painful to do a better job, and the stepper
;; makes no guarantees in this case. ;; makes no guarantees in this case.
(send-result (send-step (list #'(... ...)) '() ; lhs
(make-before-after-result (reconstruct) (reconstruct-all-completed) ; rhs
;; NB: this (... ...) IS UNRELATED TO 'normal #f #f)
;; THE MACRO IDIOM OF THE SAME NAME (reset-held-exp-list)]
(list #`(... ...))
(append (reconstruct-all-completed) (reconstruct))
'normal
#f #f))]
[(struct held (held-exps held-step-was-app? held-posn-info)) [(struct held (held-exps held-step-was-app? held-posn-info))
(let*-values (send-step held-exps held-finished-list
([(step-kind) (reconstruct) (reconstruct-all-completed)
(if (and held-step-was-app? (compute-step-kind held-step-was-app?)
(eq? break-kind 'result-exp-break)) held-posn-info (compute-posn-info))
'user-application (reset-held-exp-list)]))]
'normal)]
[(left-exps right-exps)
;; write this later:
;; (identify-changed
;; (append held-finished-list held-exps)
;; (append new-finished-list reconstructed))
(values (append held-finished-list
held-exps)
(append (reconstruct-all-completed)
(reconstruct)))])
(send-result
(make-before-after-result
left-exps right-exps step-kind
held-posn-info
(mark-list->posn-info mark-list))))]))]
; CASE: double-break ------------------------------------------
[(double-break) [(double-break)
;; a double-break occurs at the beginning of a let's ;; a double-break occurs at the beginning of a let's
;; evaluation. ;; evaluation.
@ -287,19 +352,30 @@
(let* ([new-finished-list (reconstruct-all-completed)] (let* ([new-finished-list (reconstruct-all-completed)]
[reconstruct-result [reconstruct-result
(r:reconstruct-double-break mark-list render-settings)] (r:reconstruct-double-break mark-list render-settings)]
[left-side (map (lambda (exp) (unwind exp render-settings)) [print-recon
(when DEBUG
(printf "LHS (pre-unwound):\n ~a\n"
(syntax->hilite-datum (car reconstruct-result)))
(printf "RHS (pre-unwound):\n ~a\n"
(syntax->hilite-datum (cadr reconstruct-result))))]
[lhs-unwound (map (lambda (exp) (unwind exp render-settings))
(maybe-lift (car reconstruct-result) #f))] (maybe-lift (car reconstruct-result) #f))]
[right-side (map (lambda (exp) (unwind exp render-settings)) [rhs-unwound (map (lambda (exp) (unwind exp render-settings))
(maybe-lift (cadr reconstruct-result) #t))]) (maybe-lift (cadr reconstruct-result) #t))]
(let ([posn-info (mark-list->posn-info mark-list)]) [print-unwound
(receive-result (when DEBUG
(make-before-after-result (for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
(append new-finished-list left-side) (syntax->hilite-datum x)))
(append new-finished-list right-side) lhs-unwound)
(for-each (λ (x) (printf "right side (unwound):\n ~a\n"
(syntax->hilite-datum x)))
rhs-unwound))])
(send-step lhs-unwound new-finished-list
rhs-unwound new-finished-list
'normal 'normal
posn-info (compute-posn-info) (compute-posn-info)))]
posn-info))))]
; CASE: expr-finished-break -----------------------------------
[(expr-finished-break) [(expr-finished-break)
(unless (not mark-list) (unless (not mark-list)
(error 'break (error 'break
@ -308,6 +384,17 @@
;; (list/c source lifting-index getter)) this will now include ;; (list/c source lifting-index getter)) this will now include
;; define-struct breaks, for which the source is the source ;; define-struct breaks, for which the source is the source
;; and the getter causes an error. ;; and the getter causes an error.
(when DEBUG
(for-each
(λ (x)
(printf "add to finished:\n")
(printf " source: ~a\n" (syntax->hilite-datum ((car x))))
(printf " index: ~a\n" (second x))
(printf " getter: ")
(if (stepper-syntax-property ((car x)) 'stepper-define-struct-hint)
(printf "no getter for term with stepper-define-struct-hint property\n")
(printf "~a\n" ((third x)))))
returned-value-list))
(for-each (lambda (source/index/getter) (for-each (lambda (source/index/getter)
(apply add-to-finished source/index/getter)) (apply add-to-finished source/index/getter))
returned-value-list)] returned-value-list)]

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

@ -131,6 +131,16 @@
#`#,name)) #`#,name))
(recon-source-expr (recon-source-expr
(mark-source mark) (list mark) null null render-settings)))] (mark-source mark) (list mark) null null render-settings)))]
; promise does not have annotation info,
; must be from library code, or it's a running promise
[(promise? val)
(let ([partial-eval-promise
(hash-ref partially-evaluated-promises-table
val (λ () #f))])
(or partial-eval-promise
(if (promise-forced? val)
(recon-value (force val) render-settings assigned-name)
'promise)))]
[else [else
(let* ([rendered (let* ([rendered
((render-settings-render-to-sexp render-settings) val)]) ((render-settings-render-to-sexp render-settings) val)])
@ -157,6 +167,24 @@
(define (unwrap-proc f) (define (unwrap-proc f)
(extract-proc-if-promise (extract-proc-if-struct f))) (extract-proc-if-promise (extract-proc-if-struct f)))
; nested-promise-running? : Indicates whether a promise is in the "running"
; state. promise-running? in racket/private/promise.rkt only looks down
; one level for a running promise
(define (nested-promise-running? p)
(if (promise? p)
(let ([v (pref p)])
(or (running? v)
(and (promise? v)
(nested-promise-running? v))))
(raise-type-error 'nested-promise-running? "promise" p)))
; weak hash table to keep track of partially evaluated promises
; where keys = promises, values = syntax
; - initialized on each call to reconstruct-current
; (ie - each half-step reconstruction)
; - populated on each call to recon-inner
(define partially-evaluated-promises-table null)
; ; ;;; ; ; ;;;
; ; ; ; ; ;
@ -226,9 +254,7 @@
(varref-skip-step? expr)])] (varref-skip-step? expr)])]
[(#%top . id-stx) [(#%top . id-stx)
(varref-skip-step? #`id-stx)] (varref-skip-step? #`id-stx)]
; STC: this case can be removed if stepper automatically skips [(#%plain-app . terms)
; duplicate steps
#;[(#%plain-app . terms)
; don't halt for proper applications of constructors ; don't halt for proper applications of constructors
(let ([fun-val (lookup-binding mark-list (get-arg-var 0))]) (let ([fun-val (lookup-binding mark-list (get-arg-var 0))])
(and (procedure? fun-val) (and (procedure? fun-val)
@ -749,6 +775,19 @@
bodies bodies
(iota (length bodies)))]) (iota (length bodies)))])
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
; STC: cache any running promises in the top mark
; means that promise is being evaluated
(let ([maybe-running-promise
(findf (λ (f) (and (promise? f) (nested-promise-running? f)))
(map mark-binding-value (mark-bindings top-mark)))])
(when (and maybe-running-promise
(not (hash-has-key? partially-evaluated-promises-table
maybe-running-promise))
(not (eq? so-far nothing-so-far)))
(hash-set! partially-evaluated-promises-table
maybe-running-promise so-far)))
(if (stepper-syntax-property exp 'stepper-fake-exp) (if (stepper-syntax-property exp 'stepper-fake-exp)
(kernel:kernel-syntax-case exp #f (kernel:kernel-syntax-case exp #f
@ -802,7 +841,11 @@
(stepper-syntax-property (stepper-syntax-property
(if (eq? so-far nothing-so-far) (if (eq? so-far nothing-so-far)
(datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur? (datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur?
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))) ; dont show ellipses for force
; object-name is good enough here, so dont need to add another "special val"
(if (eq? (object-name (car arg-vals)) 'force)
so-far
(datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))))
'stepper-args-of-call 'stepper-args-of-call
rectified-evaluated)) rectified-evaluated))
(else (else
@ -948,34 +991,58 @@
returned-value-list)) returned-value-list))
(define answer (define answer
(begin
; STC: reset partial-eval-promise table on each call to recon
(set! partially-evaluated-promises-table (make-weak-hash))
(case break-kind (case break-kind
((left-side) ((left-side)
(let* ([innermost (if returned-value-list ; is it a normal-break/values? (let* ([innermost
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) (if returned-value-list ; is it a normal-break/values?
(error 'reconstruct "context expected one value, given ~v" returned-value-list)) (begin
(unless (and (pair? returned-value-list)
(null? (cdr returned-value-list)))
(error 'reconstruct
"context expected one value, given ~v"
returned-value-list))
(recon-value (car returned-value-list) render-settings)) (recon-value (car returned-value-list) render-settings))
nothing-so-far)]) nothing-so-far)])
(recon innermost mark-list #t))) (recon innermost mark-list #t)))
((right-side) ((right-side)
(let* ([innermost (if returned-value-list ; is it an expr -> value reduction? (let* ([innermost
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) (if returned-value-list ; is it an expr -> value reduction?
(error 'reconstruct "context expected one value, given ~v" returned-value-list)) (begin
(unless (and (pair? returned-value-list)
(null? (cdr returned-value-list)))
(error 'reconstruct
"context expected one value, given ~v"
returned-value-list))
(recon-value (car returned-value-list) render-settings)) (recon-value (car returned-value-list) render-settings))
(recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))]) (recon-source-expr (mark-source (car mark-list))
mark-list null null render-settings))])
(recon (mark-as-highlight innermost) (cdr mark-list) #f))) (recon (mark-as-highlight innermost) (cdr mark-list) #f)))
((double-break) ((double-break)
(let* ([source-expr (mark-source (car mark-list))] (let* ([source-expr (mark-source (car mark-list))]
[innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))] [innermost-before
[newly-lifted-bindings (syntax-case source-expr (letrec-values) (mark-as-highlight
(recon-source-expr source-expr mark-list null null render-settings))]
[newly-lifted-bindings
(syntax-case source-expr (letrec-values)
[(letrec-values ([vars . rest] ...) . bodies) [(letrec-values ([vars . rest] ...) . bodies)
(apply append (map syntax->list (syntax->list #`(vars ...))))] (apply append (map syntax->list (syntax->list #`(vars ...))))]
[(let-values ([vars . rest] ...) . bodies) [(let-values ([vars . rest] ...) . bodies)
(apply append (map syntax->list (syntax->list #`(vars ...))))] (apply append (map syntax->list (syntax->list #`(vars ...))))]
[else (error 'reconstruct "expected a let-values as source for a double-break, got: ~.s" [else (error
'reconstruct
"expected a let-values as source for a double-break, got: ~.s"
(syntax->datum source-expr))])] (syntax->datum source-expr))])]
[innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))]) [innermost-after
(mark-as-highlight
(recon-source-expr
(mark-source (car mark-list))
mark-list null newly-lifted-bindings render-settings))])
(list (recon innermost-before (cdr mark-list) #f) (list (recon innermost-before (cdr mark-list) #f)
(recon innermost-after (cdr mark-list) #f)))))) (recon innermost-after (cdr mark-list) #f)))))))
) )