basis/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 models.arrow arrays accessors
   7 generic generic.standard definitions make sbufs ;
   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         [ variables>> walker-status swap at ]
  26         [ 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 >>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-dip) ( quot -- ) add-breakpoint dip ;
  68
  69 : (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
  70
  71 : (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
  72
  73 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
  74
  75 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
  76
  77 : (step-into-execute) ( word -- )
  78     {
  79         { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
  80         { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
  81         { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
  82         { [ dup uses \ suspend swap member? ] [ execute break ] }
  83         { [ dup primitive? ] [ execute break ] }
  84         [ def>> (step-into-quot) ]
  85     } cond ;
  86
  87 \ (step-into-execute) t "step-into?" set-word-prop
  88
  89 : (step-into-continuation) ( -- )
  90     continuation callstack >>call break ;
  91
  92 : (step-into-call-next-method) ( method -- )
  93     next-method-quot (step-into-quot) ;
  94
  95 << {
  96     (step-into-quot)
  97     (step-into-dip)
  98     (step-into-2dip)
  99     (step-into-3dip)
 100     (step-into-if)
 101     (step-into-dispatch)
 102     (step-into-execute)
 103     (step-into-continuation)
 104     (step-into-call-next-method)
 105 } [ t "no-compile" set-word-prop ] each >>
 106
 107 ! Messages sent to walker thread
 108 SYMBOL: step
 109 SYMBOL: step-out
 110 SYMBOL: step-into
 111 SYMBOL: step-all
 112 SYMBOL: step-into-all
 113 SYMBOL: step-back
 114 SYMBOL: abandon
 115 SYMBOL: call-in
 116
 117 SYMBOL: +running+
 118 SYMBOL: +suspended+
 119 SYMBOL: +stopped+
 120
 121 : change-frame ( continuation quot -- continuation' )
 122     #! Applies quot to innermost call frame of the
 123     #! continuation.
 124     [ clone ] dip [
 125         [ clone ] dip
 126         [
 127             [
 128                 [ innermost-frame-scan 1+ ]
 129                 [ innermost-frame-quot ] bi
 130             ] dip call
 131         ]
 132         [ drop set-innermost-frame-quot ]
 133         [ drop ]
 134         2tri
 135     ] curry change-call ; inline
 136
 137 : step-msg ( continuation -- continuation' ) USE: io
 138     [
 139         2dup length = [ nip [ break ] append ] [
 140             2dup nth \ break = [ nip ] [
 141                 swap 1+ cut [ break ] glue
 142             ] if
 143         ] if
 144     ] change-frame ;
 145
 146 : step-out-msg ( continuation -- continuation' )
 147     [ nip \ break suffix ] change-frame ;
 148
 149 {
 150     { call [ (step-into-quot) ] }
 151     { dip [ (step-into-dip) ] }
 152     { 2dip [ (step-into-2dip) ] }
 153     { 3dip [ (step-into-3dip) ] }
 154     { execute [ (step-into-execute) ] }
 155     { if [ (step-into-if) ] }
 156     { dispatch [ (step-into-dispatch) ] }
 157     { continuation [ (step-into-continuation) ] }
 158     { (call-next-method) [ (step-into-call-next-method) ] }
 159 } [ "step-into" set-word-prop ] assoc-each
 160
 161 ! Never step into these words
 162 {
 163     >n ndrop >c c>
 164     continue continue-with
 165     stop suspend (spawn)
 166 } [
 167     dup [ execute break ] curry
 168     "step-into" set-word-prop
 169 ] each
 170
 171 \ break [ break ] "step-into" set-word-prop
 172
 173 : step-into-msg ( continuation -- continuation' )
 174     [
 175         swap cut [
 176             swap %
 177             [ \ break , ] [
 178                 unclip {
 179                     { [ dup \ break eq? ] [ , ] }
 180                     { [ dup quotation? ] [ add-breakpoint , \ break , ] }
 181                     { [ dup array? ] [ add-breakpoint , \ break , ] }
 182                     { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
 183                     [ , \ break , ]
 184                 } cond %
 185             ] if-empty
 186         ] [ ] make
 187     ] change-frame ;
 188
 189 : status ( -- symbol )
 190     walker-status tget value>> ;
 191
 192 : set-status ( symbol -- )
 193     walker-status tget set-model ;
 194
 195 : keep-running ( -- )
 196     +running+ set-status ;
 197
 198 : walker-stopped ( -- )
 199     +stopped+ set-status ;
 200
 201 : step-into-all-loop ( -- )
 202     +running+ set-status
 203     [ status +running+ eq? ] [
 204         [
 205             {
 206                 { step [ f ] }
 207                 { step-out [ f ] }
 208                 { step-into [ f ] }
 209                 { step-all [ f ] }
 210                 { step-into-all [ f ] }
 211                 { step-back [ f ] }
 212                 { f [ +stopped+ set-status f ] }
 213                 [
 214                     [ walker-continuation tget set-model ]
 215                     [ step-into-msg ] bi
 216                 ]
 217             } case
 218         ] handle-synchronous
 219     ] while ;
 220
 221 : step-back-msg ( continuation -- continuation' )
 222     walker-history tget
 223     [ pop* ]
 224     [ [ nip pop ] unless-empty ] bi ;
 225
 226 : walker-suspended ( continuation -- continuation' )
 227     +suspended+ set-status
 228     [ status +suspended+ eq? ] [
 229         dup walker-history tget push
 230         dup walker-continuation tget set-model
 231         [
 232             {
 233                 ! These are sent by the walker tool. We reply
 234                 ! and keep cycling.
 235                 { step [ step-msg keep-running ] }
 236                 { step-out [ step-out-msg keep-running ] }
 237                 { step-into [ step-into-msg keep-running ] }
 238                 { step-all [ keep-running ] }
 239                 { step-into-all [ step-into-all-loop ] }
 240                 { abandon [ drop f keep-running ] }
 241                 ! Pass quotation to debugged thread
 242                 { call-in [ keep-running ] }
 243                 ! Pass previous continuation to debugged thread
 244                 { step-back [ step-back-msg ] }
 245             } case f
 246         ] handle-synchronous
 247     ] while ;
 248
 249 : walker-loop ( -- )
 250     +running+ set-status
 251     [ status +stopped+ eq? ] [
 252         [
 253             {
 254                 ! ignore these commands while the thread is
 255                 ! running
 256                 { step [ f ] }
 257                 { step-out [ f ] }
 258                 { step-into [ f ] }
 259                 { step-all [ f ] }
 260                 { step-into-all [ step-into-all-loop f ] }
 261                 { step-back [ f ] }
 262                 { abandon [ f ] }
 263                 { f [ walker-stopped f ] }
 264                 ! thread hit a breakpoint and sent us the
 265                 ! continuation, so we modify it and send it
 266                 ! back.
 267                 [ walker-suspended ]
 268             } case
 269         ] handle-synchronous
 270     ] until ;
 271
 272 : associate-thread ( walker -- )
 273     walker-thread tset
 274     [ f walker-thread tget send-synchronous drop ]
 275     self (>>exit-handler) ;
 276
 277 : start-walker-thread ( status continuation -- thread' )
 278     self [
 279         walking-thread tset
 280         walker-continuation tset
 281         walker-status tset
 282         V{ } clone walker-history tset
 283         walker-loop
 284     ] 3curry
 285     "Walker on " self name>> append spawn
 286     [ associate-thread ] keep ;
 287
 288 ! For convenience
 289 IN: syntax
 290
 291 : B ( -- ) break ;