From d8d91aff0b190e5a681d05b07a99a558b5436549 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 9 Aug 2006 22:59:46 +0000 Subject: [PATCH] * Misc reformatting in model.ss * A much improved display-break gadget svn: r4012 --- .../stepper/private/display-break-stuff.ss | 99 ++-- collects/stepper/private/model.ss | 435 ++++++++++-------- 2 files changed, 304 insertions(+), 230 deletions(-) diff --git a/collects/stepper/private/display-break-stuff.ss b/collects/stepper/private/display-break-stuff.ss index 2a7a1e51f2..a83928cb6f 100644 --- a/collects/stepper/private/display-break-stuff.ss +++ b/collects/stepper/private/display-break-stuff.ss @@ -1,38 +1,67 @@ (module display-break-stuff mzscheme - - (require (lib "mred.ss" "mred") - (lib "class.ss") - "marks.ss") - + (require (lib "mred.ss" "mred") (lib "class.ss") "marks.ss") + (provide display-break-stuff) - - ;; display-break-stuff : show the information associated with a breakpoint. Useful for - ;; people building steppers for new languages - (define (display-break-stuff break-number mark-set break-kind returned-value-list) - (define f (instantiate frame% () [label "breakpoint information"] [width 300] [height 500])) - (define ec (instantiate editor-canvas% () [parent f])) - (define t (instantiate text% ())) - (send ec set-editor t) - (send f show #t) - (send t insert (format "breakpoint number: ~v\n\n" break-number)) - (send t insert (format "break-kind: ~v \n\n" break-kind)) - (send t insert "marks:\n") - (if mark-set - (map (display-breakpoint-mark t) (extract-mark-list mark-set)) - (send t insert " no mark-set!\n")) - (send t insert "\nreturned-value-list:\n") - (send t insert (format " ~v\n" returned-value-list))) - - (define ((display-breakpoint-mark t) mark) - (let* ([em (expose-mark mark)] - [source (car em)] - [label (cadr em)] - [binding-set (caddr em)]) - (send t insert "\n") - (send t insert (format " label: ~v\n" label)) - ;; we really want one of those nice collapsible syntax-viewer thingies here: - (send t insert (format " source : ~v\n" (syntax-object->datum source))) - ;; here too, though this isn't a syntax object. - (send t insert (format " bindings: ~v\n" binding-set)))) - ) \ No newline at end of file + + (define f + (new frame% + [label (format "Breakpoints Inspector")] + [width 400] [height 500])) + (define sel (new choice% [label "Breakpoint#"] [choices '()] [parent f] + [callback (lambda (c e) (show-sel))] [stretchable-width #t])) + (define ec (new editor-canvas% [parent f])) + (define t (new text%)) + (send ec set-editor t) + + (define selections '()) + (define (add-sel num mset bkind retvals) + (set! selections (cons (list num mset bkind retvals) selections)) + (let ([num (number->string num)]) + (send sel append num) + (send sel set-string-selection num) + (show-sel))) + + (define (show-sel) + (let* ([num (string->number (send sel get-string-selection))] + [bpt (assq num selections)]) + (send* t (lock #f) (erase)) + (if (not bpt) + (send* t (insert (format "Breakpoint #~a not found!\n" num))) + (let-values ([(mset bkind retvals) (apply values (cdr bpt))]) + (send* t + (insert (format "Breakpoint #~a:\n" num)) + (insert (format " break-kind: ~v\n" bkind)) + (insert "marks:\n")) + (if mset + (for-each + (lambda (mark) + (let* ([em (expose-mark mark)] + [source (car em)] + [label (cadr em)] + [binding-set (caddr em)]) + (send* t + (insert (format " label: ~v\n" label)) + ;; we really want one of those nice collapsible + ;; syntax-viewer thingies here: + (insert (format " source : ~v\n" + (syntax-object->datum source))) + ;; here too, though this isn't a syntax object. + (insert (format " bindings: ~v\n" binding-set))))) + (extract-mark-list mset)) + (send t insert " nothing!\n")) + (send t insert "returned-value-list:\n") + (if retvals + (for-each (lambda (v) (send t insert (format " ~v\n" v))) + retvals) + (send t insert " nothing!\n")))) + (send* t (lock #t)))) + + ;; display-break-stuff : show the information associated with a breakpoint. + ;; Useful for people building steppers for new languages + (define (display-break-stuff break-number mark-set break-kind + returned-value-list) + (add-sel break-number mark-set break-kind returned-value-list) + (send f show #t)) + + ) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 039bf44fa6..0d1896a547 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -1,25 +1,28 @@ ;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 +; edge-names: first, skipped-first, second, skipped-second, double, late-let ; ;transitions (& actions): ; -; held = NO-HELD-STEP : +; 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 +; 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 +; 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 @@ -43,95 +46,108 @@ "marks.ss" "model-settings.ss" "macro-unwind.ss" - ;; for breakpoint display "display-break-stuff.ss") - - + (define program-expander-contract ((-> void?) ; init - ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter + ((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 - boolean? ; track-inferred-names? - string? ; language-level-name - (procedure? . -> . void?) ; run-on-drscheme-side - . -> . - void?)]) - + + (provide/contract + [go (program-expander-contract ; program-expander + (step-result? . -> . void?) ; receive-result + (or/c render-settings? false/c) ; render-settings + boolean? ; track-inferred-names? + string? ; language-level-name + (procedure? . -> . void?) ; run-on-drscheme-side + . -> . + void?)]) + ; go starts a stepper instance - ; see provide stmt for contract - (define (go program-expander receive-result render-settings track-inferred-names? language-level-name run-on-drscheme-side) - - ;; 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. + ; see provide stmt for contract + (define (go program-expander receive-result render-settings + track-inferred-names? language-level-name run-on-drscheme-side) + + ;; 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?) + ((-> 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. + (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 no-sexp) (define held-step-was-app? #f) (define held-finished-list null) - - ;; 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 damn 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 (syntax-property left 'stepper-highlight) - (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 (syntax-property left 'stepper-highlight) - (syntax-property right 'stepper-highlight))])) - + ;; 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 damn 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 (syntax-property left 'stepper-highlight) + (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 (syntax-property left 'stepper-highlight) + (syntax-property right 'stepper-highlight))])) + ;; mutated on receipt of a break, used in displaying breakpoint stuff. (define steps-received 0) - - (define break + + (define break (opt-lambda (mark-set break-kind [returned-value-list #f]) (set! steps-received (+ steps-received 1)) @@ -140,144 +156,173 @@ (let ([steps-received/current steps-received]) (run-on-drscheme-side (lambda () - (display-break-stuff steps-received/current mark-set break-kind returned-value-list))))) + (display-break-stuff + steps-received/current + mark-set break-kind returned-value-list))))) - ;; bizarrely, this causes something in the test tool startup to fail with - ;; current-eventspace: expects argument of type ; given #f + ;; bizarrely, this causes something in the test tool startup to fail + ;; with: + ;; current-eventspace: expects argument of type ; given #f ;; === context === - ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1183:10: queue-user/wait method in ...cheme/private/rep.ss:480:8 - ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1094:10: init-evaluation-thread method in ...cheme/private/rep.ss:480:8 - ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1346:10: reset-console method in ...cheme/private/rep.ss:480:8 - ;; /Users/clements/plt/collects/mztake/debug-tool.ss:510:10: reset-console method in ...mztake/debug-tool.ss:428:8 - ;; /Users/clements/plt/collects/test-suite/tool.ss:162:10: reset-console method in ...s/test-suite/tool.ss:137:8 - ;; /Users/clements/plt/collects/drscheme/private/rep.ss:1413:10: initialize-console method in ...cheme/private/rep.ss:480:8 - ;; /Users/clements/plt/collects/drscheme/private/unit.ss:3200:6: create-new-drscheme-frame - ;; /Users/clements/plt/collects/drscheme/private/main.ss:372:6: make-basic + ;; ...collects/drscheme/private/rep.ss:1183:10: queue-user/wait method in ...cheme/private/rep.ss:480:8 + ;; ...collects/drscheme/private/rep.ss:1094:10: init-evaluation-thread method in ...cheme/private/rep.ss:480:8 + ;; ...collects/drscheme/private/rep.ss:1346:10: reset-console method in ...cheme/private/rep.ss:480:8 + ;; ...collects/mztake/debug-tool.ss:510:10: reset-console method in ...mztake/debug-tool.ss:428:8 + ;; ...collects/test-suite/tool.ss:162:10: reset-console method in ...s/test-suite/tool.ss:137:8 + ;; ...collects/drscheme/private/rep.ss:1413:10: initialize-console method in ...cheme/private/rep.ss:480:8 + ;; ...collects/drscheme/private/unit.ss:3200:6: create-new-drscheme-frame + ;; ...collects/drscheme/private/main.ss:372:6: make-basic ;; ... okay, the error was transient. wonder what caused it? - + (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) - + (define (reconstruct-all-completed) - (map (match-lambda + (map (match-lambda [`(,source-thunk ,lifting-indices ,getter) - (match (r:reconstruct-completed (source-thunk) lifting-indices getter render-settings) + (match (r:reconstruct-completed + (source-thunk) lifting-indices + getter render-settings) [#(exp #f) (first-of-one (unwind-no-highlight exp))] - [#(exp #t) exp])]) + [#(exp #t) exp])]) finished-exps)) - - #;(printf "break called with break-kind: ~a ..." break-kind) + + ;; (printf "break called with break-kind: ~a ..." break-kind) (if (r:skip-step? break-kind mark-list render-settings) - (begin - #;(printf " but it was skipped!\n") - (when (or (eq? break-kind 'normal-break) - (eq? break-kind 'nomal-break/values)) ;; not sure about this... - (set! held-exp-list skipped-step))) - - (begin - #;(printf "and it wasn't skipped.\n") - (case break-kind - [(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 (unwind (r:reconstruct-left-side mark-list returned-value-list render-settings) #f)) - (set! held-step-was-app? (r:step-was-app? mark-list)))] - - [(result-exp-break result-value-break) - (if (eq? held-exp-list skipped-step) - ; don't render if before step was a skipped-step - (set! held-exp-list no-sexp) - - (let* ([new-finished-list (reconstruct-all-completed)] - [reconstructed (unwind (r:reconstruct-right-side mark-list returned-value-list render-settings) #f)] - [result - (if (eq? held-exp-list no-sexp) - ;; 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. - (make-before-after-result - (list #`(... ...)) - (append new-finished-list reconstructed) - 'normal) - - (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-exp-list) - (append new-finished-list reconstructed))]) - - (make-before-after-result left-exps right-exps step-kind)))]) - (set! held-exp-list no-sexp) - (receive-result result)))] - - [(double-break) - ;; a double-break occurs at the beginning of a let's evaluation. - (when (not (eq? held-exp-list 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)] - [left-side (unwind (car reconstruct-result) #f)] - [right-side (unwind (cadr reconstruct-result) #t)]) - ;; add highlighting code as for other cases... - (receive-result (make-before-after-result (append new-finished-list left-side) - (append new-finished-list right-side) - 'normal)))] - - - [(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. - (for-each (lambda (source/index/getter) - (apply add-to-finished source/index/getter)) - returned-value-list)] - - [else (error 'break "unknown label on break")])))))) - - - - + (begin + ;; (printf " but it was skipped!\n") + (when (or (eq? break-kind 'normal-break) + ;; not sure about this... + (eq? break-kind 'nomal-break/values)) + (set! held-exp-list skipped-step))) + + (begin + ;; (printf "and it wasn't skipped.\n") + (case break-kind + [(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 + (unwind + (r:reconstruct-left-side + mark-list returned-value-list render-settings) + #f)) + (set! held-step-was-app? (r:step-was-app? mark-list)))] + + [(result-exp-break result-value-break) + (if (eq? held-exp-list skipped-step) + ;; don't render if before step was a skipped-step + (set! held-exp-list no-sexp) + + (let* ([new-finished-list (reconstruct-all-completed)] + [reconstructed + (unwind + (r:reconstruct-right-side + mark-list returned-value-list render-settings) + #f)] + [result + (if (eq? held-exp-list no-sexp) + ;; 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. + (make-before-after-result + (list #`(... ...)) + (append new-finished-list reconstructed) + 'normal) + + (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-exp-list) + (append new-finished-list + reconstructed))]) + + (make-before-after-result + left-exps right-exps step-kind)))]) + (set! held-exp-list no-sexp) + (receive-result result)))] + + [(double-break) + ;; a double-break occurs at the beginning of a let's + ;; evaluation. + (when (not (eq? held-exp-list 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)] + [left-side (unwind (car reconstruct-result) #f)] + [right-side (unwind (cadr reconstruct-result) #t)]) + ;; add highlighting code as for other cases... + (receive-result + (make-before-after-result + (append new-finished-list left-side) + (append new-finished-list right-side) + 'normal)))] + + [(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. + (for-each (lambda (source/index/getter) + (apply add-to-finished source/index/getter)) + returned-value-list)] + + [else (error 'break "unknown label on break")])))))) + + (define (step-through-expression expanded expand-next-expression) - (let* ([annotated (a:annotate expanded break track-inferred-names? language-level-name)]) + (let* ([annotated (a:annotate expanded break track-inferred-names? + language-level-name)]) (eval-syntax annotated) (expand-next-expression))) - + (define (err-display-handler message exn) (if (not (eq? held-exp-list no-sexp)) - (begin - (receive-result (make-before-error-result (append held-finished-list held-exp-list) - message)) - (set! held-exp-list no-sexp)) - (receive-result (make-error-result message)))) - + (begin + (receive-result + (make-before-error-result (append held-finished-list held-exp-list) + message)) + (set! held-exp-list no-sexp)) + (receive-result (make-error-result message)))) + (program-expander - (lambda () - ; swap these to allow errors to escape (e.g., when debugging) + (lambda () + ;; swap these to allow errors to escape (e.g., when debugging) (error-display-handler err-display-handler) - #;(void) + ;; (void) ) (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))))) - - - (define (first-of-one x) + (begin + (receive-result (make-finished-stepping))) + (step-through-expression expanded continue-thunk))))) + + + (define (first-of-one x) (unless (and (pair? x) (null? (cdr x))) (error 'first-of-one "expected a list of length one in: ~v" x)) (car x)))