simple example working: (define (f x) (+ x x)) (f (+ 1 2))
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
parent
2d204dc6ea
commit
6921960c5e
|
|
@ -55,6 +55,28 @@
|
|||
(define-for-syntax strict-names
|
||||
(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
|
||||
|
||||
|
|
@ -107,7 +129,7 @@
|
|||
;; single expr
|
||||
[(expr) #`(begin #,@(reverse defs) expr)]
|
||||
[(expr ...)
|
||||
#`(begin #,@(reverse defs) (~ (begin (! expr) ...)))]))]))))
|
||||
#`(begin #,@(reverse defs) (hidden-~ (begin (hidden-! expr) ...)))]))]))))
|
||||
|
||||
;; redefined to use lazy-proc and ~begin
|
||||
(define-syntax (~lambda stx)
|
||||
|
|
@ -161,7 +183,7 @@
|
|||
(defsubst (~parameterize ([param val] ...) body ...)
|
||||
;; like ~begin, delaying the whole thing is necessary to tie the evaluation
|
||||
;; 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
|
||||
;; 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
|
||||
;; 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)
|
||||
(syntax-case stx ()
|
||||
[(_ f x ...)
|
||||
|
|
@ -256,8 +272,8 @@
|
|||
(if (lazy? p) lazy strict))))))]))
|
||||
|
||||
(defsubst (!app f x ...) (!*app (hidden-! f) x ...))
|
||||
(defsubst (~!*app f x ...) (~ (!*app f x ...)))
|
||||
(defsubst (~!app f x ...) (~ (!app f x ...)))
|
||||
(defsubst (~!*app f x ...) (hidden-~ (!*app f x ...)))
|
||||
(defsubst (~!app f x ...) (hidden-~ (!app f x ...)))
|
||||
|
||||
(define-for-syntax (toplevel?)
|
||||
(memq (syntax-local-context)
|
||||
|
|
@ -269,12 +285,12 @@
|
|||
|
||||
(provide (rename ~!%app #%app)) ; all applications are delayed
|
||||
(define-syntax (~!%app stx) ; provided as #%app
|
||||
(define (unwinder stx rec)
|
||||
#;(define (unwinder stx rec)
|
||||
(syntax-case stx (!)
|
||||
[(let-values ([(_p) (_app ! f)] [(_y) x] ...) _body)
|
||||
(with-syntax ([(f x ...) (rec #'(f x ...))])
|
||||
#'(f x ...))]))
|
||||
(define (stepper-annotate stx)
|
||||
#;(define (stepper-annotate stx)
|
||||
(let* ([stx (stepper-syntax-property stx 'stepper-hint unwinder)]
|
||||
[stx (stepper-syntax-property stx 'stepper-skip-double-break #t)])
|
||||
stx))
|
||||
|
|
@ -300,8 +316,8 @@
|
|||
(define* (!apply f . xs)
|
||||
(let ([f (! f)] [xs (!list (apply list* xs))])
|
||||
(apply f (if (lazy? f) xs (map ! xs)))))
|
||||
(defsubst (~!*apply f . xs) (~ (!*apply f . xs)))
|
||||
(defsubst (~!apply f . xs) (~ (!apply f . xs)))
|
||||
(defsubst (~!*apply f . xs) (hidden-~ (!*apply f . xs)))
|
||||
(defsubst (~!apply f . xs) (hidden-~ (!apply f . xs)))
|
||||
|
||||
(provide (rename !apply apply)) ; can only be used through #%app => delayed
|
||||
|
||||
|
|
@ -312,8 +328,8 @@
|
|||
[(_ . id) (if (toplevel?) #'(! (#%top . id)) #'(#%top . id))]))
|
||||
|
||||
;; used for explicitly strict/lazy calls
|
||||
(defsubst (strict-call f x ...) (~ (f (! x) ...)))
|
||||
(defsubst (lazy-call f x ...) (~ (f x ...)))
|
||||
(defsubst (strict-call f x ...) (hidden-~ (f (! x) ...)))
|
||||
(defsubst (lazy-call f x ...) (hidden-~ (f x ...)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Special forms that are now functions
|
||||
|
|
@ -324,8 +340,8 @@
|
|||
(define* *if
|
||||
(case-lambda [(e1 e2 e3) (if (! e1) e2 e3)]
|
||||
[(e1 e2 ) (if (! e1) e2 )]))
|
||||
(defsubst (~if e1 e2 e3) (~ (if (! e1) e2 e3))
|
||||
(~if e1 e2 ) (~ (if (! e1) e2 ))
|
||||
(defsubst (~if e1 e2 e3) (hidden-~ (if (hidden-! e1) e2 e3))
|
||||
(~if e1 e2 ) (hidden-~ (if (hidden-! e1) e2 ))
|
||||
~if *if)
|
||||
|
||||
(define* (*and . xs)
|
||||
|
|
@ -333,29 +349,29 @@
|
|||
(or (null? xs)
|
||||
(let loop ([x (car xs)] [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)
|
||||
(let ([xs (!list xs)])
|
||||
(and (pair? xs)
|
||||
(let loop ([x (car xs)] [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
|
||||
|
||||
(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 (~unless e x ...) (~ (unless (! e) (~begin x ...))))
|
||||
(defsubst (~when e x ...) (hidden-~ (when (hidden-! e) (~begin x ...))))
|
||||
(defsubst (~unless e x ...) (hidden-~ (unless (hidden-! e) (~begin x ...))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Misc stuff
|
||||
|
||||
;; 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:
|
||||
;; (let ([a 1] [b 2]) (set! a (add1 b)) (set! b (add1 a)) a)
|
||||
;; goes into an infinite loop. (Thanks to Jos Koot)
|
||||
|
|
@ -373,11 +389,11 @@
|
|||
;; avoid forcing an `else' keyword
|
||||
(map (lambda (stx)
|
||||
(syntax-case stx (else)
|
||||
[else stx] [x #'(! x)]))
|
||||
[else stx] [x #'(hidden-! x)]))
|
||||
(syntax->list #'(test ...)))])
|
||||
#'(~ (cond [test (~begin body ...)] ...)))]))
|
||||
#'(hidden-~ (cond [test (~begin 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
|
||||
(define* (~error . args) (apply error (!! args)))
|
||||
|
|
@ -525,14 +541,14 @@
|
|||
#'(define* ?~name
|
||||
(case-lambda
|
||||
[(?proc ?args ... ?l)
|
||||
(let ([?proc (! ?proc)])
|
||||
(let ?loop ([?l (! ?l)] [?var ?init] ...)
|
||||
(let ([?proc (hidden-! ?proc)])
|
||||
(let ?loop ([?l (hidden-! ?l)] [?var ?init] ...)
|
||||
(if (null? ?l)
|
||||
?base
|
||||
?step-single)))]
|
||||
[(?proc ?args ... ?l . ?ls)
|
||||
(let ([?proc (! ?proc)])
|
||||
(let ?loop ([?ls (cons (! ?l) (!!list ?ls))] [?var ?init] ...)
|
||||
(let ([?proc (hidden-! ?proc)])
|
||||
(let ?loop ([?ls (cons (hidden-! ?l) (!!list ?ls))] [?var ?init] ...)
|
||||
(if (ormap null? ?ls)
|
||||
(if (andmap null? ?ls)
|
||||
?base
|
||||
|
|
|
|||
|
|
@ -171,6 +171,26 @@
|
|||
(define-struct (composable-promise promise) ()
|
||||
#: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
|
||||
;; (with simple keyword matching: keywords is an alist with default exprs)
|
||||
(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
|
||||
;; around this for now
|
||||
[(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 ()
|
||||
[_ (pair? exprs) ; throw a syntax error if anything is wrong
|
||||
(with-syntax ([(expr ...) exprs]
|
||||
[(kwd-arg ...) kwd-args])
|
||||
(with-syntax ([proc (syntax-property
|
||||
(with-syntax ([proc
|
||||
(stepper-syntax-property
|
||||
(syntax-property
|
||||
(syntax/loc stx (lambda () expr ...))
|
||||
'inferred-name name)]
|
||||
'inferred-name name)
|
||||
'stepper-hint unwind-promise)]
|
||||
[make maker])
|
||||
(syntax/loc stx (make proc kwd-arg ...))))])))
|
||||
|
||||
|
|
|
|||
|
|
@ -1281,6 +1281,30 @@
|
|||
call-with-values (#%plain-lambda () vals)
|
||||
print-values))))
|
||||
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
|
||||
(stepper-syntax-property exp 'stepper-test-suite-hint)
|
||||
(top-level-annotate/inner (top-level-rewrite exp) exp #f)]
|
||||
|
|
|
|||
|
|
@ -58,6 +58,20 @@
|
|||
stx)]
|
||||
[(define-values dc ...)
|
||||
(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 ...)
|
||||
(recur-on-pieces #'(exp ...) settings)]
|
||||
[(quote datum)
|
||||
|
|
@ -82,7 +96,10 @@
|
|||
(transfer-info
|
||||
(let ([hint (stepper-syntax-property stx 'stepper-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
|
||||
[(comes-from-cond) unwind-cond]
|
||||
[(comes-from-and) (unwind-and/or 'and)]
|
||||
|
|
|
|||
|
|
@ -84,6 +84,8 @@
|
|||
#:disable-error-handling? [disable-error-handling? #f]
|
||||
#:raw-step-receiver [raw-step-receiver #f])
|
||||
|
||||
(define DEBUG #f)
|
||||
|
||||
;; finished-exps:
|
||||
;; (listof (list/c syntax-object? (or/c number? false?)( -> any)))
|
||||
;; because of mutation, these cannot be fixed renderings, but must be
|
||||
|
|
@ -104,6 +106,14 @@
|
|||
|
||||
(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 :
|
||||
;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?))
|
||||
;; -> (list/c (listof syntax?) (listof syntax?)))
|
||||
|
|
@ -164,6 +174,8 @@
|
|||
|
||||
(define break
|
||||
(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))
|
||||
;; have to be careful else this won't be looked up right away:
|
||||
|
|
@ -176,7 +188,13 @@
|
|||
steps-received/current
|
||||
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)
|
||||
(filter-map
|
||||
|
|
@ -192,91 +210,138 @@
|
|||
[(vector exp #t) exp])))])
|
||||
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)
|
||||
#;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind)
|
||||
(if (r:skip-step? break-kind mark-list render-settings)
|
||||
(begin
|
||||
#;(fprintf (current-error-port) " but it was skipped!\n")
|
||||
(when DEBUG (printf "skipped step\n"))
|
||||
(when (or (eq? break-kind 'normal-break)
|
||||
;; not sure about this...
|
||||
(eq? break-kind 'nomal-break/values))
|
||||
(set! held-exp-list the-skipped-step)))
|
||||
|
||||
(begin
|
||||
#;(fprintf (current-error-port) "and it wasn't skipped.\n")
|
||||
(case break-kind
|
||||
; CASE: normal-break or normal-break/values -------------------
|
||||
[(normal-break normal-break/values)
|
||||
(begin
|
||||
(when (and (eq? break-kind 'normal-break)
|
||||
returned-value-list)
|
||||
(error 'break
|
||||
"broken invariant: normal-break can't have returned values"))
|
||||
(set! held-finished-list (reconstruct-all-completed))
|
||||
(set! held-exp-list
|
||||
(make-held
|
||||
(map (lambda (exp)
|
||||
(unwind exp render-settings))
|
||||
(maybe-lift
|
||||
(let*
|
||||
([lhs-reconstructed
|
||||
(r:reconstruct-left-side
|
||||
mark-list returned-value-list render-settings)
|
||||
#f))
|
||||
(r:step-was-app? mark-list)
|
||||
(mark-list->posn-info mark-list))))]
|
||||
mark-list returned-value-list render-settings)]
|
||||
[print-lhs-recon
|
||||
(when DEBUG
|
||||
(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)
|
||||
(let ([reconstruct
|
||||
(lambda ()
|
||||
(map (lambda (exp)
|
||||
(unwind exp render-settings))
|
||||
(maybe-lift
|
||||
(let* ([rhs-reconstructed
|
||||
(r:reconstruct-right-side
|
||||
mark-list returned-value-list render-settings)
|
||||
#f)))]
|
||||
[send-result (lambda (result)
|
||||
(set! held-exp-list the-no-sexp)
|
||||
(receive-result result))])
|
||||
mark-list returned-value-list render-settings)]
|
||||
[print-rhs-recon
|
||||
(when DEBUG
|
||||
(printf "RHS (pre-unwound):\n ~a\n"
|
||||
(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
|
||||
[(struct skipped-step ())
|
||||
(when DEBUG (printf "LHS = skipped, so skipping RHS\n"))
|
||||
;; don't render if before step was a skipped-step
|
||||
(set! held-exp-list the-no-sexp)]
|
||||
(reset-held-exp-list)]
|
||||
[(struct no-sexp ())
|
||||
(when DEBUG (printf "LHS = none\n"))
|
||||
;; in this case, there was no "before" step, due
|
||||
;; to unannotated code. In this case, we make the
|
||||
;; optimistic guess that none of the finished
|
||||
;; expressions were mutated. It would be somewhat
|
||||
;; painful to do a better job, and the stepper
|
||||
;; makes no guarantees in this case.
|
||||
(send-result
|
||||
(make-before-after-result
|
||||
;; NB: this (... ...) IS UNRELATED TO
|
||||
;; THE MACRO IDIOM OF THE SAME NAME
|
||||
(list #`(... ...))
|
||||
(append (reconstruct-all-completed) (reconstruct))
|
||||
'normal
|
||||
#f #f))]
|
||||
(send-step (list #'(... ...)) '() ; lhs
|
||||
(reconstruct) (reconstruct-all-completed) ; rhs
|
||||
'normal #f #f)
|
||||
(reset-held-exp-list)]
|
||||
[(struct held (held-exps held-step-was-app? held-posn-info))
|
||||
(let*-values
|
||||
([(step-kind)
|
||||
(if (and held-step-was-app?
|
||||
(eq? break-kind 'result-exp-break))
|
||||
'user-application
|
||||
'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))))]))]
|
||||
(send-step held-exps held-finished-list
|
||||
(reconstruct) (reconstruct-all-completed)
|
||||
(compute-step-kind held-step-was-app?)
|
||||
held-posn-info (compute-posn-info))
|
||||
(reset-held-exp-list)]))]
|
||||
|
||||
; CASE: double-break ------------------------------------------
|
||||
[(double-break)
|
||||
;; a double-break occurs at the beginning of a let's
|
||||
;; evaluation.
|
||||
|
|
@ -287,19 +352,30 @@
|
|||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstruct-result
|
||||
(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))]
|
||||
[right-side (map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (cadr reconstruct-result) #t))])
|
||||
(let ([posn-info (mark-list->posn-info mark-list)])
|
||||
(receive-result
|
||||
(make-before-after-result
|
||||
(append new-finished-list left-side)
|
||||
(append new-finished-list right-side)
|
||||
[rhs-unwound (map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (cadr reconstruct-result) #t))]
|
||||
[print-unwound
|
||||
(when DEBUG
|
||||
(for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
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
|
||||
posn-info
|
||||
posn-info))))]
|
||||
(compute-posn-info) (compute-posn-info)))]
|
||||
|
||||
; CASE: expr-finished-break -----------------------------------
|
||||
[(expr-finished-break)
|
||||
(unless (not mark-list)
|
||||
(error 'break
|
||||
|
|
@ -308,6 +384,17 @@
|
|||
;; (list/c source lifting-index getter)) this will now include
|
||||
;; define-struct breaks, for which the source is the source
|
||||
;; 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)
|
||||
(apply add-to-finished source/index/getter))
|
||||
returned-value-list)]
|
||||
|
|
|
|||
|
|
@ -131,6 +131,16 @@
|
|||
#`#,name))
|
||||
(recon-source-expr
|
||||
(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
|
||||
(let* ([rendered
|
||||
((render-settings-render-to-sexp render-settings) val)])
|
||||
|
|
@ -157,6 +167,24 @@
|
|||
(define (unwrap-proc 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)])]
|
||||
[(#%top . id-stx)
|
||||
(varref-skip-step? #`id-stx)]
|
||||
; STC: this case can be removed if stepper automatically skips
|
||||
; duplicate steps
|
||||
#;[(#%plain-app . terms)
|
||||
[(#%plain-app . terms)
|
||||
; don't halt for proper applications of constructors
|
||||
(let ([fun-val (lookup-binding mark-list (get-arg-var 0))])
|
||||
(and (procedure? fun-val)
|
||||
|
|
@ -749,6 +775,19 @@
|
|||
bodies
|
||||
(iota (length bodies)))])
|
||||
(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)
|
||||
|
||||
(kernel:kernel-syntax-case exp #f
|
||||
|
|
@ -802,7 +841,11 @@
|
|||
(stepper-syntax-property
|
||||
(if (eq? so-far nothing-so-far)
|
||||
(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
|
||||
rectified-evaluated))
|
||||
(else
|
||||
|
|
@ -948,34 +991,58 @@
|
|||
returned-value-list))
|
||||
|
||||
(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
|
||||
((left-side)
|
||||
(let* ([innermost (if returned-value-list ; is it a normal-break/values?
|
||||
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list)))
|
||||
(error 'reconstruct "context expected one value, given ~v" returned-value-list))
|
||||
(let* ([innermost
|
||||
(if returned-value-list ; is it a normal-break/values?
|
||||
(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))
|
||||
nothing-so-far)])
|
||||
(recon innermost mark-list #t)))
|
||||
((right-side)
|
||||
(let* ([innermost (if returned-value-list ; is it an expr -> value reduction?
|
||||
(begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list)))
|
||||
(error 'reconstruct "context expected one value, given ~v" returned-value-list))
|
||||
(let* ([innermost
|
||||
(if returned-value-list ; is it an expr -> value reduction?
|
||||
(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-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)))
|
||||
((double-break)
|
||||
(let* ([source-expr (mark-source (car mark-list))]
|
||||
[innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))]
|
||||
[newly-lifted-bindings (syntax-case source-expr (letrec-values)
|
||||
[innermost-before
|
||||
(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)
|
||||
(apply append (map syntax->list (syntax->list #`(vars ...))))]
|
||||
[(let-values ([vars . rest] ...) . bodies)
|
||||
(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))])]
|
||||
[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)
|
||||
(recon innermost-after (cdr mark-list) #f))))))
|
||||
(recon innermost-after (cdr mark-list) #f)))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user