Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) trace.fth 98/01/28 1.2 |
2 | \ TRACE ( <name> -- , trace pForth word ) | |
3 | \ | |
4 | \ Single step debugger. | |
5 | \ TRACE ( i*x <name> -- , setup trace for Forth word ) | |
6 | \ S ( -- , step over ) | |
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 ) | |
11 | \ | |
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 | |
18 | \ tested. | |
19 | \ | |
20 | \ Copyright 1997 Phil Burk | |
21 | \ | |
22 | \ Modifications: | |
23 | \ 19990930 John Providenza - Fixed stack bugs in GD | |
24 | ||
25 | anew task-trace.fth | |
26 | ||
27 | : SPACE.TO.COLUMN ( col -- ) | |
28 | out @ - spaces | |
29 | ; | |
30 | ||
31 | : IS.PRIMITIVE? ( xt -- flag , true if kernel primitive ) | |
32 | ['] first_colon < | |
33 | ; | |
34 | ||
35 | 0 value TRACE_IP \ instruction pointer | |
36 | 0 value TRACE_LEVEL \ level of descent for inner interpreter | |
37 | 0 value TRACE_LEVEL_MAX \ maximum level of descent | |
38 | ||
39 | private{ | |
40 | ||
41 | \ use fake return stack | |
42 | 128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes | |
43 | create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot | |
44 | variable TRACE-RSP | |
45 | : TRACE.>R ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ; \ *(--rsp) = n | |
46 | : TRACE.R> ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ; \ n = *rsp++ | |
47 | : TRACE.R@ ( -- n ) trace-rsp @ @ ; ; \ n = *rsp | |
48 | : TRACE.RPICK ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index] | |
49 | : TRACE.0RP ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ; | |
50 | : TRACE.RDROP ( -- ) cell trace-rsp +! ; | |
51 | : TRACE.RCHECK ( -- , abort if return stack out of range ) | |
52 | trace-rsp @ trace-return-stack u< | |
53 | abort" TRACE return stack OVERFLOW!" | |
54 | trace-rsp @ trace-return-stack trace_return_size + 12 + u> | |
55 | abort" TRACE return stack UNDERFLOW!" | |
56 | ; | |
57 | ||
58 | \ save and restore several state variables | |
59 | 10 cells constant TRACE_STATE_SIZE | |
60 | create TRACE-STATE-1 TRACE_STATE_SIZE allot | |
61 | create TRACE-STATE-2 TRACE_STATE_SIZE allot | |
62 | ||
63 | variable TRACE-STATE-PTR | |
64 | : TRACE.SAVE++ ( addr -- , save next thing ) | |
65 | @ trace-state-ptr @ ! | |
66 | cell trace-state-ptr +! | |
67 | ; | |
68 | ||
69 | : TRACE.SAVE.STATE ( -- ) | |
70 | state trace.save++ | |
71 | hld trace.save++ | |
72 | base trace.save++ | |
73 | ; | |
74 | ||
75 | : TRACE.SAVE.STATE1 ( -- , save normal state ) | |
76 | trace-state-1 trace-state-ptr ! | |
77 | trace.save.state | |
78 | ; | |
79 | : TRACE.SAVE.STATE2 ( -- , save state of word being debugged ) | |
80 | trace-state-2 trace-state-ptr ! | |
81 | trace.save.state | |
82 | ; | |
83 | ||
84 | ||
85 | : TRACE.RESTORE++ ( addr -- , restore next thing ) | |
86 | trace-state-ptr @ @ swap ! | |
87 | cell trace-state-ptr +! | |
88 | ; | |
89 | ||
90 | : TRACE.RESTORE.STATE ( -- ) | |
91 | state trace.restore++ | |
92 | hld trace.restore++ | |
93 | base trace.restore++ | |
94 | ; | |
95 | ||
96 | : TRACE.RESTORE.STATE1 ( -- ) | |
97 | trace-state-1 trace-state-ptr ! | |
98 | trace.restore.state | |
99 | ; | |
100 | : TRACE.RESTORE.STATE2 ( -- ) | |
101 | trace-state-2 trace-state-ptr ! | |
102 | trace.restore.state | |
103 | ; | |
104 | ||
105 | \ The implementation of these pForth primitives is specific to pForth. | |
106 | ||
107 | variable TRACE-LOCALS-PTR \ point to top of local frame | |
108 | ||
109 | \ create a return stack frame for NUM local variables | |
110 | : TRACE.(LOCAL.ENTRY) ( x0 x1 ... xn n -- ) { num | lp -- } | |
111 | trace-locals-ptr @ trace.>r | |
112 | trace-rsp @ trace-locals-ptr ! | |
113 | trace-rsp @ num cells - trace-rsp ! \ make room for locals | |
114 | trace-rsp @ -> lp | |
115 | num 0 | |
116 | DO | |
117 | lp ! | |
118 | cell +-> lp \ move data into locals frame on return stack | |
119 | LOOP | |
120 | ; | |
121 | ||
122 | : TRACE.(LOCAL.EXIT) ( -- ) | |
123 | trace-locals-ptr @ trace-rsp ! | |
124 | trace.r> trace-locals-ptr ! | |
125 | ; | |
126 | : TRACE.(LOCAL@) ( l# -- n , fetch from local frame ) | |
127 | trace-locals-ptr @ swap cells - @ | |
128 | ; | |
129 | : TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ; | |
130 | : TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ; | |
131 | : TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ; | |
132 | : TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ; | |
133 | : TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ; | |
134 | : TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ; | |
135 | : TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ; | |
136 | : TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ; | |
137 | ||
138 | : TRACE.(LOCAL!) ( n l# -- , store into local frame ) | |
139 | trace-locals-ptr @ swap cells - ! | |
140 | ; | |
141 | : TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ; | |
142 | : TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ; | |
143 | : TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ; | |
144 | : TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ; | |
145 | : TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ; | |
146 | : TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ; | |
147 | : TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ; | |
148 | : TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ; | |
149 | ||
150 | : TRACE.(LOCAL+!) ( n l# -- , store into local frame ) | |
151 | trace-locals-ptr @ swap cells - +! | |
152 | ; | |
153 | : TRACE.(?DO) { limit start ip -- ip' } | |
154 | limit start = | |
155 | IF | |
156 | ip @ +-> ip \ BRANCH | |
157 | ELSE | |
158 | start trace.>r | |
159 | limit trace.>r | |
160 | cell +-> ip | |
161 | THEN | |
162 | ip | |
163 | ; | |
164 | ||
165 | : TRACE.(LOOP) { ip | limit indx -- ip' } | |
166 | trace.r> -> limit | |
167 | trace.r> 1+ -> indx | |
168 | limit indx = | |
169 | IF | |
170 | cell +-> ip | |
171 | ELSE | |
172 | indx trace.>r | |
173 | limit trace.>r | |
174 | ip @ +-> ip | |
175 | THEN | |
176 | ip | |
177 | ; | |
178 | ||
179 | : TRACE.(+LOOP) { delta ip | limit indx oldindx -- ip' } | |
180 | trace.r> -> limit | |
181 | trace.r> -> oldindx | |
182 | oldindx delta + -> indx | |
183 | \ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */ | |
184 | \ if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) || | |
185 | \ ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) ) | |
186 | oldindx limit - limit 1- indx - AND $ 80000000 AND | |
187 | indx limit - limit 1- oldindx - AND $ 80000000 AND OR | |
188 | IF | |
189 | cell +-> ip | |
190 | ELSE | |
191 | indx trace.>r | |
192 | limit trace.>r | |
193 | ip @ +-> ip | |
194 | THEN | |
195 | ip | |
196 | ; | |
197 | ||
198 | : TRACE.CHECK.IP { ip -- } | |
199 | ip ['] first_colon u< | |
200 | ip here u> OR | |
201 | IF | |
202 | ." TRACE - IP out of range = " ip .hex cr | |
203 | abort | |
204 | THEN | |
205 | ; | |
206 | ||
207 | : TRACE.SHOW.IP { ip -- , print name and offset } | |
208 | ip code> >name dup id. | |
209 | name> >code ip swap - ." +" . | |
210 | ; | |
211 | ||
212 | : TRACE.SHOW.STACK { | mdepth -- } | |
213 | base @ >r | |
214 | ." <" base @ decimal 1 .r ." :" | |
215 | depth 1 .r ." > " | |
216 | r> base ! | |
217 | depth 5 min -> mdepth | |
218 | depth mdepth - | |
219 | IF | |
220 | ." ... " \ if we don't show entire stack | |
221 | THEN | |
222 | mdepth 0 | |
223 | ?DO | |
224 | mdepth i 1+ - pick . \ show numbers in current base | |
225 | LOOP | |
226 | ; | |
227 | ||
228 | : TRACE.SHOW.NEXT { ip -- } | |
229 | >newline | |
230 | ip trace.check.ip | |
231 | \ show word name and offset | |
232 | ." << " | |
233 | ip trace.show.ip | |
234 | 16 space.to.column | |
235 | \ show data stack | |
236 | trace.show.stack | |
237 | 40 space.to.column ." ||" | |
238 | trace_level 2* spaces | |
239 | ip code@ | |
240 | cell +-> ip | |
241 | \ show primitive about to be executed | |
242 | dup .xt space | |
243 | \ trap any primitives that are followed by inline data | |
244 | CASE | |
245 | ['] (LITERAL) OF ip @ . ENDOF | |
246 | ['] (ALITERAL) OF ip a@ . ENDOF | |
247 | [ exists? (FLITERAL) [IF] ] | |
248 | ['] (FLITERAL) OF ip f@ f. ENDOF | |
249 | [ [THEN] ] | |
250 | ['] BRANCH OF ip @ . ENDOF | |
251 | ['] 0BRANCH OF ip @ . ENDOF | |
252 | ['] (.") OF ip count type .' "' ENDOF | |
253 | ['] (C") OF ip count type .' "' ENDOF | |
254 | ['] (S") OF ip count type .' "' ENDOF | |
255 | ENDCASE | |
256 | 65 space.to.column ." >> " | |
257 | ; | |
258 | ||
259 | : TRACE.DO.PRIMITIVE { ip xt | oldhere -- ip' , perform code at ip } | |
260 | xt | |
261 | CASE | |
262 | 0 OF -1 +-> trace_level trace.r> -> ip ENDOF \ EXIT | |
263 | ['] (CREATE) OF ip cell- body_offset + ENDOF | |
264 | ['] (LITERAL) OF ip @ cell +-> ip ENDOF | |
265 | ['] (ALITERAL) OF ip a@ cell +-> ip ENDOF | |
266 | [ exists? (FLITERAL) [IF] ] | |
267 | ['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF | |
268 | [ [THEN] ] | |
269 | ['] BRANCH OF ip @ +-> ip ENDOF | |
270 | ['] 0BRANCH OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF | |
271 | ['] >R OF trace.>r ENDOF | |
272 | ['] R> OF trace.r> ENDOF | |
273 | ['] R@ OF trace.r@ ENDOF | |
274 | ['] RDROP OF trace.rdrop ENDOF | |
275 | ['] 2>R OF trace.>r trace.>r ENDOF | |
276 | ['] 2R> OF trace.r> trace.r> ENDOF | |
277 | ['] 2R@ OF trace.r@ 1 trace.rpick ENDOF | |
278 | ['] i OF 1 trace.rpick ENDOF | |
279 | ['] j OF 3 trace.rpick ENDOF | |
280 | ['] (LEAVE) OF trace.rdrop trace.rdrop ip @ +-> ip ENDOF | |
281 | ['] (LOOP) OF ip trace.(loop) -> ip ENDOF | |
282 | ['] (+LOOP) OF ip trace.(+loop) -> ip ENDOF | |
283 | ['] (DO) OF trace.>r trace.>r ENDOF | |
284 | ['] (?DO) OF ip trace.(?do) -> ip ENDOF | |
285 | ['] (.") OF ip count type ip count + aligned -> ip ENDOF | |
286 | ['] (C") OF ip ip count + aligned -> ip ENDOF | |
287 | ['] (S") OF ip count ip count + aligned -> ip ENDOF | |
288 | ['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF | |
289 | ['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF | |
290 | ['] (LOCAL@) OF trace.(local@) ENDOF | |
291 | ['] (1_LOCAL@) OF trace.(1_local@) ENDOF | |
292 | ['] (2_LOCAL@) OF trace.(2_local@) ENDOF | |
293 | ['] (3_LOCAL@) OF trace.(3_local@) ENDOF | |
294 | ['] (4_LOCAL@) OF trace.(4_local@) ENDOF | |
295 | ['] (5_LOCAL@) OF trace.(5_local@) ENDOF | |
296 | ['] (6_LOCAL@) OF trace.(6_local@) ENDOF | |
297 | ['] (7_LOCAL@) OF trace.(7_local@) ENDOF | |
298 | ['] (8_LOCAL@) OF trace.(8_local@) ENDOF | |
299 | ['] (LOCAL!) OF trace.(local!) ENDOF | |
300 | ['] (1_LOCAL!) OF trace.(1_local!) ENDOF | |
301 | ['] (2_LOCAL!) OF trace.(2_local!) ENDOF | |
302 | ['] (3_LOCAL!) OF trace.(3_local!) ENDOF | |
303 | ['] (4_LOCAL!) OF trace.(4_local!) ENDOF | |
304 | ['] (5_LOCAL!) OF trace.(5_local!) ENDOF | |
305 | ['] (6_LOCAL!) OF trace.(6_local!) ENDOF | |
306 | ['] (7_LOCAL!) OF trace.(7_local!) ENDOF | |
307 | ['] (8_LOCAL!) OF trace.(8_local!) ENDOF | |
308 | ['] (LOCAL+!) OF trace.(local+!) ENDOF | |
309 | >r xt EXECUTE r> | |
310 | ENDCASE | |
311 | ip | |
312 | ; | |
313 | ||
314 | : TRACE.DO.NEXT { ip | xt oldhere -- ip' , perform code at ip } | |
315 | ip trace.check.ip | |
316 | \ set context for word under test | |
317 | trace.save.state1 | |
318 | here -> oldhere | |
319 | trace.restore.state2 | |
320 | oldhere 256 + dp ! | |
321 | \ get execution token | |
322 | ip code@ -> xt | |
323 | cell +-> ip | |
324 | \ execute token | |
325 | xt is.primitive? | |
326 | IF \ primitive | |
327 | ip xt trace.do.primitive -> ip | |
328 | ELSE \ secondary | |
329 | trace_level trace_level_max < | |
330 | IF | |
331 | ip trace.>r \ threaded execution | |
332 | 1 +-> trace_level | |
333 | xt codebase + -> ip | |
334 | ELSE | |
335 | \ treat it as a primitive | |
336 | ip xt trace.do.primitive -> ip | |
337 | THEN | |
338 | THEN | |
339 | \ restore original context | |
340 | trace.rcheck | |
341 | trace.save.state2 | |
342 | trace.restore.state1 | |
343 | oldhere dp ! | |
344 | ip | |
345 | ; | |
346 | ||
347 | : TRACE.NEXT { ip | xt -- ip' } | |
348 | trace_level 0> | |
349 | IF | |
350 | ip trace.do.next -> ip | |
351 | THEN | |
352 | trace_level 0> | |
353 | IF | |
354 | ip trace.show.next | |
355 | ELSE | |
356 | trace-stack on | |
357 | ." Finished." cr | |
358 | THEN | |
359 | ip | |
360 | ; | |
361 | ||
362 | }private | |
363 | ||
364 | : TRACE ( i*x <name> -- i*x , setup trace environment ) | |
365 | ' dup is.primitive? | |
366 | IF | |
367 | drop ." Sorry. You can't trace a primitive." cr | |
368 | ELSE | |
369 | 1 -> trace_level | |
370 | trace_level -> trace_level_max | |
371 | trace.0rp | |
372 | >code -> trace_ip | |
373 | trace_ip trace.show.next | |
374 | trace-stack off | |
375 | trace.save.state2 | |
376 | THEN | |
377 | ; | |
378 | ||
379 | : s ( -- , step over ) | |
380 | trace_level -> trace_level_max | |
381 | trace_ip trace.next -> trace_ip | |
382 | ; | |
383 | ||
384 | : sd ( -- , step down ) | |
385 | trace_level 1+ -> trace_level_max | |
386 | trace_ip trace.next -> trace_ip | |
387 | ; | |
388 | ||
389 | : sm ( many -- , step many times ) | |
390 | trace_level -> trace_level_max | |
391 | 0 | |
392 | ?DO | |
393 | trace_ip trace.next -> trace_ip | |
394 | LOOP | |
395 | ; | |
396 | ||
397 | defer trace.user ( IP -- stop? ) | |
398 | ' 0= is trace.user | |
399 | ||
400 | : gd { more_levels | stop_level -- } | |
401 | here what's trace.user u< \ has it been forgotten? | |
402 | IF | |
403 | ." Resetting TRACE.USER !!!" cr | |
404 | ['] 0= is trace.user | |
405 | THEN | |
406 | ||
407 | more_levels 0< | |
408 | more_levels 10 > | |
409 | or \ 19990930 - OR was missing | |
410 | IF | |
411 | ." GD level out of range (0-10), = " more_levels . cr | |
412 | ELSE | |
413 | trace_level more_levels + -> trace_level_max | |
414 | trace_level 1- -> stop_level | |
415 | BEGIN | |
416 | trace_ip trace.user \ call deferred user word | |
417 | ?dup \ leave flag for UNTIL \ 19990930 - was DUP | |
418 | IF | |
419 | ." TRACE.USER returned " dup . ." so stopping execution." cr | |
420 | ELSE | |
421 | trace_ip trace.next -> trace_ip | |
422 | trace_level stop_level > not | |
423 | THEN | |
424 | UNTIL | |
425 | THEN | |
426 | ; | |
427 | ||
428 | : g ( -- , execute until end of word ) | |
429 | 0 gd | |
430 | ; | |
431 | ||
432 | : TRACE.HELP ( -- ) | |
433 | ." TRACE ( i*x <name> -- , setup trace for Forth word )" cr | |
434 | ." S ( -- , step over )" cr | |
435 | ." SM ( many -- , step over many times )" cr | |
436 | ." SD ( -- , step down )" cr | |
437 | ." G ( -- , go to end of word )" cr | |
438 | ." GD ( n -- , go down N levels from current level," cr | |
439 | ." stop at end of this level )" cr | |
440 | ; | |
441 | ||
442 | privatize | |
443 | ||
444 | 0 [IF] | |
445 | variable var1 | |
446 | 100 var1 ! | |
447 | : FOO dup IF 1 + . THEN 77 var1 @ + . ; | |
448 | : ZOO 29 foo 99 22 + . ; | |
449 | : ROO 92 >r 1 r@ + . r> . ; | |
450 | : MOO c" hello" count type | |
451 | ." This is a message." cr | |
452 | s" another message" type cr | |
453 | ; | |
454 | : KOO 7 FOO ." DONE" ; | |
455 | : TR.DO 4 0 DO i . LOOP ; | |
456 | : TR.?DO 0 ?DO i . LOOP ; | |
457 | : TR.LOC1 { aa bb } aa bb + . ; | |
458 | : TR.LOC2 789 >r 4 5 tr.loc1 r> . ; | |
459 | ||
460 | [THEN] |