1 \ @(#) trace.fth 98/01/08 1.1
2 \ TRACE ( <name> -- , trace pForth word )
4 \ Single step debugger.
5 \ TRACE ( i*x <name> -- , setup trace for Forth word )
7 \ SM ( many -- , step over many times )
8 \ SD ( -- , step down )
9 \ G ( -- , go to end of word )
10 \ GD ( n -- , go down N levels from current level, stop at end of this level )
12 \ This debugger works by emulating the inner interpreter of pForth.
13 \ It executes code and maintains a separate return stack for the
14 \ program under test. Thus all primitives that operate on the return
15 \ stack, such as DO and R> must be trapped. Local variables must
16 \ also be handled specially. Several state variables are also
17 \ saved and restored to establish the context for the program being
20 \ Copyright 1997 Phil Burk
24 : SPACE.TO.COLUMN ( col -- )
28 : IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )
32 0 value TRACE_IP \ instruction pointer
33 0 value TRACE_LEVEL \ level of descent for inner interpreter
34 0 value TRACE_LEVEL_MAX \ maximum level of descent
38 \ use fake return stack
39 128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes
40 create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot
42 : TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n
43 : TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++
44 : TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp
45 : TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]
46 : TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;
47 : TRACE.RDROP ( -- ) cell trace-rsp +! ;
48 : TRACE.RCHECK ( -- , abort if return stack out of range )
49 trace-rsp @ trace-return-stack u<
50 abort" TRACE return stack OVERFLOW!"
51 trace-rsp @ trace-return-stack trace_return_size + 12 + u>
52 abort" TRACE return stack UNDERFLOW!"
55 \ save and restore several state variables
56 10 cells constant TRACE_STATE_SIZE
57 create TRACE-STATE-1 TRACE_STATE_SIZE allot
58 create TRACE-STATE-2 TRACE_STATE_SIZE allot
60 variable TRACE-STATE-PTR
61 : TRACE.SAVE++ ( addr -- , save next thing )
63 cell trace-state-ptr +!
66 : TRACE.SAVE.STATE ( -- )
72 : TRACE.SAVE.STATE1 ( -- , save normal state )
73 trace-state-1 trace-state-ptr !
76 : TRACE.SAVE.STATE2 ( -- , save state of word being debugged )
77 trace-state-2 trace-state-ptr !
82 : TRACE.RESTORE++ ( addr -- , restore next thing )
83 trace-state-ptr @ @ swap !
84 cell trace-state-ptr +!
87 : TRACE.RESTORE.STATE ( -- )
93 : TRACE.RESTORE.STATE1 ( -- )
94 trace-state-1 trace-state-ptr !
97 : TRACE.RESTORE.STATE2 ( -- )
98 trace-state-2 trace-state-ptr !
102 \ The implementation of these pForth primitives is specific to pForth.
104 variable TRACE-LOCALS-PTR \ point to top of local frame
106 \ create a return stack frame for NUM local variables
107 : TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- }
108 trace-locals-ptr @ trace.>r
109 trace-rsp @ trace-locals-ptr !
110 trace-rsp @ num cells - trace-rsp ! \ make room for locals
115 cell +-> lp \ move data into locals frame on return stack
119 : TRACE.(LOCAL.EXIT) ( -- )
120 trace-locals-ptr @ trace-rsp !
121 trace.r> trace-locals-ptr !
123 : TRACE.(LOCAL@) ( l# -- n , fetch from local frame )
124 trace-locals-ptr @ swap cells - @
126 : TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;
127 : TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;
128 : TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;
129 : TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;
130 : TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;
131 : TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;
132 : TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;
133 : TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;
135 : TRACE.(LOCAL!) ( n l# -- , store into local frame )
136 trace-locals-ptr @ swap cells - !
138 : TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;
139 : TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;
140 : TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;
141 : TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;
142 : TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;
143 : TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;
144 : TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;
145 : TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;
147 : TRACE.(LOCAL+!) ( n l# -- , store into local frame )
148 trace-locals-ptr @ swap cells - +!
150 : TRACE.(?DO) { limit start ip -- ip' }
162 : TRACE.(LOOP) { ip | limit indx -- ip' }
176 : TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' }
179 oldindx delta + -> indx
180 \ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */
181 \ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||
182 \ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )
183 oldindx limit - limit 1- indx - AND $ 80000000 AND
184 indx limit - limit 1- oldindx - AND $ 80000000 AND OR
195 : TRACE.CHECK.IP { ip -- }
196 ip ['] first_colon u<
199 ." TRACE - IP out of range = " ip .hex cr
204 : TRACE.SHOW.IP { ip -- , print name and offset }
205 ip code> >name dup id.
206 name> >code ip swap - ." +" .
209 : TRACE.SHOW.STACK { | mdepth -- }
211 ." <" base @ decimal 1 .r ." :"
214 depth 5 min -> mdepth
217 ." ... " \ if we don't show entire stack
221 mdepth i 1+ - pick . \ show numbers in current base
225 : TRACE.SHOW.NEXT { ip -- }
228 \ show word name and offset
234 65 space.to.column ." ||"
235 trace_level 2* spaces
238 \ show primitive about to be executed
240 \ trap any primitives that are followed by inline data
242 ['] (LITERAL) OF ip @ . ENDOF
243 ['] (ALITERAL) OF ip a@ . ENDOF
244 [ exists? (FLITERAL) [IF] ]
245 ['] (FLITERAL) OF ip f@ f. ENDOF
247 ['] BRANCH OF ip @ . ENDOF
248 ['] 0BRANCH OF ip @ . ENDOF
249 ['] (.") OF ip count type .' "' ENDOF
250 ['] (C") OF ip count type .' "' ENDOF
251 ['] (S") OF ip count type .' "' ENDOF
253 100 space.to.column ." >> "
256 : TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip }
259 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT
260 ['] (CREATE) OF ip cell- body_offset + ENDOF
261 ['] (LITERAL) OF ip @ cell +-> ip ENDOF
262 ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF
263 [ exists? (FLITERAL) [IF] ]
264 ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF
266 ['] BRANCH OF ip @ +-> ip ENDOF
267 ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF
268 ['] >R OF trace.>r ENDOF
269 ['] R> OF trace.r> ENDOF
270 ['] R@ OF trace.r@ ENDOF
271 ['] RDROP OF trace.rdrop ENDOF
272 ['] 2>R OF trace.>r trace.>r ENDOF
273 ['] 2R> OF trace.r> trace.r> ENDOF
274 ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF
275 ['] i OF 1 trace.rpick ENDOF
276 ['] j OF 3 trace.rpick ENDOF
277 ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF
278 ['] (LOOP) OF ip trace.(loop) -> ip ENDOF
279 ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF
280 ['] (DO) OF trace.>r trace.>r ENDOF
281 ['] (?DO) OF ip trace.(?do) -> ip ENDOF
282 ['] (.") OF ip count type ip count + aligned -> ip ENDOF
283 ['] (C") OF ip ip count + aligned -> ip ENDOF
284 ['] (S") OF ip count ip count + aligned -> ip ENDOF
285 ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF
286 ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF
287 ['] (LOCAL@) OF trace.(local@) ENDOF
288 ['] (1_LOCAL@) OF trace.(1_local@) ENDOF
289 ['] (2_LOCAL@) OF trace.(2_local@) ENDOF
290 ['] (3_LOCAL@) OF trace.(3_local@) ENDOF
291 ['] (4_LOCAL@) OF trace.(4_local@) ENDOF
292 ['] (5_LOCAL@) OF trace.(5_local@) ENDOF
293 ['] (6_LOCAL@) OF trace.(6_local@) ENDOF
294 ['] (7_LOCAL@) OF trace.(7_local@) ENDOF
295 ['] (8_LOCAL@) OF trace.(8_local@) ENDOF
296 ['] (LOCAL!) OF trace.(local!) ENDOF
297 ['] (1_LOCAL!) OF trace.(1_local!) ENDOF
298 ['] (2_LOCAL!) OF trace.(2_local!) ENDOF
299 ['] (3_LOCAL!) OF trace.(3_local!) ENDOF
300 ['] (4_LOCAL!) OF trace.(4_local!) ENDOF
301 ['] (5_LOCAL!) OF trace.(5_local!) ENDOF
302 ['] (6_LOCAL!) OF trace.(6_local!) ENDOF
303 ['] (7_LOCAL!) OF trace.(7_local!) ENDOF
304 ['] (8_LOCAL!) OF trace.(8_local!) ENDOF
305 ['] (LOCAL+!) OF trace.(local+!) ENDOF
311 : TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip }
313 \ set context for word under test
318 \ get execution token
324 ip xt trace.do.primitive -> ip
326 trace_level trace_level_max <
328 ip trace.>r \ threaded execution
332 \ treat it as a primitive
333 ip xt trace.do.primitive -> ip
336 \ restore original context
344 : TRACE.NEXT { ip | xt -- ip' }
347 ip trace.do.next -> ip
360 : TRACE ( i*x <name> -- i*x , setup trace environment )
363 drop ." Sorry. You can't trace a primitive." cr
366 trace_level -> trace_level_max
369 trace_ip trace.show.next
375 : s ( -- , step over )
376 trace_level -> trace_level_max
377 trace_ip trace.next -> trace_ip
380 : sd ( -- , step down )
381 trace_level 1+ -> trace_level_max
382 trace_ip trace.next -> trace_ip
385 : sm ( many -- , step down )
386 trace_level -> trace_level_max
389 trace_ip trace.next -> trace_ip
393 : gd { more_levels | stop_level -- }
396 ." GD requires a MORE_LEVELS parameter." cr
398 trace_level more_levels + -> trace_level_max
399 trace_level 1- -> stop_level
401 trace_ip trace.next -> trace_ip
402 trace_level stop_level > not
407 : g ( -- , execute until end of word )
412 ." TRACE ( i*x <name> -- , setup trace for Forth word )" cr
413 ." S ( -- , step over )" cr
414 ." SM ( many -- , step over many times )" cr
415 ." SD ( -- , step down )" cr
416 ." G ( -- , go to end of word )" cr
417 ." GD ( n -- , go down N levels from current level," cr
418 ." stop at end of this level )" cr
426 : FOO dup IF 1 + . THEN 77 var1 @ + . ;
427 : ZOO 29 foo 99 22 + . ;
428 : ROO 92 >r 1 r@ + . r> . ;
429 : MOO c" hello" count type
430 ." This is a message." cr
431 s" another message" type cr
433 : KOO 7 FOO ." DONE" ;
434 : TR.DO 4 0 DO i . LOOP ;
435 : TR.?DO 0 ?DO i . LOOP ;
436 : TR.LOC1 { aa bb } aa bb + . ;
437 : TR.LOC2 789 >r 4 5 tr.loc1 r> . ;