/fth/trace.fth

https://github.com/philburk/pforth · Forth · 460 lines · 418 code · 42 blank · 0 comment · 9 complexity · f8bee53f375537e43df02dc01aed0c6d MD5 · raw file

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