basis/tools/walker/walker.factor

   1 ! Copyright (C) 2004, 2009 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 tools.continuations ;
   9 IN: tools.walker
  10
  11 SYMBOL: show-walker-hook ! ( status continuation thread -- )
  12
  13 ! Thread local in thread being walked
  14 SYMBOL: walker-thread
  15
  16 ! Thread local in walker thread
  17 SYMBOL: walking-thread
  18 SYMBOL: walker-status
  19 SYMBOL: walker-continuation
  20 SYMBOL: walker-history
  21
  22 DEFER: start-walker-thread
  23
  24 : get-walker-thread ( -- status continuation thread )
  25     walker-thread tget [
  26         [ variables>> walker-status swap at ]
  27         [ variables>> walker-continuation swap at ]
  28         [ ] tri
  29     ] [
  30         f <model>
  31         f <model>
  32         2dup start-walker-thread
  33     ] if* ;
  34
  35 : walk ( quot -- quot' )
  36     \ break prefix [ break rethrow ] recover ;
  37
  38 break-hook [
  39     [
  40         get-walker-thread
  41         [ show-walker-hook get call ] keep
  42         send-synchronous
  43     ]
  44 ] initialize
  45
  46 << {
  47     (step-into-quot)
  48     (step-into-dip)
  49     (step-into-2dip)
  50     (step-into-3dip)
  51     (step-into-if)
  52     (step-into-dispatch)
  53     (step-into-execute)
  54     (step-into-continuation)
  55     (step-into-call-next-method)
  56 } [ t "no-compile" set-word-prop ] each >>
  57
  58 ! Messages sent to walker thread
  59 SYMBOL: step
  60 SYMBOL: step-out
  61 SYMBOL: step-into
  62 SYMBOL: step-all
  63 SYMBOL: step-into-all
  64 SYMBOL: step-back
  65 SYMBOL: abandon
  66 SYMBOL: call-in
  67
  68 SYMBOL: +running+
  69 SYMBOL: +suspended+
  70 SYMBOL: +stopped+
  71
  72 : status ( -- symbol )
  73     walker-status tget value>> ;
  74
  75 : set-status ( symbol -- )
  76     walker-status tget set-model ;
  77
  78 : keep-running ( -- )
  79     +running+ set-status ;
  80
  81 : walker-stopped ( -- )
  82     +stopped+ set-status ;
  83
  84 : step-into-all-loop ( -- )
  85     +running+ set-status
  86     [ status +running+ eq? ] [
  87         [
  88             {
  89                 { step [ f ] }
  90                 { step-out [ f ] }
  91                 { step-into [ f ] }
  92                 { step-all [ f ] }
  93                 { step-into-all [ f ] }
  94                 { step-back [ f ] }
  95                 { f [ +stopped+ set-status f ] }
  96                 [
  97                     [ walker-continuation tget set-model ]
  98                     [ continuation-step-into ] bi
  99                 ]
 100             } case
 101         ] handle-synchronous
 102     ] while ;
 103
 104 : continuation-step-back ( continuation -- continuation' )
 105     walker-history tget
 106     [ pop* ]
 107     [ [ nip pop ] unless-empty ] bi ;
 108
 109 : walker-suspended ( continuation -- continuation' )
 110     +suspended+ set-status
 111     [ status +suspended+ eq? ] [
 112         dup walker-history tget push
 113         dup walker-continuation tget set-model
 114         [
 115             {
 116                 ! These are sent by the walker tool. We reply
 117                 ! and keep cycling.
 118                 { step [ continuation-step keep-running ] }
 119                 { step-out [ continuation-step-out keep-running ] }
 120                 { step-into [ continuation-step-into keep-running ] }
 121                 { step-all [ keep-running ] }
 122                 { step-into-all [ step-into-all-loop ] }
 123                 { abandon [ drop f keep-running ] }
 124                 ! Pass quotation to debugged thread
 125                 { call-in [ keep-running ] }
 126                 ! Pass previous continuation to debugged thread
 127                 { step-back [ continuation-step-back ] }
 128             } case f
 129         ] handle-synchronous
 130     ] while ;
 131
 132 : walker-loop ( -- )
 133     +running+ set-status
 134     [ status +stopped+ eq? ] [
 135         [
 136             {
 137                 ! ignore these commands while the thread is
 138                 ! running
 139                 { step [ f ] }
 140                 { step-out [ f ] }
 141                 { step-into [ f ] }
 142                 { step-all [ f ] }
 143                 { step-into-all [ step-into-all-loop f ] }
 144                 { step-back [ f ] }
 145                 { abandon [ f ] }
 146                 { f [ walker-stopped f ] }
 147                 ! thread hit a breakpoint and sent us the
 148                 ! continuation, so we modify it and send it
 149                 ! back.
 150                 [ walker-suspended ]
 151             } case
 152         ] handle-synchronous
 153     ] until ;
 154
 155 : associate-thread ( walker -- )
 156     walker-thread tset
 157     [ f walker-thread tget send-synchronous drop ]
 158     self (>>exit-handler) ;
 159
 160 : start-walker-thread ( status continuation -- thread' )
 161     self [
 162         walking-thread tset
 163         walker-continuation tset
 164         walker-status tset
 165         V{ } clone walker-history tset
 166         walker-loop
 167     ] 3curry
 168     "Walker on " self name>> append spawn
 169     [ associate-thread ] keep ;
 170
 171 ! For convenience
 172 IN: syntax
 173
 174 : B ( -- ) break ;