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 parser tools.annotations fry ;
   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 of ]
  27         [ variables>> walker-continuation of ]
  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 << \ walk t "no-compile" set-word-prop >>
  39
  40 break-hook [
  41     [
  42         get-walker-thread
  43         [ show-walker-hook get call ] keep
  44         send-synchronous
  45     ]
  46 ] initialize
  47
  48 ! Messages sent to walker thread
  49 SYMBOL: step
  50 SYMBOL: step-out
  51 SYMBOL: step-into
  52 SYMBOL: step-all
  53 SYMBOL: step-into-all
  54 SYMBOL: step-back
  55 SYMBOL: abandon
  56 SYMBOL: call-in
  57
  58 SYMBOL: +running+
  59 SYMBOL: +suspended+
  60 SYMBOL: +stopped+
  61
  62 : status ( -- symbol )
  63     walker-status tget value>> ;
  64
  65 : set-status ( symbol -- )
  66     walker-status tget set-model ;
  67
  68 : keep-running ( -- )
  69     +running+ set-status ;
  70
  71 : walker-stopped ( -- )
  72     +stopped+ set-status ;
  73
  74 : step-into-all-loop ( -- )
  75     +running+ set-status
  76     [ status +running+ eq? ] [
  77         [
  78             {
  79                 { step [ f ] }
  80                 { step-out [ f ] }
  81                 { step-into [ f ] }
  82                 { step-all [ f ] }
  83                 { step-into-all [ f ] }
  84                 { step-back [ f ] }
  85                 { f [ +stopped+ set-status f ] }
  86                 [
  87                     [ walker-continuation tget set-model ]
  88                     [ continuation-step-into ] bi
  89                 ]
  90             } case
  91         ] handle-synchronous
  92     ] while ;
  93
  94 : continuation-step-back ( continuation -- continuation' )
  95     walker-history tget
  96     [ pop* ]
  97     [ [ nip pop ] unless-empty ] bi ;
  98
  99 : walker-suspended ( continuation -- continuation' )
 100     +suspended+ set-status
 101     [ status +suspended+ eq? ] [
 102         dup walker-history tget push
 103         dup walker-continuation tget set-model
 104         [
 105             {
 106                 ! These are sent by the walker tool. We reply
 107                 ! and keep cycling.
 108                 { step [ continuation-step keep-running ] }
 109                 { step-out [ continuation-step-out keep-running ] }
 110                 { step-into [ continuation-step-into keep-running ] }
 111                 { step-all [ keep-running ] }
 112                 { step-into-all [ step-into-all-loop ] }
 113                 { abandon [ drop f keep-running ] }
 114                 ! Pass quotation to debugged thread
 115                 { call-in [ keep-running ] }
 116                 ! Pass previous continuation to debugged thread
 117                 { step-back [ continuation-step-back ] }
 118             } case f
 119         ] handle-synchronous
 120     ] while ;
 121
 122 : walker-loop ( -- )
 123     +running+ set-status
 124     [ status +stopped+ eq? ] [
 125         [
 126             {
 127                 ! ignore these commands while the thread is
 128                 ! running
 129                 { step [ f ] }
 130                 { step-out [ f ] }
 131                 { step-into [ f ] }
 132                 { step-all [ f ] }
 133                 { step-into-all [ step-into-all-loop f ] }
 134                 { step-back [ f ] }
 135                 { abandon [ f ] }
 136                 { f [ walker-stopped f ] }
 137                 ! thread hit a breakpoint and sent us the
 138                 ! continuation, so we modify it and send it
 139                 ! back.
 140                 [ walker-suspended ]
 141             } case
 142         ] handle-synchronous
 143     ] until ;
 144
 145 : associate-thread ( walker -- )
 146     walker-thread tset
 147     [ f walker-thread tget send-synchronous drop ]
 148     self exit-handler<< ;
 149
 150 : start-walker-thread ( status continuation -- thread' )
 151     self [
 152         walking-thread tset
 153         walker-continuation tset
 154         walker-status tset
 155         V{ } clone walker-history tset
 156         walker-loop
 157     ] 3curry
 158     "Walker on " self name>> append spawn
 159     [ associate-thread ] keep ;
 160
 161 : breakpoint ( word -- )
 162     [ add-breakpoint ] annotate ;
 163
 164 : breakpoint-if ( word quot -- )
 165     '[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
 166
 167 ! For convenience
 168 IN: syntax
 169
 170 SYNTAX: B \ break suffix! ;
 171
 172 SYNTAX: B: scan-word definition
 173     [ break "now press O I to land inside the parsing word" drop ]
 174     prepose call( accum -- accum ) ;