Clean up interpreter and walker
parent
849c83247d
commit
deb1406f83
|
@ -1,18 +1,31 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.interpreter namespaces kernel arrays continuations
|
||||
threads sequences ;
|
||||
USING: tools.interpreter kernel arrays continuations threads
|
||||
sequences namespaces ;
|
||||
IN: tools.interpreter.debug
|
||||
|
||||
: run-interpreter ( -- )
|
||||
interpreter get [ step-into run-interpreter ] when ;
|
||||
: run-interpreter ( interpreter -- )
|
||||
dup interpreter-continuation [
|
||||
dup step-into run-interpreter
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: init-interpreter ( quot -- )
|
||||
: quot>cont ( quot -- cont )
|
||||
[
|
||||
"out" set
|
||||
[ f swap 2array restore "out" get continue ] callcc0
|
||||
] swap [ datastack "datastack" set stop ]
|
||||
3append callcc0 ;
|
||||
swap [
|
||||
continue-with
|
||||
] curry callcc0 call stop
|
||||
] curry callcc1 ;
|
||||
|
||||
: init-interpreter ( quot interpreter -- )
|
||||
>r
|
||||
[ datastack "datastack" set ] compose quot>cont
|
||||
f swap 2array
|
||||
r> restore ;
|
||||
|
||||
: test-interpreter ( quot -- )
|
||||
init-interpreter run-interpreter "datastack" get ;
|
||||
<interpreter>
|
||||
[ init-interpreter ] keep
|
||||
run-interpreter
|
||||
"datastack" get ;
|
||||
|
|
|
@ -2,7 +2,13 @@ USING: help.markup help.syntax kernel generic
|
|||
math hashtables quotations classes continuations ;
|
||||
IN: tools.interpreter
|
||||
|
||||
ARTICLE: "meta-interp-step" "Single-stepping words"
|
||||
ARTICLE: "meta-interpreter" "Meta-circular interpreter"
|
||||
"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
|
||||
$nl
|
||||
"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
|
||||
$nl
|
||||
"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
|
||||
$nl
|
||||
"Breakpoints can be inserted in user code:"
|
||||
{ $subsection break }
|
||||
"Breakpoints invoke a hook:"
|
||||
|
@ -13,40 +19,16 @@ ARTICLE: "meta-interp-step" "Single-stepping words"
|
|||
{ $subsection step-out }
|
||||
{ $subsection step-all } ;
|
||||
|
||||
ARTICLE: "meta-interp-travel" "Backwards time travel"
|
||||
"Backwards time travel is implemented by capturing the continuation after every step. Since this consumes additional memory, it must be explicitly enabled by storing an empty vector into a variable:"
|
||||
{ $subsection history }
|
||||
"If this variable holds a vector, the interpreter state is automatically saved after every step. It can be saved at other points manually:"
|
||||
{ $subsection save-interpreter }
|
||||
"Or restore the most recently saved state:"
|
||||
{ $subsection step-back } ;
|
||||
|
||||
ARTICLE: "meta-interpreter" "Meta-circular interpreter"
|
||||
"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
|
||||
$nl
|
||||
"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
|
||||
$nl
|
||||
"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
|
||||
$nl
|
||||
"The current interpreter state is stored in the " { $link interpreter } " variable."
|
||||
{ $subsection "meta-interp-step" }
|
||||
{ $subsection "meta-interp-travel" } ;
|
||||
|
||||
ABOUT: "meta-interpreter"
|
||||
|
||||
HELP: interpreter
|
||||
{ $var-description "Variable holding a " { $link continuation } " instance for the single-stepper." } ;
|
||||
{ $class-description "An interpreter instance." } ;
|
||||
|
||||
HELP: break
|
||||
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
|
||||
|
||||
HELP: history
|
||||
{ $var-description "A sequence of continuations, captured at every stage of single-stepping. Used by " { $link step-back } " to implement backwards time travel." } ;
|
||||
|
||||
HELP: save-interpreter
|
||||
{ $description "Snapshots the single stepper state and saves it in " { $link history } "." } ;
|
||||
|
||||
HELP: step
|
||||
{ $values { "interpreter" interpreter } }
|
||||
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
|
||||
{ $list
|
||||
{ "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
|
||||
|
@ -56,6 +38,7 @@ HELP: step
|
|||
} ;
|
||||
|
||||
HELP: step-into
|
||||
{ $values { "interpreter" interpreter } }
|
||||
{ $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
|
||||
{ $list
|
||||
{ "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
|
||||
|
@ -66,10 +49,9 @@ HELP: step-into
|
|||
} ;
|
||||
|
||||
HELP: step-out
|
||||
{ $values { "interpreter" interpreter } }
|
||||
{ $description "Evaluates the remainder of the current quotation in the single stepper." } ;
|
||||
|
||||
HELP: step-back
|
||||
{ $description "Steps back to the most recently saved snapshot of the single stepper continuation in " { $link history } "." } ;
|
||||
|
||||
HELP: step-all
|
||||
{ $values { "interpreter" interpreter } }
|
||||
{ $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ;
|
||||
|
|
|
@ -105,54 +105,6 @@ IN: temporary
|
|||
[ [ { 1 2 3 } . ] string-out ] test-interpreter
|
||||
] unit-test
|
||||
|
||||
: meta-catch interpreter get continuation-catch ;
|
||||
|
||||
! Step back test
|
||||
! [
|
||||
! init-interpreter
|
||||
! V{ } clone meta-history set
|
||||
!
|
||||
! V{ f } clone
|
||||
! V{ } clone
|
||||
! V{ [ 1 2 3 ] 0 3 } clone
|
||||
! V{ } clone
|
||||
! V{ } clone
|
||||
! f <continuation>
|
||||
! meta-catch push
|
||||
!
|
||||
! [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test
|
||||
!
|
||||
! [ ] [ step ] unit-test
|
||||
!
|
||||
! [ ] [ step ] unit-test
|
||||
!
|
||||
! [ { 2 2 } ] [ meta-d ] unit-test
|
||||
!
|
||||
! [ ] [ step ] unit-test
|
||||
!
|
||||
! [ { 4 } ] [ meta-d ] unit-test
|
||||
! [ 3 ] [ callframe-scan get ] unit-test
|
||||
!
|
||||
! [ ] [ step-back ] unit-test
|
||||
! [ 2 ] [ callframe-scan get ] unit-test
|
||||
!
|
||||
! [ { 2 2 } ] [ meta-d ] unit-test
|
||||
!
|
||||
! [ ] [ step ] unit-test
|
||||
!
|
||||
! [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
|
||||
!
|
||||
! [ ] [ step ] unit-test
|
||||
!
|
||||
! [ [ 1 2 3 ] ] [ callframe get ] unit-test
|
||||
! [ ] [ step-back ] unit-test
|
||||
!
|
||||
! [ { 4 } ] [ meta-d ] unit-test
|
||||
!
|
||||
! [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
|
||||
!
|
||||
! [ ] [ step ] unit-test
|
||||
!
|
||||
! [ [ 1 2 3 ] ] [ callframe get ] unit-test
|
||||
!
|
||||
! ] with-scope
|
||||
[ { } ] [
|
||||
[ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope
|
||||
] unit-test
|
||||
|
|
|
@ -6,7 +6,9 @@ kernel.private math namespaces namespaces.private prettyprint
|
|||
quotations sequences splitting strings threads vectors words ;
|
||||
IN: tools.interpreter
|
||||
|
||||
SYMBOL: interpreter
|
||||
TUPLE: interpreter continuation ;
|
||||
|
||||
: <interpreter> interpreter construct-empty ;
|
||||
|
||||
SYMBOL: break-hook
|
||||
|
||||
|
@ -15,22 +17,25 @@ SYMBOL: break-hook
|
|||
over set-continuation-call
|
||||
walker-hook [ continue-with ] [ break-hook get call ] if* ;
|
||||
|
||||
: with-interpreter-datastack ( quot -- )
|
||||
interpreter get continuation-data
|
||||
swap with-datastack
|
||||
interpreter get set-continuation-data ; inline
|
||||
|
||||
GENERIC: restore ( obj -- )
|
||||
|
||||
M: continuation restore
|
||||
clone interpreter set ;
|
||||
|
||||
M: pair restore
|
||||
first2 clone interpreter set
|
||||
[ nip f ] curry with-interpreter-datastack ;
|
||||
GENERIC# restore 1 ( obj interpreter -- )
|
||||
|
||||
M: f restore
|
||||
drop interpreter off ;
|
||||
set-interpreter-continuation ;
|
||||
|
||||
M: continuation restore
|
||||
>r clone r> set-interpreter-continuation ;
|
||||
|
||||
: with-interpreter-datastack ( quot interpreter -- )
|
||||
interpreter-continuation [
|
||||
continuation-data
|
||||
swap with-datastack
|
||||
] keep set-continuation-data ; inline
|
||||
|
||||
M: pair restore
|
||||
>r first2 r> [ restore ] keep
|
||||
>r [ nip f ] curry r> with-interpreter-datastack ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (step-into-call) \ break add* call ;
|
||||
|
||||
|
@ -71,19 +76,6 @@ M: f restore
|
|||
"step-into" set-word-prop
|
||||
] each
|
||||
|
||||
! Time travel
|
||||
SYMBOL: history
|
||||
|
||||
: save-interpreter ( -- )
|
||||
history get [ interpreter get clone swap push ] when* ;
|
||||
|
||||
: restore-interpreter ( interp -- )
|
||||
clone interpreter set ;
|
||||
|
||||
: step-back ( -- )
|
||||
history get dup empty?
|
||||
[ drop ] [ pop restore-interpreter ] if ;
|
||||
|
||||
: (continue) ( continuation -- )
|
||||
>continuation<
|
||||
set-catchstack
|
||||
|
@ -93,26 +85,34 @@ SYMBOL: history
|
|||
set-callstack ;
|
||||
|
||||
! Stepping
|
||||
: step-all ( -- )
|
||||
[ interpreter get (continue) ] in-thread ;
|
||||
: change-innermost-frame ( quot interpreter -- )
|
||||
interpreter-continuation [
|
||||
continuation-call clone
|
||||
[
|
||||
dup innermost-frame-scan 1+
|
||||
swap innermost-frame-quot
|
||||
rot call
|
||||
] keep
|
||||
[ set-innermost-frame-quot ] keep
|
||||
] keep set-continuation-call ; inline
|
||||
|
||||
: change-innermost-frame ( quot -- )
|
||||
interpreter get continuation-call clone
|
||||
: (step) ( interpreter quot -- )
|
||||
swap
|
||||
[ change-innermost-frame ] keep
|
||||
[
|
||||
dup innermost-frame-scan 1+
|
||||
swap innermost-frame-quot
|
||||
rot call
|
||||
] keep
|
||||
[ set-innermost-frame-quot ] keep
|
||||
interpreter get set-continuation-call ; inline
|
||||
set-walker-hook
|
||||
interpreter-continuation (continue)
|
||||
] callcc1 swap restore ;
|
||||
|
||||
: (step) ( quot -- )
|
||||
save-interpreter
|
||||
change-innermost-frame
|
||||
[ set-walker-hook interpreter get (continue) ] callcc1
|
||||
restore ;
|
||||
GENERIC: (step-into) ( obj -- )
|
||||
|
||||
: step ( n -- )
|
||||
M: word (step-into) (step-into-execute) ;
|
||||
M: wrapper (step-into) wrapped break ;
|
||||
M: object (step-into) break ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: step ( interpreter -- )
|
||||
[
|
||||
2dup nth \ break = [
|
||||
nip
|
||||
|
@ -121,18 +121,15 @@ SYMBOL: history
|
|||
] if
|
||||
] (step) ;
|
||||
|
||||
: step-out ( -- )
|
||||
: step-out ( interpreter -- )
|
||||
[ nip \ break add ] (step) ;
|
||||
|
||||
GENERIC: (step-into) ( obj -- )
|
||||
|
||||
M: word (step-into) (step-into-execute) ;
|
||||
M: wrapper (step-into) wrapped break ;
|
||||
M: object (step-into) break ;
|
||||
|
||||
: step-into ( -- )
|
||||
: step-into ( interpreter -- )
|
||||
[
|
||||
cut [
|
||||
swap % unclip literalize , \ (step-into) , %
|
||||
] [ ] make
|
||||
] (step) ;
|
||||
|
||||
: step-all ( interpreter -- )
|
||||
interpreter-continuation [ (continue) ] curry in-thread ;
|
||||
|
|
|
@ -58,9 +58,9 @@ ARTICLE: "ui-walker" "UI walker"
|
|||
"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
|
||||
$nl
|
||||
"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
|
||||
{ $command-map walker-gadget "toolbar" }
|
||||
{ $command-map walker-gadget "other" }
|
||||
"Walkers are instances of " { $link walker-gadget } "." ;
|
||||
{ $command-map walker "toolbar" }
|
||||
{ $command-map walker "other" }
|
||||
"Walkers are instances of " { $link walker } "." ;
|
||||
|
||||
ARTICLE: "ui-profiler" "UI profiler"
|
||||
"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
|
||||
|
|
|
@ -17,7 +17,7 @@ IN: ui.tools
|
|||
<stack-display>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<walker-gadget>
|
||||
<walker>
|
||||
<profiler-gadget>
|
||||
} ;
|
||||
|
||||
|
@ -65,7 +65,7 @@ M: workspace model-changed
|
|||
|
||||
: com-inspector inspector-gadget select-tool ;
|
||||
|
||||
: com-walker walker-gadget select-tool ;
|
||||
: com-walker walker select-tool ;
|
||||
|
||||
: com-profiler profiler-gadget select-tool ;
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@ listener tools.test ui ui.gadgets ui.gadgets.worlds
|
|||
ui.gadgets.packs vectors ui.tools ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ <walker-gadget> "walker" set ] unit-test
|
||||
[ ] [ <walker "walker" set ] unit-test
|
||||
|
||||
! Make sure the toolbar buttons don't throw if we're
|
||||
! not actually walking.
|
||||
|
@ -37,7 +37,7 @@ IN: temporary
|
|||
|
||||
[ t ] [ "ok" get ] unit-test
|
||||
|
||||
[ ] [ <walker-gadget> "w" set ] unit-test
|
||||
[ ] [ <walker> "w" set ] unit-test
|
||||
continuation "c" set
|
||||
|
||||
[ ] [ "c" get "w" get call-tool* ] unit-test
|
||||
|
|
|
@ -8,61 +8,70 @@ ui.gestures ui.gadgets.buttons ui.gadgets.panes
|
|||
prettyprint.config prettyprint.backend ;
|
||||
IN: ui.tools.walker
|
||||
|
||||
TUPLE: walker-gadget model ns ;
|
||||
TUPLE: walker model interpreter history ;
|
||||
|
||||
: update-stacks ( walker -- )
|
||||
interpreter get swap walker-gadget-model set-model ;
|
||||
dup walker-interpreter interpreter-continuation
|
||||
swap walker-model set-model ;
|
||||
|
||||
: with-walker ( gadget quot -- )
|
||||
swap dup walker-gadget-ns [ slip update-stacks ] bind ;
|
||||
inline
|
||||
: with-walker ( walker quot -- )
|
||||
over >r >r walker-interpreter r> call r>
|
||||
update-stacks ; inline
|
||||
|
||||
: walker-active? ( walker -- ? )
|
||||
interpreter swap walker-gadget-ns key? ;
|
||||
walker-interpreter interpreter-continuation >boolean ;
|
||||
|
||||
: walker-command ( gadget quot -- )
|
||||
over walker-active? [ with-walker ] [ 2drop ] if ; inline
|
||||
|
||||
: com-step [ step ] walker-command ;
|
||||
: com-into [ step-into ] walker-command ;
|
||||
: com-out [ step-out ] walker-command ;
|
||||
: com-back [ step-back ] walker-command ;
|
||||
: save-interpreter ( walker -- )
|
||||
dup walker-interpreter interpreter-continuation clone
|
||||
swap walker-history push ;
|
||||
|
||||
: init-walker-models ( walker -- )
|
||||
f <model> over set-walker-gadget-model
|
||||
H{ } clone swap set-walker-gadget-ns ;
|
||||
: com-step ( walker -- )
|
||||
dup save-interpreter [ step ] walker-command ;
|
||||
|
||||
: com-into ( walker -- )
|
||||
dup save-interpreter [ step-into ] walker-command ;
|
||||
|
||||
: com-out ( walker -- )
|
||||
dup save-interpreter [ step-out ] walker-command ;
|
||||
|
||||
: com-back ( walker -- )
|
||||
dup walker-history
|
||||
dup empty? [ drop ] [ pop swap call-tool* ] if ;
|
||||
|
||||
: reset-walker ( walker -- )
|
||||
dup walker-gadget-ns clear-assoc
|
||||
[ V{ } clone history set ] with-walker ;
|
||||
<interpreter> over set-walker-interpreter
|
||||
V{ } clone over set-walker-history
|
||||
update-stacks ;
|
||||
|
||||
: <walker-gadget> ( -- gadget )
|
||||
walker-gadget construct-empty
|
||||
dup init-walker-models [
|
||||
: <walker> ( -- gadget )
|
||||
f <model> f f walker construct-boa [
|
||||
toolbar,
|
||||
g walker-gadget-model <traceback-gadget> 1 track,
|
||||
g walker-model <traceback-gadget> 1 track,
|
||||
] { 0 1 } build-track
|
||||
dup reset-walker ;
|
||||
|
||||
M: walker-gadget call-tool* ( continuation walker -- )
|
||||
M: walker call-tool* ( continuation walker -- )
|
||||
[ restore ] with-walker ;
|
||||
|
||||
: com-inspect ( walker -- )
|
||||
dup walker-active? [
|
||||
interpreter swap walker-gadget-ns at
|
||||
walker-interpreter interpreter-continuation
|
||||
[ inspect ] curry call-listener
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: com-continue ( walker -- )
|
||||
dup [ step-all ] walker-command reset-walker ;
|
||||
dup walker-interpreter step-all reset-walker ;
|
||||
|
||||
: walker-help "ui-walker" help-window ;
|
||||
|
||||
\ walker-help H{ { +nullary+ t } } define-command
|
||||
|
||||
walker-gadget "toolbar" f {
|
||||
walker "toolbar" f {
|
||||
{ T{ key-down f { A+ } "s" } com-step }
|
||||
{ T{ key-down f { A+ } "i" } com-into }
|
||||
{ T{ key-down f { A+ } "o" } com-out }
|
||||
|
@ -71,8 +80,8 @@ walker-gadget "toolbar" f {
|
|||
{ T{ key-down f f "F1" } walker-help }
|
||||
} define-command-map
|
||||
|
||||
walker-gadget "other" f {
|
||||
walker "other" f {
|
||||
{ T{ key-down f { A+ } "n" } com-inspect }
|
||||
} define-command-map
|
||||
|
||||
[ walker-gadget call-tool stop ] break-hook set-global
|
||||
[ walker call-tool stop ] break-hook set-global
|
||||
|
|
Loading…
Reference in New Issue