Merge branch 'trace_tool' of git://factorcode.org/git/factor into trace_tool
Slava Pestov
commit
72487f7f33
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,146 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: threads kernel namespaces continuations combinators
|
||||||
|
sequences math namespaces.private continuations.private
|
||||||
|
concurrency.messaging quotations kernel.private words
|
||||||
|
sequences.private assocs models models.arrow arrays accessors
|
||||||
|
generic generic.standard definitions make sbufs ;
|
||||||
|
IN: tools.continuations
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: after-break ( object -- )
|
||||||
|
{
|
||||||
|
{ [ dup continuation? ] [ (continue) ] }
|
||||||
|
{ [ dup quotation? ] [ call ] }
|
||||||
|
{ [ dup not ] [ "Single stepping abandoned" rethrow ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
SYMBOL: break-hook
|
||||||
|
|
||||||
|
: break ( -- )
|
||||||
|
continuation callstack >>call
|
||||||
|
break-hook get call
|
||||||
|
after-break ;
|
||||||
|
|
||||||
|
\ break t "break?" set-word-prop
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
GENERIC: add-breakpoint ( quot -- quot' )
|
||||||
|
|
||||||
|
M: callable add-breakpoint
|
||||||
|
dup [ break ] head? [ \ break prefix ] unless ;
|
||||||
|
|
||||||
|
M: array add-breakpoint
|
||||||
|
[ add-breakpoint ] map ;
|
||||||
|
|
||||||
|
M: object add-breakpoint ;
|
||||||
|
|
||||||
|
: (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-execute) ( word -- )
|
||||||
|
{
|
||||||
|
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||||
|
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
|
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
||||||
|
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
||||||
|
{ [ dup primitive? ] [ execute break ] }
|
||||||
|
[ def>> (step-into-quot) ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
\ (step-into-execute) t "step-into?" set-word-prop
|
||||||
|
|
||||||
|
: (step-into-continuation) ( -- )
|
||||||
|
continuation callstack >>call break ;
|
||||||
|
|
||||||
|
: (step-into-call-next-method) ( method -- )
|
||||||
|
next-method-quot (step-into-quot) ;
|
||||||
|
|
||||||
|
: change-frame ( continuation quot -- continuation' )
|
||||||
|
#! Applies quot to innermost call frame of the
|
||||||
|
#! continuation.
|
||||||
|
[ clone ] dip [
|
||||||
|
[ clone ] dip
|
||||||
|
[
|
||||||
|
[
|
||||||
|
[ innermost-frame-scan 1+ ]
|
||||||
|
[ innermost-frame-quot ] bi
|
||||||
|
] dip call
|
||||||
|
]
|
||||||
|
[ drop set-innermost-frame-quot ]
|
||||||
|
[ drop ]
|
||||||
|
2tri
|
||||||
|
] curry change-call ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: continuation-step ( continuation -- continuation' )
|
||||||
|
[
|
||||||
|
2dup length = [ nip [ break ] append ] [
|
||||||
|
2dup nth \ break = [ nip ] [
|
||||||
|
swap 1+ cut [ break ] glue
|
||||||
|
] if
|
||||||
|
] if
|
||||||
|
] change-frame ;
|
||||||
|
|
||||||
|
: continuation-step-out ( continuation -- continuation' )
|
||||||
|
[ nip \ break suffix ] change-frame ;
|
||||||
|
|
||||||
|
|
||||||
|
{
|
||||||
|
{ call [ (step-into-quot) ] }
|
||||||
|
{ dip [ (step-into-dip) ] }
|
||||||
|
{ 2dip [ (step-into-2dip) ] }
|
||||||
|
{ 3dip [ (step-into-3dip) ] }
|
||||||
|
{ execute [ (step-into-execute) ] }
|
||||||
|
{ if [ (step-into-if) ] }
|
||||||
|
{ dispatch [ (step-into-dispatch) ] }
|
||||||
|
{ continuation [ (step-into-continuation) ] }
|
||||||
|
{ (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
|
||||||
|
stop suspend (spawn)
|
||||||
|
} [
|
||||||
|
dup [ execute break ] curry
|
||||||
|
"step-into" set-word-prop
|
||||||
|
] each
|
||||||
|
|
||||||
|
\ break [ break ] "step-into" set-word-prop
|
||||||
|
|
||||||
|
: continuation-step-into ( continuation -- continuation' )
|
||||||
|
[
|
||||||
|
swap cut [
|
||||||
|
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 ;
|
||||||
|
|
||||||
|
: continuation-current ( continuation -- obj )
|
||||||
|
call>>
|
||||||
|
[ innermost-frame-scan 1+ ]
|
||||||
|
[ innermost-frame-quot ] bi ?nth ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1,66 @@
|
||||||
|
! Copyright (C) 2009 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: concurrency.promises models tools.continuations kernel
|
||||||
|
sequences concurrency.messaging locals continuations
|
||||||
|
threads namespaces namespaces.private make assocs accessors
|
||||||
|
io strings prettyprint math words effects summary io.styles
|
||||||
|
classes ;
|
||||||
|
IN: tools.trace
|
||||||
|
|
||||||
|
: callstack-depth ( callstack -- n )
|
||||||
|
callstack>array length ;
|
||||||
|
|
||||||
|
SYMBOL: end
|
||||||
|
|
||||||
|
SYMBOL: exclude-vocabs
|
||||||
|
SYMBOL: include-vocabs
|
||||||
|
|
||||||
|
exclude-vocabs { "kernel" "math" "accessors" } swap set-global
|
||||||
|
|
||||||
|
: include? ( vocab -- ? )
|
||||||
|
include-vocabs get dup [ member? ] [ 2drop t ] if ;
|
||||||
|
|
||||||
|
: exclude? ( vocab -- ? )
|
||||||
|
exclude-vocabs get dup [ member? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: into? ( obj -- ? )
|
||||||
|
dup word? [
|
||||||
|
dup predicate? [ drop f ] [
|
||||||
|
vocabulary>> [ include? ] [ exclude? not ] bi and
|
||||||
|
] if
|
||||||
|
] [ drop t ] if ;
|
||||||
|
|
||||||
|
TUPLE: trace-step word inputs ;
|
||||||
|
|
||||||
|
M: trace-step summary
|
||||||
|
[
|
||||||
|
[ "Word: " % word>> name>> % ]
|
||||||
|
[ " -- inputs: " % inputs>> unparse-short % ] bi
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
|
: <trace-step> ( continuation word -- trace-step )
|
||||||
|
[ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi
|
||||||
|
\ trace-step boa ;
|
||||||
|
|
||||||
|
: print-step ( continuation -- )
|
||||||
|
dup continuation-current dup word? [
|
||||||
|
[ nip name>> ] [ <trace-step> ] 2bi write-object nl
|
||||||
|
] [
|
||||||
|
nip short.
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: trace-step ( continuation -- continuation' )
|
||||||
|
dup continuation-current end eq? [
|
||||||
|
[ call>> callstack-depth 2/ CHAR: \s <string> write ]
|
||||||
|
[ print-step ]
|
||||||
|
[
|
||||||
|
dup continuation-current into?
|
||||||
|
[ continuation-step-into ] [ continuation-step ] if
|
||||||
|
]
|
||||||
|
tri
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
: trace ( quot -- data )
|
||||||
|
[ [ trace-step ] break-hook ] dip
|
||||||
|
[ break ] [ end drop ] surround
|
||||||
|
with-variable ;
|
||||||
|
|
@ -1,10 +1,11 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: threads kernel namespaces continuations combinators
|
USING: threads kernel namespaces continuations combinators
|
||||||
sequences math namespaces.private continuations.private
|
sequences math namespaces.private continuations.private
|
||||||
concurrency.messaging quotations kernel.private words
|
concurrency.messaging quotations kernel.private words
|
||||||
sequences.private assocs models models.arrow arrays accessors
|
sequences.private assocs models models.arrow arrays accessors
|
||||||
generic generic.standard definitions make sbufs ;
|
generic generic.standard definitions make sbufs
|
||||||
|
tools.continuations ;
|
||||||
IN: tools.walker
|
IN: tools.walker
|
||||||
|
|
||||||
SYMBOL: show-walker-hook ! ( status continuation thread -- )
|
SYMBOL: show-walker-hook ! ( status continuation thread -- )
|
||||||
|
|
@ -31,66 +32,16 @@ DEFER: start-walker-thread
|
||||||
2dup start-walker-thread
|
2dup start-walker-thread
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
: show-walker ( -- thread )
|
|
||||||
get-walker-thread
|
|
||||||
[ show-walker-hook get call ] keep ;
|
|
||||||
|
|
||||||
: after-break ( object -- )
|
|
||||||
{
|
|
||||||
{ [ dup continuation? ] [ (continue) ] }
|
|
||||||
{ [ dup quotation? ] [ call ] }
|
|
||||||
{ [ dup not ] [ "Single stepping abandoned" rethrow ] }
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
: break ( -- )
|
|
||||||
continuation callstack >>call
|
|
||||||
show-walker send-synchronous
|
|
||||||
after-break ;
|
|
||||||
|
|
||||||
\ break t "break?" set-word-prop
|
|
||||||
|
|
||||||
: walk ( quot -- quot' )
|
: walk ( quot -- quot' )
|
||||||
\ break prefix [ break rethrow ] recover ;
|
\ break prefix [ break rethrow ] recover ;
|
||||||
|
|
||||||
GENERIC: add-breakpoint ( quot -- quot' )
|
break-hook [
|
||||||
|
[
|
||||||
M: callable add-breakpoint
|
get-walker-thread
|
||||||
dup [ break ] head? [ \ break prefix ] unless ;
|
[ show-walker-hook get call ] keep
|
||||||
|
send-synchronous
|
||||||
M: array add-breakpoint
|
]
|
||||||
[ add-breakpoint ] map ;
|
] initialize
|
||||||
|
|
||||||
M: object add-breakpoint ;
|
|
||||||
|
|
||||||
: (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-execute) ( word -- )
|
|
||||||
{
|
|
||||||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
|
||||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
|
||||||
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
|
||||||
{ [ dup uses \ suspend swap member? ] [ execute break ] }
|
|
||||||
{ [ dup primitive? ] [ execute break ] }
|
|
||||||
[ def>> (step-into-quot) ]
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
\ (step-into-execute) t "step-into?" set-word-prop
|
|
||||||
|
|
||||||
: (step-into-continuation) ( -- )
|
|
||||||
continuation callstack >>call break ;
|
|
||||||
|
|
||||||
: (step-into-call-next-method) ( method -- )
|
|
||||||
next-method-quot (step-into-quot) ;
|
|
||||||
|
|
||||||
<< {
|
<< {
|
||||||
(step-into-quot)
|
(step-into-quot)
|
||||||
|
|
@ -118,74 +69,6 @@ SYMBOL: +running+
|
||||||
SYMBOL: +suspended+
|
SYMBOL: +suspended+
|
||||||
SYMBOL: +stopped+
|
SYMBOL: +stopped+
|
||||||
|
|
||||||
: change-frame ( continuation quot -- continuation' )
|
|
||||||
#! Applies quot to innermost call frame of the
|
|
||||||
#! continuation.
|
|
||||||
[ clone ] dip [
|
|
||||||
[ clone ] dip
|
|
||||||
[
|
|
||||||
[
|
|
||||||
[ 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' ) USE: io
|
|
||||||
[
|
|
||||||
2dup length = [ nip [ break ] append ] [
|
|
||||||
2dup nth \ break = [ nip ] [
|
|
||||||
swap 1+ cut [ break ] glue
|
|
||||||
] if
|
|
||||||
] if
|
|
||||||
] change-frame ;
|
|
||||||
|
|
||||||
: step-out-msg ( continuation -- continuation' )
|
|
||||||
[ nip \ break suffix ] change-frame ;
|
|
||||||
|
|
||||||
{
|
|
||||||
{ call [ (step-into-quot) ] }
|
|
||||||
{ dip [ (step-into-dip) ] }
|
|
||||||
{ 2dip [ (step-into-2dip) ] }
|
|
||||||
{ 3dip [ (step-into-3dip) ] }
|
|
||||||
{ execute [ (step-into-execute) ] }
|
|
||||||
{ if [ (step-into-if) ] }
|
|
||||||
{ dispatch [ (step-into-dispatch) ] }
|
|
||||||
{ continuation [ (step-into-continuation) ] }
|
|
||||||
{ (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
|
|
||||||
stop suspend (spawn)
|
|
||||||
} [
|
|
||||||
dup [ execute break ] curry
|
|
||||||
"step-into" set-word-prop
|
|
||||||
] each
|
|
||||||
|
|
||||||
\ break [ break ] "step-into" set-word-prop
|
|
||||||
|
|
||||||
: step-into-msg ( continuation -- continuation' )
|
|
||||||
[
|
|
||||||
swap cut [
|
|
||||||
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 ;
|
|
||||||
|
|
||||||
: status ( -- symbol )
|
: status ( -- symbol )
|
||||||
walker-status tget value>> ;
|
walker-status tget value>> ;
|
||||||
|
|
||||||
|
|
@ -212,13 +95,13 @@ SYMBOL: +stopped+
|
||||||
{ f [ +stopped+ set-status f ] }
|
{ f [ +stopped+ set-status f ] }
|
||||||
[
|
[
|
||||||
[ walker-continuation tget set-model ]
|
[ walker-continuation tget set-model ]
|
||||||
[ step-into-msg ] bi
|
[ continuation-step-into ] bi
|
||||||
]
|
]
|
||||||
} case
|
} case
|
||||||
] handle-synchronous
|
] handle-synchronous
|
||||||
] while ;
|
] while ;
|
||||||
|
|
||||||
: step-back-msg ( continuation -- continuation' )
|
: continuation-step-back ( continuation -- continuation' )
|
||||||
walker-history tget
|
walker-history tget
|
||||||
[ pop* ]
|
[ pop* ]
|
||||||
[ [ nip pop ] unless-empty ] bi ;
|
[ [ nip pop ] unless-empty ] bi ;
|
||||||
|
|
@ -232,16 +115,16 @@ SYMBOL: +stopped+
|
||||||
{
|
{
|
||||||
! These are sent by the walker tool. We reply
|
! These are sent by the walker tool. We reply
|
||||||
! and keep cycling.
|
! and keep cycling.
|
||||||
{ step [ step-msg keep-running ] }
|
{ step [ continuation-step keep-running ] }
|
||||||
{ step-out [ step-out-msg keep-running ] }
|
{ step-out [ continuation-step-out keep-running ] }
|
||||||
{ step-into [ step-into-msg keep-running ] }
|
{ step-into [ continuation-step-into keep-running ] }
|
||||||
{ step-all [ keep-running ] }
|
{ step-all [ keep-running ] }
|
||||||
{ step-into-all [ step-into-all-loop ] }
|
{ step-into-all [ step-into-all-loop ] }
|
||||||
{ abandon [ drop f keep-running ] }
|
{ abandon [ drop f keep-running ] }
|
||||||
! Pass quotation to debugged thread
|
! Pass quotation to debugged thread
|
||||||
{ call-in [ keep-running ] }
|
{ call-in [ keep-running ] }
|
||||||
! Pass previous continuation to debugged thread
|
! Pass previous continuation to debugged thread
|
||||||
{ step-back [ step-back-msg ] }
|
{ step-back [ continuation-step-back ] }
|
||||||
} case f
|
} case f
|
||||||
] handle-synchronous
|
] handle-synchronous
|
||||||
] while ;
|
] while ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue