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