extra/tools/walker/walker.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: threads kernel namespaces continuations combinators
   4 sequences math namespaces.private continuations.private
   5 concurrency.messaging quotations kernel.private words
   6 sequences.private assocs models arrays accessors
   7 generic generic.standard definitions ;
   8 IN: tools.walker
   9
  10 SYMBOL: show-walker-hook ! ( status continuation thread -- )
  11
  12 ! Thread local in thread being walked
  13 SYMBOL: walker-thread
  14
  15 ! Thread local in walker thread
  16 SYMBOL: walking-thread
  17 SYMBOL: walker-status
  18 SYMBOL: walker-continuation
  19 SYMBOL: walker-history
  20
  21 DEFER: start-walker-thread
  22
  23 : get-walker-thread ( -- status continuation thread )
  24     walker-thread tget [
  25         [ thread-variables walker-status swap at ]
  26         [ thread-variables walker-continuation swap at ]
  27         [ ] tri
  28     ] [
  29         f <model>
  30         f <model>
  31         2dup start-walker-thread
  32     ] if* ;
  33
  34 : show-walker ( -- thread )
  35     get-walker-thread
  36     [ show-walker-hook get call ] keep ;
  37
  38 : after-break ( object -- )
  39     {
  40         { [ dup continuation? ] [ (continue) ] }
  41         { [ dup quotation? ] [ call ] }
  42         { [ dup not ] [ "Single stepping abandoned" rethrow ] }
  43     } cond ;
  44
  45 : break ( -- )
  46     continuation callstack over set-continuation-call
  47     show-walker send-synchronous
  48     after-break ;
  49
  50 \ break t "break?" set-word-prop
  51
  52 : walk ( quot -- quot' )
  53     \ break prefix [ break rethrow ] recover ;
  54
  55 GENERIC: add-breakpoint ( quot -- quot' )
  56
  57 M: callable add-breakpoint
  58     dup [ break ] head? [ \ break prefix ] unless ;
  59
  60 M: array add-breakpoint
  61     [ add-breakpoint ] map ;
  62
  63 M: object add-breakpoint ;
  64
  65 : (step-into-quot) ( quot -- ) add-breakpoint call ;
  66
  67 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
  68
  69 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
  70
  71 : (step-into-execute) ( word -- )
  72     {
  73         { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
  74         { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
  75         { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
  76         { [ dup uses \ suspend swap member? ] [ execute break ] }
  77         { [ dup primitive? ] [ execute break ] }
  78         [ word-def (step-into-quot) ]
  79     } cond ;
  80
  81 \ (step-into-execute) t "step-into?" set-word-prop
  82
  83 : (step-into-continuation) ( -- )
  84     continuation callstack >>call break ;
  85
  86 ! Messages sent to walker thread
  87 SYMBOL: step
  88 SYMBOL: step-out
  89 SYMBOL: step-into
  90 SYMBOL: step-all
  91 SYMBOL: step-into-all
  92 SYMBOL: step-back
  93 SYMBOL: abandon
  94 SYMBOL: call-in
  95
  96 SYMBOL: +running+
  97 SYMBOL: +suspended+
  98 SYMBOL: +stopped+
  99
 100 : change-frame ( continuation quot -- continuation' )
 101     #! Applies quot to innermost call frame of the
 102     #! continuation.
 103     >r clone r> [
 104         >r clone r>
 105         [
 106             >r
 107             [ innermost-frame-scan 1+ ]
 108             [ innermost-frame-quot ] bi
 109             r> call
 110         ]
 111         [ drop set-innermost-frame-quot ]
 112         [ drop ]
 113         2tri
 114     ] curry change-call ; inline
 115
 116 : step-msg ( continuation -- continuation' )
 117     [
 118         2dup nth \ break = [
 119             nip
 120         ] [
 121             swap 1+ cut [ break ] swap 3append
 122         ] if
 123     ] change-frame ;
 124
 125 : step-out-msg ( continuation -- continuation' )
 126     [ nip \ break suffix ] change-frame ;
 127
 128 {
 129     { call [ (step-into-quot) ] }
 130     { (throw) [ drop (step-into-quot) ] }
 131     { execute [ (step-into-execute) ] }
 132     { if [ (step-into-if) ] }
 133     { dispatch [ (step-into-dispatch) ] }
 134     { continuation [ (step-into-continuation) ] }
 135 } [ "step-into" set-word-prop ] assoc-each
 136
 137 {
 138     >n ndrop >c c>
 139     continue continue-with
 140     stop suspend (spawn)
 141 } [
 142     dup [ execute break ] curry
 143     "step-into" set-word-prop
 144 ] each
 145
 146 \ break [ break ] "step-into" set-word-prop
 147
 148 : step-into-msg ( continuation -- continuation' )
 149     [
 150         swap cut [
 151             swap % unclip {
 152                 { [ dup \ break eq? ] [ , ] }
 153                 { [ dup quotation? ] [ add-breakpoint , \ break , ] }
 154                 { [ dup array? ] [ add-breakpoint , \ break , ] }
 155                 { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
 156                 [ , \ break , ]
 157             } cond %
 158         ] [ ] make
 159     ] change-frame ;
 160
 161 : status ( -- symbol )
 162     walker-status tget model-value ;
 163
 164 : set-status ( symbol -- )
 165     walker-status tget set-model ;
 166
 167 : keep-running ( -- )
 168     +running+ set-status ;
 169
 170 : walker-stopped ( -- )
 171     +stopped+ set-status ;
 172
 173 : step-into-all-loop ( -- )
 174     +running+ set-status
 175     [ status +running+ eq? ] [
 176         [
 177             {
 178                 { step [ f ] }
 179                 { step-out [ f ] }
 180                 { step-into [ f ] }
 181                 { step-all [ f ] }
 182                 { step-into-all [ f ] }
 183                 { step-back [ f ] }
 184                 { f [ +stopped+ set-status f ] }
 185                 [
 186                     [ walker-continuation tget set-model ]
 187                     [ step-into-msg ] bi
 188                 ]
 189             } case
 190         ] handle-synchronous
 191     ] [ ] while ;
 192
 193 : step-back-msg ( continuation -- continuation' )
 194     walker-history tget
 195     [ pop* ]
 196     [ dup empty? [ drop ] [ nip pop ] if ] bi ;
 197
 198 : walker-suspended ( continuation -- continuation' )
 199     +suspended+ set-status
 200     [ status +suspended+ eq? ] [
 201         dup walker-history tget push
 202         dup walker-continuation tget set-model
 203         [
 204             {
 205                 ! These are sent by the walker tool. We reply
 206                 ! and keep cycling.
 207                 { step [ step-msg keep-running ] }
 208                 { step-out [ step-out-msg keep-running ] }
 209                 { step-into [ step-into-msg keep-running ] }
 210                 { step-all [ keep-running ] }
 211                 { step-into-all [ step-into-all-loop ] }
 212                 { abandon [ drop f keep-running ] }
 213                 ! Pass quotation to debugged thread
 214                 { call-in [ nip keep-running ] }
 215                 ! Pass previous continuation to debugged thread
 216                 { step-back [ step-back-msg ] }
 217             } case f
 218         ] handle-synchronous
 219     ] [ ] while ;
 220
 221 : walker-loop ( -- )
 222     +running+ set-status
 223     [ status +stopped+ eq? not ] [
 224         [
 225             {
 226                 ! ignore these commands while the thread is
 227                 ! running
 228                 { step [ f ] }
 229                 { step-out [ f ] }
 230                 { step-into [ f ] }
 231                 { step-all [ f ] }
 232                 { step-into-all [ step-into-all-loop f ] }
 233                 { step-back [ f ] }
 234                 { abandon [ f ] }
 235                 { f [ walker-stopped f ] }
 236                 ! thread hit a breakpoint and sent us the
 237                 ! continuation, so we modify it and send it
 238                 ! back.
 239                 [ walker-suspended ]
 240             } case
 241         ] handle-synchronous
 242     ] [ ] while ;
 243
 244 : associate-thread ( walker -- )
 245     walker-thread tset
 246     [ f walker-thread tget send-synchronous drop ]
 247     self set-thread-exit-handler ;
 248
 249 : start-walker-thread ( status continuation -- thread' )
 250     self [
 251         walking-thread tset
 252         walker-continuation tset
 253         walker-status tset
 254         V{ } clone walker-history tset
 255         walker-loop
 256     ] 3curry
 257     "Walker on " self thread-name append spawn
 258     [ associate-thread ] keep ;
 259
 260 ! For convenience
 261 IN: syntax
 262
 263 : B ( -- ) break ;