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.filter arrays accessors
7 generic generic.standard definitions make sbufs ;
10 SYMBOL: show-walker-hook ! ( status continuation thread -- )
12 ! Thread local in thread being walked
15 ! Thread local in walker thread
16 SYMBOL: walking-thread
18 SYMBOL: walker-continuation
19 SYMBOL: walker-history
21 DEFER: start-walker-thread
23 : get-walker-thread ( -- status continuation thread )
25 [ variables>> walker-status swap at ]
26 [ variables>> walker-continuation swap at ]
31 2dup start-walker-thread
34 : show-walker ( -- thread )
36 [ show-walker-hook get call ] keep ;
38 : after-break ( object -- )
40 { [ dup continuation? ] [ (continue) ] }
41 { [ dup quotation? ] [ call ] }
42 { [ dup not ] [ "Single stepping abandoned" rethrow ] }
46 continuation callstack >>call
47 show-walker send-synchronous
50 \ break t "break?" set-word-prop
52 : walk ( quot -- quot' )
53 \ break prefix [ break rethrow ] recover ;
55 GENERIC: add-breakpoint ( quot -- quot' )
57 M: callable add-breakpoint
58 dup [ break ] head? [ \ break prefix ] unless ;
60 M: array add-breakpoint
61 [ add-breakpoint ] map ;
63 M: object add-breakpoint ;
65 : (step-into-quot) ( quot -- ) add-breakpoint call ;
67 : (step-into-dip) ( quot -- ) add-breakpoint dip ;
69 : (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
71 : (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
73 : (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
75 : (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
77 : (step-into-execute) ( word -- )
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) ]
87 \ (step-into-execute) t "step-into?" set-word-prop
89 : (step-into-continuation) ( -- )
90 continuation callstack >>call break ;
92 : (step-into-call-next-method) ( method -- )
93 next-method-quot (step-into-quot) ;
95 ! Messages sent to walker thread
100 SYMBOL: step-into-all
109 : change-frame ( continuation quot -- continuation' )
110 #! Applies quot to innermost call frame of the
116 [ innermost-frame-scan 1+ ]
117 [ innermost-frame-quot ] bi
120 [ drop set-innermost-frame-quot ]
123 ] curry change-call ; inline
125 : step-msg ( continuation -- continuation' ) USE: io
127 2dup length = [ nip [ break ] append ] [
128 2dup nth \ break = [ nip ] [
129 swap 1+ cut [ break ] glue
134 : step-out-msg ( continuation -- continuation' )
135 [ nip \ break suffix ] change-frame ;
138 { call [ (step-into-quot) ] }
139 { dip [ (step-into-dip) ] }
140 { 2dip [ (step-into-2dip) ] }
141 { 3dip [ (step-into-3dip) ] }
142 { (throw) [ drop (step-into-quot) ] }
143 { execute [ (step-into-execute) ] }
144 { if [ (step-into-if) ] }
145 { dispatch [ (step-into-dispatch) ] }
146 { continuation [ (step-into-continuation) ] }
147 { (call-next-method) [ (step-into-call-next-method) ] }
148 } [ "step-into" set-word-prop ] assoc-each
150 ! Never step into these words
153 continue continue-with
155 ! Don't step into some sequence words since output of
156 ! (string) and new-sequence-unsafe may not print due to
157 ! memory safety issues
158 <sbuf> prepare-subseq subseq new-sequence-unsafe
160 dup [ execute break ] curry
161 "step-into" set-word-prop
164 \ break [ break ] "step-into" set-word-prop
166 : step-into-msg ( continuation -- continuation' )
172 { [ dup \ break eq? ] [ , ] }
173 { [ dup quotation? ] [ add-breakpoint , \ break , ] }
174 { [ dup array? ] [ add-breakpoint , \ break , ] }
175 { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
182 : status ( -- symbol )
183 walker-status tget value>> ;
185 : set-status ( symbol -- )
186 walker-status tget set-model ;
188 : keep-running ( -- )
189 +running+ set-status ;
191 : walker-stopped ( -- )
192 +stopped+ set-status ;
194 : step-into-all-loop ( -- )
196 [ status +running+ eq? ] [
203 { step-into-all [ f ] }
205 { f [ +stopped+ set-status f ] }
207 [ walker-continuation tget set-model ]
214 : step-back-msg ( continuation -- continuation' )
217 [ [ nip pop ] unless-empty ] bi ;
219 : walker-suspended ( continuation -- continuation' )
220 +suspended+ set-status
221 [ status +suspended+ eq? ] [
222 dup walker-history tget push
223 dup walker-continuation tget set-model
226 ! These are sent by the walker tool. We reply
228 { step [ step-msg keep-running ] }
229 { step-out [ step-out-msg keep-running ] }
230 { step-into [ step-into-msg keep-running ] }
231 { step-all [ keep-running ] }
232 { step-into-all [ step-into-all-loop ] }
233 { abandon [ drop f keep-running ] }
234 ! Pass quotation to debugged thread
235 { call-in [ nip keep-running ] }
236 ! Pass previous continuation to debugged thread
237 { step-back [ step-back-msg ] }
244 [ status +stopped+ eq? ] [
247 ! ignore these commands while the thread is
253 { step-into-all [ step-into-all-loop f ] }
256 { f [ walker-stopped f ] }
257 ! thread hit a breakpoint and sent us the
258 ! continuation, so we modify it and send it
265 : associate-thread ( walker -- )
267 [ f walker-thread tget send-synchronous drop ]
268 self (>>exit-handler) ;
270 : start-walker-thread ( status continuation -- thread' )
273 walker-continuation tset
275 V{ } clone walker-history tset
278 "Walker on " self name>> append spawn
279 [ associate-thread ] keep ;