#lang scheme/base ;step collector state machine (not yet implemented): ; ; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args) ; ; states: global state of held ; global: held : held-type ; edge-names: first, skipped-first, second, skipped-second, double, late-let ; ;transitions (& actions): ; ; held = NO-HELD-STEP : ; first(x) : held := HELD(x) ; skipped-first : held := SKIPPED-STEP ; second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP. ; this happens when evaluating unannotated code ; skipped-second : held := NO-HELD-STEP ; I believe this can also arise in unannotated code ; double(x) : double-trigger(x), held := NO-HELD-STEP ; late-let(x) : late-let-trigger(x), held := NO-HELD-STEP ; ; held = SOME(SKIPPED-STEP) : ; first(x) : ERROR ; skipped-first : ERROR ; second(x) : held := NO-HELD-STEP ; this happens e.g. for evaluation of top-level var bound to a procedure ; skipped-second : held := NO-HELD-STEP ; double(x) : ERROR ; late-let(x) : ERROR ; ; held = SOME(HELD(args)) ; first(x) : ERROR ; skipped-first : ERROR ; second(x) : trigger(HELD(args),x), held = NO-HELD-STEP ; skipped-second : held = NO-HELD-STEP ; double(x) : ERROR ; late-let(x) : ERROR (require scheme/contract scheme/match scheme/class scheme/list (prefix-in a: "annotate.ss") (prefix-in r: "reconstruct.ss") "shared.ss" "marks.ss" "model-settings.ss" "macro-unwind.ss" "lifting.ss" (prefix-in test-engine: test-engine/scheme-tests) #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") ;; for breakpoint display ;; (commented out to allow nightly testing) #;"display-break-stuff.ss" (for-syntax scheme/base)) (define program-expander-contract ((-> void?) ; init ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter . -> . void?)) (provide/contract [go (->* (program-expander-contract ; program-expander (step-result? . -> . void?) ; receive-result (or/c render-settings? false/c)) ; render-settings (#:raw-step-receiver (-> continuation-mark-set? symbol? void?) #:disable-error-handling? boolean?) void?)]) (define-struct posn-info (posn span)) (provide (struct-out posn-info)) ; go starts a stepper instance ; see provide stmt for contract (define (go program-expander receive-result render-settings #: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 ;; re-rendered at each step. (define finished-exps null) (define/contract add-to-finished ((-> syntax?) (or/c (listof natural-number/c) false/c) (-> any) . -> . void?) (lambda (exp-thunk lifting-indices getter) (set! finished-exps (append finished-exps (list (list exp-thunk lifting-indices getter)))))) ;; the "held" variables are used to store the "before" step. (define held-exp-list the-no-sexp) (define-struct held (exps was-app? source-info)) (define held-finished-list null) (define (reset-held-exp-list) (set! held-exp-list the-no-sexp) (set! held-finished-list null) (set! lhs-recon-thunk null)) ; used when determining whether to skip step with ellipses on LHS (define last-rhs-exps null) ; thunk that can re-reconstruct the last lhs (define lhs-recon-thunk null) ; used to resolve lhs ellipses, to make sure highlighting is correct ; steps are pushed onto the stack: ; when step=? but not step-and-highlight=? ; steps are popped off the stack: ; lhs = ellipses and rhs != last-rhs-exps and skips = 0 ; skips are defined for each fn in lazy-highlighting.rkt; ; # of skips depends on # of hidden !'s in fn def (define highlight-stack null) (define (highlight-stack-push mark-list) (let ([top-called-fn (find-top-called-fn mark-list)]) (when DEBUG (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)) (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))) ;; highlight-mutated-expressions : ;; ((listof (list/c syntax? syntax?)) (listof (list/c syntax? syntax?)) ;; -> (list/c (listof syntax?) (listof syntax?))) ;; highlights changes occurring due to mutation. This function accepts the ;; left-hand-side expressions and the right-hand-side expressions, and ;; matches them against each other to see which ones have changed due to ;; mutation, and highlights these. ;; POSSIBLE RESEARCH POINT: if, say, (list 3 4) is mutated to (list 4 5), ;; should the 4 & 5 be highlighted individually or should the list as a ;; whole be highlighted. Is either one "wrong?" equivalences between ;; reduction semantics? ;; ;; 2005-11-14: punting. just highlight the whole darn thing if there are ;; any differences. In fact, just test for eq?-ness. #; (define (highlight-mutated-expressions lefts rights) (if (or (null? lefts) (null? rights)) (list lefts rights) (let ([left-car (car lefts)] [right-car (car rights)]) (if (eq? (syntax-property left-car 'user-source) (syntax-property right-car 'user-source)) (let ([highlights-added (highlight-mutated-expression left-car right-car)] [rest (highlight-mutated-expressions (cdr lefts) (cdr rights))]) (cons (cons (car highlights-added) (car rest)) (cons (cadr highlights-added) (cadr rest)))))))) ;; highlight-mutated-expression: syntax? syntax? -> syntax? ;; given two expressions, highlight 'em both if they differ at all. ;; notes: wanted to use simple "eq?" test... but this will fail when a ;; being-stepped definition (e.g. in a let) turns into a permanent one. ;; We pay a terrible price for the lifting thing. And, for the fact that ;; the highlighting follows from the reductions but can't obviously be ;; deduced from them. #; (define (highlight-mutated-expression left right) (cond ;; if either one is already highlighted, leave them alone. [(or (stepper-syntax-property left 'stepper-highlight) (stepper-syntax-property right 'stepper-highlight)) (list left right)] ;; first pass: highlight if not eq?. Should be broken for local-bound ;; things as they pass into permanence. [(eq? left right) (list left right)] [else (list (stepper-syntax-property left 'stepper-highlight) (stepper-syntax-property right 'stepper-highlight))])) ;; mutated on receipt of a break, used in displaying breakpoint stuff. (define steps-received 0) (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: ;; (commented out to allow nightly tests to proceed, 2007-09-04 #;(when (getenv "PLTSTEPPERUNSAFE") (let ([steps-received/current steps-received]) (run-on-drscheme-side (lambda () (display-break-stuff steps-received/current mark-set break-kind returned-value-list))))) (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 (match-lambda [(list source-thunk lifting-indices getter) (let ([source (source-thunk)]) (if (r:hide-completed? source) #f (match (r:reconstruct-completed source lifting-indices getter render-settings) [(vector exp #f) (unwind exp render-settings)] [(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))) (define-syntax (with-DEBUG stx) (syntax-case stx () [(_ exp msg) #'(and exp (when DEBUG (printf msg)))])) ; sends a step to the stepper, except if ; - lhs = rhs ; - lhs = ellipses, highlight-stack = null (ie, this is first step) ; - lhs = ellipses, rhs = last-rhs-exps ; when lhs = ellipses, and highlight-stack != null, ; pop step from stack and use lhs (define (send-step lhs-exps lhs-finished-exps rhs-exps rhs-finished-exps step-kind lhs-posn-info rhs-posn-info) (define (send-it) (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") (printf "LHS = ~a\n" (map syntax->hilite-datum lhs-exps)) (printf "RHS = ~a\n" (map syntax->hilite-datum rhs-exps))) (set! last-rhs-exps rhs-exps)) (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))) (cond ; SKIPPING step, lhs = rhs ; if highlights differ, push highlight-stack and set last-rhs-exp [(step=? lhs-exps rhs-exps) (when DEBUG (printf "SKIPPING STEP (LHS = RHS)\n")) (when (not (step-and-highlight=? lhs-exps rhs-exps)) (when DEBUG (printf "Pushing onto highlight-stack:\n ~a thunk\n" (syntax->hilite-datum (car lhs-exps)))) (highlight-stack-push mark-list) (set! last-rhs-exps rhs-exps))] [(step=? lhs-exps (list #'(... ...))) (cond ; SKIPPING step, lhs = ellipses and rhs = last-rhs-exps [(step=? rhs-exps last-rhs-exps) (when DEBUG (printf "SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n"))] ; SKIPPING step, lhs = ellipses and highlight-stack = null and last-rhs = null ; if last-rhs != null, send step (lhs = ...) [(null? highlight-stack) (if (not (null? last-rhs-exps)) (send-it) (when DEBUG (printf "SKIPPING STEP (LHS = ellipses and highlight-stack = null)\n")))] ; 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 ([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)) (when (not (null? last-rhs-exps)) (send-it))))])] ; sending step [else (send-it)])) ; 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))) (define (step-and-highlight=? lhs rhs) (equal? (map syntax->hilite-datum lhs) (map syntax->hilite-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 (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 (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")) (let* ([lhs-reconstructed (r:reconstruct-left-side 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)) (set! lhs-recon-thunk (λ () (when DEBUG (printf "\nforcing saved MARKLIST\n") (for-each (λ (x) (printf "~a\n" (display-mark x))) mark-list) (printf "saved RETURNED VALUE LIST: ~a\n" returned-value-list)) (map (λ (exp) (unwind exp render-settings)) (maybe-lift (r:reconstruct-left-side mark-list returned-value-list render-settings) #f))))))] ; CASE: result-exp-break or result-value-break ---------------- [(result-exp-break result-value-break) (let ([reconstruct (lambda () (let* ([rhs-reconstructed (r:reconstruct-right-side 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 (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-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)) (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. (when (not (eq? held-exp-list the-no-sexp)) (error 'break-reconstruction "held-exp-list not empty when a double-break occurred")) (let* ([new-finished-list (reconstruct-all-completed)] [reconstruct-result (r:reconstruct-double-break mark-list 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))] [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 (compute-posn-info) (compute-posn-info)))] ; CASE: expr-finished-break ----------------------------------- [(expr-finished-break) (unless (not mark-list) (error 'break "expected no mark-list with expr-finished-break")) ;; in an expr-finished-break, the returned-vals hold (listof ;; (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)] [else (error 'break "unknown label on break")])))))) (define maybe-lift (if (render-settings-lifting? render-settings) lift ;; ... oh dear; model.ss should disable the double-break & late-let break when lifting is off. (lambda (stx dont-care) (list stx)))) (define (step-through-expression expanded expand-next-expression) (define show-lambdas-as-lambdas? (render-settings-show-lambdas-as-lambdas? render-settings)) (let* ([annotated (a:annotate expanded break show-lambdas-as-lambdas?)]) (parameterize ([test-engine:test-silence #t]) (eval-syntax annotated)) (expand-next-expression))) (define (err-display-handler message exn) (match held-exp-list [(struct no-sexp ()) (receive-result (make-error-result message))] [(struct held (exps dc posn-info)) (begin (receive-result (make-before-error-result (append held-finished-list exps) message posn-info)) (set! held-exp-list the-no-sexp))])) (program-expander (lambda () (unless disable-error-handling? (error-display-handler err-display-handler))) (lambda (expanded continue-thunk) ; iter (r:reset-special-values) (if (eof-object? expanded) (begin (receive-result (make-finished-stepping))) (step-through-expression expanded continue-thunk))))) ; no-sexp is used to indicate no sexpression for display. ; e.g., on an error message, there's no sexp. (define-struct no-sexp ()) (define the-no-sexp (make-no-sexp)) ; skipped-step is used to indicate that the "before" step was skipped. (define-struct skipped-step ()) (define the-skipped-step (make-skipped-step)) ;; produce a posn-info structure or false based on the information in a mark-list ;; mark-list->posn-info : (listof mark) -> (or/c posn-info? false?) (define (mark-list->posn-info mark-list) (let* ([first-mark-source (mark-source (car mark-list))] [posn (syntax-position first-mark-source)] [span (syntax-span first-mark-source)]) (if posn (make-posn-info posn span) #f)))