Merge branch 'trace_tool' of git://factorcode.org/git/factor into trace_tool

diff --git a/basis/tools/continuations/authors.txt b/basis/tools/continuations/authors.txt
new file mode 100644 (file)
index 0000000..d4f5d6b
--- /dev/null
+++ b/basis/tools/continuations/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file

diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor
new file mode 100644 (file)
index 0000000..70ebff9
--- /dev/null
+++ b/basis/tools/continuations/continuations.factor
@@ -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 ;

diff --git a/basis/tools/trace/authors.txt b/basis/tools/trace/authors.txt
new file mode 100644 (file)
index 0000000..d4f5d6b
--- /dev/null
+++ b/basis/tools/trace/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file

diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor
new file mode 100644 (file)
index 0000000..42d4a00
--- /dev/null
+++ b/basis/tools/trace/trace.factor
@@ -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 ;

diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index e6cdc36fe1314b7f3fdd9c9b293f3d107ee6ecd8..72d7cd81cd0d3f96794a48f23a465ff4e8d69152 100644 (file)
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -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.
 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 ;
+generic generic.standard definitions make sbufs
+tools.continuations ;
 IN: tools.walker
 
 SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -31,66 +32,16 @@ DEFER: start-walker-thread
         2dup start-walker-thread
     ] 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' )
     \ break prefix [ break rethrow ] recover ;
 
-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) ;
+break-hook [
+    [
+        get-walker-thread
+        [ show-walker-hook get call ] keep
+        send-synchronous
+    ]
+] initialize
 
 << {
     (step-into-quot)
@@ -118,74 +69,6 @@ SYMBOL: +running+
 SYMBOL: +suspended+
 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 )
     walker-status tget value>> ;
 
@@ -212,13 +95,13 @@ SYMBOL: +stopped+
                 { f [ +stopped+ set-status f ] }
                 [
                     [ walker-continuation tget set-model ]
-                    [ step-into-msg ] bi
+                    [ continuation-step-into ] bi
                 ]
             } case
         ] handle-synchronous
     ] while ;
 
-: step-back-msg ( continuation -- continuation' )
+: continuation-step-back ( continuation -- continuation' )
     walker-history tget
     [ pop* ]
     [ [ nip pop ] unless-empty ] bi ;
@@ -232,20 +115,20 @@ SYMBOL: +stopped+
             {
                 ! These are sent by the walker tool. We reply
                 ! and keep cycling.
-                { step [ step-msg keep-running ] }
-                { step-out [ step-out-msg keep-running ] }
-                { step-into [ step-into-msg keep-running ] }
+                { step [ continuation-step keep-running ] }
+                { step-out [ continuation-step-out keep-running ] }
+                { step-into [ continuation-step-into keep-running ] }
                 { step-all [ keep-running ] }
                 { step-into-all [ step-into-all-loop ] }
                 { abandon [ drop f keep-running ] }
                 ! Pass quotation to debugged thread
                 { call-in [ keep-running ] }
                 ! Pass previous continuation to debugged thread
-                { step-back [ step-back-msg ] }
+                { step-back [ continuation-step-back ] }
             } case f
         ] handle-synchronous
     ] while ;
-
+ 
 : walker-loop ( -- )
     +running+ set-status
     [ status +stopped+ eq? ] [