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 ! Messages sent to walker thread
  47 SYMBOL: step
  48 SYMBOL: step-out
  49 SYMBOL: step-into
  50 SYMBOL: step-all
  51 SYMBOL: step-into-all
  52 SYMBOL: step-back
  53 SYMBOL: abandon
  54 SYMBOL: call-in
  55
  56 SYMBOL: +running+
  57 SYMBOL: +suspended+
  58 SYMBOL: +stopped+
  59
  60 : status ( -- symbol )
  61     walker-status tget value>> ;
  62
  63 : set-status ( symbol -- )
  64     walker-status tget set-model ;
  65
  66 : keep-running ( -- )
  67     +running+ set-status ;
  68
  69 : walker-stopped ( -- )
  70     +stopped+ set-status ;
  71
  72 : step-into-all-loop ( -- )
  73     +running+ set-status
  74     [ status +running+ eq? ] [
  75         [
  76             {
  77                 { step [ f ] }
  78                 { step-out [ f ] }
  79                 { step-into [ f ] }
  80                 { step-all [ f ] }
  81                 { step-into-all [ f ] }
  82                 { step-back [ f ] }
  83                 { f [ +stopped+ set-status f ] }
  84                 [
  85                     [ walker-continuation tget set-model ]
  86                     [ continuation-step-into ] bi
  87                 ]
  88             } case
  89         ] handle-synchronous
  90     ] while ;
  91
  92 : continuation-step-back ( continuation -- continuation' )
  93     walker-history tget
  94     [ pop* ]
  95     [ [ nip pop ] unless-empty ] bi ;
  96
  97 : walker-suspended ( continuation -- continuation' )
  98     +suspended+ set-status
  99     [ status +suspended+ eq? ] [
 100         dup walker-history tget push
 101         dup walker-continuation tget set-model
 102         [
 103             {
 104                 ! These are sent by the walker tool. We reply
 105                 ! and keep cycling.
 106                 { step [ continuation-step keep-running ] }
 107                 { step-out [ continuation-step-out keep-running ] }
 108                 { step-into [ continuation-step-into keep-running ] }
 109                 { step-all [ keep-running ] }
 110                 { step-into-all [ step-into-all-loop ] }
 111                 { abandon [ drop f keep-running ] }
 112                 ! Pass quotation to debugged thread
 113                 { call-in [ keep-running ] }
 114                 ! Pass previous continuation to debugged thread
 115                 { step-back [ continuation-step-back ] }
 116             } case f
 117         ] handle-synchronous
 118     ] while ;
 119
 120 : walker-loop ( -- )
 121     +running+ set-status
 122     [ status +stopped+ eq? ] [
 123         [
 124             {
 125                 ! ignore these commands while the thread is
 126                 ! running
 127                 { step [ f ] }
 128                 { step-out [ f ] }
 129                 { step-into [ f ] }
 130                 { step-all [ f ] }
 131                 { step-into-all [ step-into-all-loop f ] }
 132                 { step-back [ f ] }
 133                 { abandon [ f ] }
 134                 { f [ walker-stopped f ] }
 135                 ! thread hit a breakpoint and sent us the
 136                 ! continuation, so we modify it and send it
 137                 ! back.
 138                 [ walker-suspended ]
 139             } case
 140         ] handle-synchronous
 141     ] until ;
 142
 143 : associate-thread ( walker -- )
 144     walker-thread tset
 145     [ f walker-thread tget send-synchronous drop ]
 146     self (>>exit-handler) ;
 147
 148 : start-walker-thread ( status continuation -- thread' )
 149     self [
 150         walking-thread tset
 151         walker-continuation tset
 152         walker-status tset
 153         V{ } clone walker-history tset
 154         walker-loop
 155     ] 3curry
 156     "Walker on " self name>> append spawn
 157     [ associate-thread ] keep ;
 158
 159 ! For convenience
 160 IN: syntax
 161
 162 : B ( -- ) break ;