/fth/utils/trace.fth

\ @(#) trace.fth 98/01/08 1.1

\ TRACE ( <name> -- , trace pForth word )

\

\ Single step debugger.

\   TRACE  ( i*x <name> -- , setup trace for Forth word )

\   S      ( -- , step over )

\   SM     ( many -- , step over many times )

\   SD     ( -- , step down )

\   G      ( -- , go to end of word )

\   GD     ( n -- , go down N levels from current level, stop at end of this level )

\

\ This debugger works by emulating the inner interpreter of pForth.

\ It executes code and maintains a separate return stack for the

\ program under test.  Thus all primitives that operate on the return

\ stack, such as DO and R> must be trapped.  Local variables must

\ also be handled specially.  Several state variables are also

\ saved and restored to establish the context for the program being

\ tested.

\    

\ Copyright 1997 Phil Burk



anew task-trace.fth



: SPACE.TO.COLUMN  ( col -- )

	out @ - spaces

;



: IS.PRIMITIVE? ( xt -- flag , true if kernel primitive )

	['] first_colon <

;



0 value TRACE_IP         \ instruction pointer

0 value TRACE_LEVEL      \ level of descent for inner interpreter

0 value TRACE_LEVEL_MAX  \ maximum level of descent



private{



\ use fake return stack

128 cells constant TRACE_RETURN_SIZE \ size of return stack in bytes

create TRACE-RETURN-STACK TRACE_RETURN_SIZE 16 + allot

variable TRACE-RSP

: TRACE.>R     ( n -- ) trace-rsp @ cell- dup trace-rsp ! ! ;  \ *(--rsp) = n

: TRACE.R>     ( -- n ) trace-rsp @ dup @ swap cell+ trace-rsp ! ;  \ n = *rsp++

: TRACE.R@     ( -- n ) trace-rsp @ @ ; ; \ n = *rsp

: TRACE.RPICK  ( index -- n ) cells trace-rsp @ + @ ; ; \ n = rsp[index]

: TRACE.0RP    ( -- n ) trace-return-stack trace_return_size + 8 + trace-rsp ! ;

: TRACE.RDROP  ( --  ) cell trace-rsp +! ;

: TRACE.RCHECK ( -- , abort if return stack out of range )

	trace-rsp @ trace-return-stack u<

		abort" TRACE return stack OVERFLOW!"

	trace-rsp @ trace-return-stack trace_return_size + 12 + u>

		abort" TRACE return stack UNDERFLOW!"

;



\ save and restore several state variables

10 cells constant TRACE_STATE_SIZE

create TRACE-STATE-1 TRACE_STATE_SIZE allot

create TRACE-STATE-2 TRACE_STATE_SIZE allot



variable TRACE-STATE-PTR

: TRACE.SAVE++ ( addr -- , save next thing )

	@ trace-state-ptr @ !

	cell trace-state-ptr +!

;



: TRACE.SAVE.STATE  ( -- )

	state trace.save++

	hld   trace.save++

	base  trace.save++

;



: TRACE.SAVE.STATE1  ( -- , save normal state )

	trace-state-1 trace-state-ptr !

	trace.save.state

;

: TRACE.SAVE.STATE2  ( -- , save state of word being debugged )

	trace-state-2 trace-state-ptr !

	trace.save.state

;





: TRACE.RESTORE++ ( addr -- , restore next thing )

	trace-state-ptr @ @ swap !

	cell trace-state-ptr +!

;



: TRACE.RESTORE.STATE  ( -- )

	state trace.restore++

	hld   trace.restore++

	base  trace.restore++

;



: TRACE.RESTORE.STATE1  ( -- )

	trace-state-1 trace-state-ptr !

	trace.restore.state

;

: TRACE.RESTORE.STATE2  ( -- )

	trace-state-2 trace-state-ptr !

	trace.restore.state

;



\ The implementation of these pForth primitives is specific to pForth.



variable TRACE-LOCALS-PTR  \ point to top of local frame



\ create a return stack frame for NUM local variables

: TRACE.(LOCAL.ENTRY)  ( x0 x1 ... xn n -- )  { num | lp -- }

	trace-locals-ptr @ trace.>r

	trace-rsp @ trace-locals-ptr !

	trace-rsp @  num cells - trace-rsp !  \ make room for locals

	trace-rsp @ -> lp

	num 0

	DO

		lp !

		cell +-> lp  \ move data into locals frame on return stack

	LOOP

;

	

: TRACE.(LOCAL.EXIT) ( -- )

	trace-locals-ptr @  trace-rsp !

	trace.r> trace-locals-ptr !

;

: TRACE.(LOCAL@) ( l# -- n , fetch from local frame )

	trace-locals-ptr @  swap cells - @

;

: TRACE.(1_LOCAL@) ( -- n ) 1 trace.(local@) ;

: TRACE.(2_LOCAL@) ( -- n ) 2 trace.(local@) ;

: TRACE.(3_LOCAL@) ( -- n ) 3 trace.(local@) ;

: TRACE.(4_LOCAL@) ( -- n ) 4 trace.(local@) ;

: TRACE.(5_LOCAL@) ( -- n ) 5 trace.(local@) ;

: TRACE.(6_LOCAL@) ( -- n ) 6 trace.(local@) ;

: TRACE.(7_LOCAL@) ( -- n ) 7 trace.(local@) ;

: TRACE.(8_LOCAL@) ( -- n ) 8 trace.(local@) ;



: TRACE.(LOCAL!) ( n l# -- , store into local frame )

	trace-locals-ptr @  swap cells - !

;

: TRACE.(1_LOCAL!) ( -- n ) 1 trace.(local!) ;

: TRACE.(2_LOCAL!) ( -- n ) 2 trace.(local!) ;

: TRACE.(3_LOCAL!) ( -- n ) 3 trace.(local!) ;

: TRACE.(4_LOCAL!) ( -- n ) 4 trace.(local!) ;

: TRACE.(5_LOCAL!) ( -- n ) 5 trace.(local!) ;

: TRACE.(6_LOCAL!) ( -- n ) 6 trace.(local!) ;

: TRACE.(7_LOCAL!) ( -- n ) 7 trace.(local!) ;

: TRACE.(8_LOCAL!) ( -- n ) 8 trace.(local!) ;



: TRACE.(LOCAL+!) ( n l# -- , store into local frame )

	trace-locals-ptr @  swap cells - +!

;

: TRACE.(?DO)  { limit start ip -- ip' }

	limit start =

	IF

		ip @ +-> ip \ BRANCH

	ELSE

		start trace.>r

		limit trace.>r

		cell +-> ip

	THEN

	ip

;



: TRACE.(LOOP)  { ip | limit indx -- ip' }

	trace.r> -> limit

	trace.r> 1+ -> indx

	limit indx =

	IF

		cell +-> ip

	ELSE

		indx trace.>r

		limit trace.>r

		ip @ +-> ip

	THEN

	ip

;



: TRACE.(+LOOP)  { delta ip | limit indx oldindx -- ip' }

	trace.r> -> limit

	trace.r> -> oldindx

	oldindx delta + -> indx

\ /* Do indices cross boundary between LIMIT-1 and LIMIT ? */

\  if( ( (OldIndex - Limit) & ((Limit-1) - NewIndex) & 0x80000000 ) ||

\    ( (NewIndex - Limit) & ((Limit-1) - OldIndex) & 0x80000000 ) )

	oldindx limit -    limit 1-    indx -  AND $ 80000000 AND

	   indx limit -    limit 1- oldindx -  AND $ 80000000 AND OR

	IF

		cell +-> ip

	ELSE

		indx trace.>r

		limit trace.>r

		ip @ +-> ip

	THEN

	ip

;



: TRACE.CHECK.IP  {  ip -- }

	ip ['] first_colon u<

	ip here u> OR

	IF

		." TRACE - IP out of range = " ip .hex cr

		abort

	THEN

;



: TRACE.SHOW.IP { ip -- , print name and offset }

	ip code> >name dup id.

	name> >code ip swap - ."  +" .

;



: TRACE.SHOW.STACK { | mdepth -- }

	base @ >r

	." <" base @ decimal 1 .r ." :"

	depth 1 .r ." > "

	r> base !

	depth 5 min -> mdepth

	depth mdepth  -

	IF

		." ... "  \ if we don't show entire stack

	THEN

	mdepth 0

	?DO

		mdepth i 1+ - pick .  \ show numbers in current base

	LOOP

;



: TRACE.SHOW.NEXT { ip -- }

	>newline

	ip trace.check.ip

\ show word name and offset

	." <<  "

	ip trace.show.ip

	30 space.to.column

\ show data stack

	trace.show.stack

	65 space.to.column ."  ||"

	trace_level 2* spaces

	ip code@

	cell +-> ip

\ show primitive about to be executed

	dup .xt space

\ trap any primitives that are followed by inline data

	CASE

		['] (LITERAL)  OF ip @  . ENDOF

		['] (ALITERAL) OF ip a@ . ENDOF

[ exists? (FLITERAL) [IF] ]

		['] (FLITERAL) OF ip f@ f. ENDOF

[ [THEN] ]

		['] BRANCH     OF ip @  . ENDOF

		['] 0BRANCH    OF ip @  . ENDOF

		['] (.")       OF ip count type .' "' ENDOF

		['] (C")       OF ip count type .' "' ENDOF

		['] (S")       OF ip count type .' "' ENDOF

	ENDCASE

	100 space.to.column ."  >> "

;



: TRACE.DO.PRIMITIVE  { ip xt | oldhere --  ip' , perform code at ip }

	xt

	CASE

		0 OF -1 +-> trace_level  trace.r> -> ip ENDOF \ EXIT

		['] (CREATE)   OF ip cell- body_offset + ENDOF

		['] (LITERAL)  OF ip @ cell +-> ip ENDOF

		['] (ALITERAL) OF ip a@ cell +-> ip ENDOF

[ exists? (FLITERAL) [IF] ]

		['] (FLITERAL) OF ip f@ 1 floats +-> ip ENDOF

[ [THEN] ]

		['] BRANCH     OF ip @ +-> ip ENDOF

		['] 0BRANCH    OF 0= IF ip @ +-> ip ELSE cell +-> ip THEN ENDOF

		['] >R         OF trace.>r ENDOF

		['] R>         OF trace.r> ENDOF

		['] R@         OF trace.r@ ENDOF

		['] RDROP      OF trace.rdrop ENDOF

		['] 2>R        OF trace.>r trace.>r ENDOF

		['] 2R>        OF trace.r> trace.r> ENDOF

		['] 2R@        OF trace.r@ 1 trace.rpick ENDOF

		['] i          OF 1 trace.rpick ENDOF

		['] j          OF 3 trace.rpick ENDOF

		['] (LEAVE)    OF trace.rdrop trace.rdrop  ip @ +-> ip ENDOF

		['] (LOOP)     OF ip trace.(loop) -> ip  ENDOF

		['] (+LOOP)    OF ip trace.(+loop) -> ip  ENDOF

		['] (DO)       OF trace.>r trace.>r ENDOF

		['] (?DO)      OF ip trace.(?do) -> ip ENDOF

		['] (.")       OF ip count type  ip count + aligned -> ip ENDOF

		['] (C")       OF ip  ip count + aligned -> ip ENDOF

		['] (S")       OF ip count  ip count + aligned -> ip ENDOF

		['] (LOCAL.ENTRY) OF trace.(local.entry) ENDOF

		['] (LOCAL.EXIT) OF trace.(local.exit) ENDOF

		['] (LOCAL@)   OF trace.(local@)   ENDOF

		['] (1_LOCAL@) OF trace.(1_local@) ENDOF

		['] (2_LOCAL@) OF trace.(2_local@) ENDOF

		['] (3_LOCAL@) OF trace.(3_local@) ENDOF

		['] (4_LOCAL@) OF trace.(4_local@) ENDOF

		['] (5_LOCAL@) OF trace.(5_local@) ENDOF

		['] (6_LOCAL@) OF trace.(6_local@) ENDOF

		['] (7_LOCAL@) OF trace.(7_local@) ENDOF

		['] (8_LOCAL@) OF trace.(8_local@) ENDOF

		['] (LOCAL!)   OF trace.(local!)   ENDOF

		['] (1_LOCAL!) OF trace.(1_local!) ENDOF

		['] (2_LOCAL!) OF trace.(2_local!) ENDOF

		['] (3_LOCAL!) OF trace.(3_local!) ENDOF

		['] (4_LOCAL!) OF trace.(4_local!) ENDOF

		['] (5_LOCAL!) OF trace.(5_local!) ENDOF

		['] (6_LOCAL!) OF trace.(6_local!) ENDOF

		['] (7_LOCAL!) OF trace.(7_local!) ENDOF

		['] (8_LOCAL!) OF trace.(8_local!) ENDOF

		['] (LOCAL+!)  OF trace.(local+!)  ENDOF

		>r xt EXECUTE r>

	ENDCASE

	ip

;



: TRACE.DO.NEXT  { ip | xt oldhere --  ip' , perform code at ip }

	ip trace.check.ip

\ set context for word under test

	trace.save.state1

	here -> oldhere

	trace.restore.state2

	oldhere 256 + dp !

\ get execution token

	ip code@ -> xt

	cell +-> ip

\ execute token

	xt is.primitive?

	IF  \ primitive

		ip xt trace.do.primitive -> ip

	ELSE \ secondary

		trace_level trace_level_max <

		IF

			ip trace.>r         \ threaded execution

			1 +-> trace_level

			xt codebase + -> ip

		ELSE

			\ treat it as a primitive

			ip xt trace.do.primitive -> ip

		THEN		

	THEN

\ restore original context

	trace.rcheck

	trace.save.state2

	trace.restore.state1

	oldhere dp !

	ip

;



: TRACE.NEXT { ip | xt -- ip' }

	trace_level 0>

	IF

		ip trace.do.next -> ip

	THEN

	trace_level 0>

	IF

		ip trace.show.next

	ELSE

		." Finished." cr

	THEN

	ip

;



}private



: TRACE ( i*x <name> -- i*x , setup trace environment )

	' dup is.primitive?

	IF

		drop ." Sorry. You can't trace a primitive." cr

	ELSE

		1 -> trace_level

		trace_level -> trace_level_max

		trace.0rp

		>code -> trace_ip

		trace_ip trace.show.next

		trace-stack off

		trace.save.state2

	THEN

;



: s ( -- , step over )

	trace_level -> trace_level_max

	trace_ip trace.next -> trace_ip

;



: sd ( -- , step down )

	trace_level 1+ -> trace_level_max

	trace_ip trace.next -> trace_ip

;



: sm ( many -- , step down )

	trace_level -> trace_level_max

	0

	?DO

		trace_ip trace.next -> trace_ip

	LOOP

;



: gd { more_levels | stop_level -- }

	depth 1 <

	IF

		." GD requires a MORE_LEVELS parameter." cr

	ELSE

		trace_level more_levels + -> trace_level_max

		trace_level 1- -> stop_level

		BEGIN

			trace_ip trace.next -> trace_ip

			trace_level stop_level > not

		UNTIL

	THEN

;



: g ( -- , execute until end of word )

	0 gd

;



: TRACE.HELP ( -- )

	."   TRACE  ( i*x <name> -- , setup trace for Forth word )" cr

	."   S      ( -- , step over )" cr

	."   SM     ( many -- , step over many times )" cr

	."   SD     ( -- , step down )" cr

	."   G      ( -- , go to end of word )" cr

	."   GD     ( n -- , go down N levels from current level," cr

	."                   stop at end of this level )" cr

;



privatize



0 [IF]

variable var1

100 var1 !

: FOO  dup IF 1 + . THEN 77 var1 @ + . ;

: ZOO 29 foo 99 22 + . ;

: ROO 92 >r 1 r@ + . r> . ;

: MOO  c" hello" count type

	." This is a message." cr

	s" another message" type cr

;

: KOO 7 FOO ." DONE" ;

: TR.DO  4 0 DO i . LOOP ;

: TR.?DO  0 ?DO i . LOOP ;

: TR.LOC1 { aa bb } aa bb + . ;

: TR.LOC2 789 >r 4 5 tr.loc1 r> . ;

[THEN]