USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models models.filter arrays accessors
-generic generic.standard definitions make ;
+sequences.private assocs models models.arrow arrays accessors
+generic generic.standard definitions make sbufs ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
: (step-into-quot) ( quot -- ) add-breakpoint call ;
+: (step-into-dip) ( quot -- ) add-breakpoint dip ;
+
+: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
+
+: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
+
: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
-: (step-into-call-next-method) ( class generic -- )
+: (step-into-call-next-method) ( method -- )
next-method-quot (step-into-quot) ;
! Messages sent to walker thread
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- >r clone r> [
- >r clone r>
+ [ clone ] dip [
+ [ clone ] dip
[
- >r
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi
- r> call
+ [
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi
+ ] dip call
]
[ drop set-innermost-frame-quot ]
[ drop ]
2tri
] curry change-call ; inline
-: step-msg ( continuation -- continuation' )
+: step-msg ( continuation -- continuation' ) USE: io
[
- 2dup nth \ break = [
- nip
- ] [
- swap 1+ cut [ break ] swap 3append
+ 2dup length = [ nip [ break ] append ] [
+ 2dup nth \ break = [ nip ] [
+ swap 1+ cut [ break ] glue
+ ] if
] if
] change-frame ;
{
{ call [ (step-into-quot) ] }
+ { dip [ (step-into-dip) ] }
+ { 2dip [ (step-into-2dip) ] }
+ { 3dip [ (step-into-3dip) ] }
{ (throw) [ drop (step-into-quot) ] }
{ execute [ (step-into-execute) ] }
{ if [ (step-into-if) ] }
{ (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each
+! Never step into these words
{
>n ndrop >c c>
continue continue-with
: step-into-msg ( continuation -- continuation' )
[
swap cut [
- swap % unclip {
- { [ dup \ break eq? ] [ , ] }
- { [ dup quotation? ] [ add-breakpoint , \ break , ] }
- { [ dup array? ] [ add-breakpoint , \ break , ] }
- { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- [ , \ break , ]
- } cond %
+ swap %
+ [ \ break , ] [
+ unclip {
+ { [ dup \ break eq? ] [ , ] }
+ { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
+ { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+ [ , \ break , ]
+ } cond %
+ ] if-empty
] [ ] make
] change-frame ;
]
} case
] handle-synchronous
- ] [ ] while ;
+ ] while ;
: step-back-msg ( continuation -- continuation' )
walker-history tget
{ step-into-all [ step-into-all-loop ] }
{ abandon [ drop f keep-running ] }
! Pass quotation to debugged thread
- { call-in [ nip keep-running ] }
+ { call-in [ keep-running ] }
! Pass previous continuation to debugged thread
{ step-back [ step-back-msg ] }
} case f
] handle-synchronous
- ] [ ] while ;
+ ] while ;
: walker-loop ( -- )
+running+ set-status
- [ status +stopped+ eq? not ] [
+ [ status +stopped+ eq? ] [
[
{
! ignore these commands while the thread is
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] while ;
+ ] until ;
: associate-thread ( walker -- )
walker-thread tset