clone.fth | searchcode

/fth/utils/clone.fth

https://github.com/cataska/pforth
Forth | 489 lines | 431 code | 58 blank | 0 comment | 10 complexity | 8d42b76162a2f1ef43b933c195535f30 MD5 | raw file

\ @(#) clone.fth 97/12/10 1.1

\ Clone for PForth

\

\ Create the smallest dictionary required to run an application.

\

\ Clone decompiles the Forth dictionary starting with the top

\ word in the program.  It then moves all referenced secondaries

\ into a new dictionary.

\

\ This work was inspired by the CLONE feature that Mike Haas wrote

\ for JForth.  Mike's CLONE disassembled 68000 machine code then

\ reassembled it which is much more difficult.

\

\ Copyright Phil Burk & 3DO 1994

\

\ O- trap custom 'C' calls

\ O- investigate ALITERAL, XLITERAL, use XLITERAL in [']



anew task-clone.fth

decimal



\ move to 'C'

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

	['] FIRST_COLON <

;



: 'SELF ( -- xt , return xt of word being compiled )

	?comp

	latest name>

	[compile] literal

; immediate





:struct CL.REFERENCE

	long  clr_OriginalXT    \ original XT of word

	long  clr_NewXT         \ corresponding XT in cloned dictionary

	long  clr_TotalSize     \ size including data in body

;struct



variable CL-INITIAL-REFS \ initial number of refs to allocate

100 cl-initial-refs !

variable CL-REF-LEVEL    \ level of threading while scanning

variable CL-NUM-REFS     \ number of secondaries referenced

variable CL-MAX-REFS     \ max number of secondaries allocated

variable CL-LEVEL-MAX    \ max level reached while scanning

variable CL-LEVEL-ABORT  \ max level before aborting

10 cl-level-abort !

variable CL-REFERENCES   \ pointer to cl.reference array

variable CL-TRACE        \ print debug stuff if true



\ Cloned dictionary builds in allocated memory but XTs are relative

\ to normal code-base, if CL-TEST-MODE true.

variable CL-TEST-MODE

 

variable CL-INITIAL-DICT \ initial size of dict to allocate

20 1024 * cl-initial-dict !

variable CL-DICT-SIZE    \ size of allocated cloned dictionary

variable CL-DICT-BASE    \ pointer to virtual base of cloned dictionary

variable CL-DICT-ALLOC   \ pointer to allocated dictionary memory

variable CL-DICT-PTR     \ rel pointer index into cloned dictionary

0 cl-dict-base !



	

: CL.INDENT ( -- )

	cl-ref-level @ 2* 2* spaces

;

: CL.DUMP.NAME ( xt -- )

	cl.indent

	>name id. cr

;



: CL.DICT[] ( relptr -- addr )

	cl-dict-base @ +

;



: CL,  ( cell -- , comma into clone dictionary )

	cl-dict-ptr @ cl.dict[] !

	cell cl-dict-ptr +!

;





: CL.FREE.DICT ( -- , free dictionary we built into )

	cl-dict-alloc @ ?dup

	IF

		free dup ?error

		0 cl-dict-alloc !

	THEN

;



: CL.FREE.REFS ( -- , free dictionary we built into )

	cl-references @ ?dup

	IF

		free dup ?error

		0 cl-references !

	THEN

;



: CL.ALLOC.REFS ( --  , allocate references to track )

	cl-initial-refs @  \ initial number of references

	dup cl-max-refs ! \ maximum allowed

	sizeof() cl.reference *

	allocate dup ?error

	cl-references !

;



: CL.RESIZE.REFS ( -- , allocate references to track )

	cl-max-refs @   \ current number of references allocated

	5 * 4 / dup cl-max-refs ! \ new maximum allowed

\ cl.indent ." Resize # references to " dup . cr

	sizeof() cl.reference *

	cl-references @ swap resize dup ?error

	cl-references !

;





: CL.ALLOC.DICT ( -- , allocate dictionary to build into )

	cl-initial-dict @  \ initial dictionary size

	dup cl-dict-size !

	allocate dup ?error

	cl-dict-alloc !

\

\ kludge dictionary if testing

	cl-test-mode @

	IF

		cl-dict-alloc @ code-base @ - cl-dict-ptr +!

		code-base @ cl-dict-base !

	ELSE

		cl-dict-alloc @  cl-dict-base !

	THEN

	." CL.ALLOC.DICT" cr

	."   cl-dict-alloc = $" cl-dict-alloc @ .hex cr

	."   cl-dict-base  = $" cl-dict-base @ .hex cr

	."   cl-dict-ptr   = $" cl-dict-ptr @ .hex cr

;



: CODEADDR>DATASIZE { code-addr -- datasize }

\ Determine size of any literal data following execution token.

\ Examples are text following (."), or branch offsets.

	code-addr @

	CASE

	['] (literal) OF cell ENDOF   \ a number

	['] 0branch   OF cell ENDOF   \ branch offset

	['] branch    OF cell ENDOF

	['] (do)      OF    0 ENDOF

	['] (?do)     OF cell ENDOF

	['] (loop)    OF cell ENDOF

	['] (+loop)   OF cell ENDOF

	['] (.")      OF code-addr cell+ c@ 1+ ENDOF  \ text

	['] (s")      OF code-addr cell+ c@ 1+ ENDOF

	['] (c")      OF code-addr cell+ c@ 1+ ENDOF

	0 swap

	ENDCASE

;



: XT>SIZE  ( xt -- wordsize , including code and data )

	dup >code

	swap >name

	dup latest =

	IF

		drop here

	ELSE

		dup c@ 1+ + aligned 8 + \ get next name

		name> >code \ where is next word

	THEN

	swap -

;



\ ------------------------------------------------------------------

: CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize --  }

\ scan secondary and pass each code-address to ca-process

\ CA-PROCESS ( code-addr -- , required stack action for vector )

	1 cl-ref-level +!

	cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL"

	BEGIN

		code-addr @ -> xt

\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr

		code-addr codeaddr>datasize -> dsize      \ any data after this?

		code-addr ca-process execute              \ process it

		code-addr cell+ dsize + aligned -> code-addr  \ skip past data

\ !!! Bummer! EXIT called in middle of secondary will cause early stop.

		xt  ['] EXIT  =                           \ stop when we get to EXIT

	UNTIL

	-1 cl-ref-level +!

;



\ ------------------------------------------------------------------



: CL.DUMP.XT ( xt -- )

	cl-trace @

	IF

		dup primitive?

		IF   ." PRI:  "

		ELSE ." SEC:  "

		THEN

		cl.dump.name

	ELSE

		drop

	THEN

;



\ ------------------------------------------------------------------

: CL.REF[] ( index -- clref )

	sizeof() cl.reference *

	cl-references @ +

;



: CL.DUMP.REFS ( -- , print references )

	cl-num-refs @ 0

	DO

		i 3 .r ."  : "

		i cl.ref[]

		dup s@ clr_OriginalXT >name id. ."  => "

		dup s@ clr_NewXT .

		." , size = "

		dup s@ clr_TotalSize . cr

		drop \ clref

	loop

;			

		

: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found }

	BEGIN

\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr

		indx cl-num-refs @ >=

		IF

			true

		ELSE

			indx cl.ref[] s@ clr_OriginalXT

\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr

			xt  =

			IF

				true

				dup -> flag

			ELSE

				false

				indx 1+ -> indx

			THEN

		THEN

	UNTIL

	indx flag

\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space  indx . flag . cr

;			



: CL.ADD.REF  { xt | clref -- , add referenced secondary to list }

	cl-references @ 0= abort" CL.ADD.REF - References not allocated!"

\

\ do we need to allocate more room?

	cl-num-refs @ cl-max-refs @ >=

	IF

		cl.resize.refs

	THEN

\

	cl-num-refs @ cl.ref[] -> clref    \ index into array

	xt clref s! clr_OriginalXT

	0 clref s! clr_NewXT

	xt xt>size clref s! clr_TotalSize

\

	1 cl-num-refs +!

;



\ ------------------------------------------------------------------



\ called by cl.traverse.secondary to compile each piece of secondary

: CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- ,  }

\ recompile to new location

\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr

	code-addr @ -> xt

\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr

	xt cl.dump.xt

	xt primitive?

	IF

		xt cl,

	ELSE

		xt CL.XT>REF_INDEX

		IF

			cl.ref[] -> clref

			clref s@ clr_NewXT

			dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT"

			cl,

		ELSE

			cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr

			abort

		THEN

	THEN

\

\ transfer any literal data

	code-addr codeaddr>datasize -> dsize

	dsize 0>

	IF

\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr

		code-addr cell+  cl-dict-ptr @ cl.dict[]  dsize  move

		cl-dict-ptr @ dsize + aligned cl-dict-ptr !

	THEN

\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr

;



: CL.RECOMPILE.REF { indx | clref codesize datasize -- }

\ all references have been resolved so recompile new secondary

	depth >r

	indx cl.ref[] -> clref

	cl-trace @

	IF

		cl.indent

		clref s@ clr_OriginalXT >name id. ."  recompiled at $"

		cl-dict-ptr @ .hex cr    \ new address

	THEN

	cl-dict-ptr @  clref s! clr_NewXT

\

\ traverse this secondary and compile into new dictionary

	clref s@ clr_OriginalXT

	>code ['] cl.recompile.secondary cl.traverse.secondary

\

\ determine whether there is any data following definition

	cl-dict-ptr @

	clref s@ clr_NewXT - -> codesize \ size of cloned code

	clref s@ clr_TotalSize \ total bytes

	codesize - -> datasize

	cl-trace @

	IF

		cl.indent

		." Move data: data size = " datasize . ." codesize = " codesize . cr

	THEN

\

\ copy any data that followed definition

	datasize 0>

	IF

		clref s@ clr_OriginalXT >code codesize +

		clref s@ clr_NewXT cl-dict-base @ + codesize +

		datasize move

		datasize cl-dict-ptr +!  \ allot space in clone dictionary

	THEN

	

	depth r> - abort" Stack depth change in CL.RECOMPILE.REF"

;



\ ------------------------------------------------------------------

: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list )

	depth 1- >r

\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr

	cl-ref-level @ cl-level-max @  MAX cl-level-max !

	@ ( get xt )

\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr

	dup cl.dump.xt

	dup primitive?

	IF

		drop

\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr

	ELSE

		dup CL.XT>REF_INDEX

		IF

			drop \ indx   \ already referenced once so ignore

			drop \ xt

		ELSE

			>r \ indx

			dup cl.add.ref

			>code 'self cl.traverse.secondary   \ use 'self for recursion!

			r> cl.recompile.ref    \ now that all refs resolved, recompile

		THEN

	THEN

\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr

	depth r> - abort" Stack depth change in CL.SCAN.SECONDARY"

;



: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list )

	dup primitive? abort" Cannot CLONE a PRIMITIVE word!"

	0 cl-ref-level !

	0 cl-level-max !

	0 cl-num-refs !

	dup cl.add.ref     \ word being cloned is top of ref list

	>code ['] cl.scan.secondary cl.traverse.secondary

	0 cl.recompile.ref

;



\ ------------------------------------------------------------------

: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict )

	cl.xt>ref_index 0= abort" not in cloned dictionary!"

	cl.ref[] s@ clr_NewXT

;

: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict )

	cl.xt>New_XT

	cl-dict-base @ +

;



: CL.REPORT ( -- )

	." Clone scan went " cl-level-max @ . ." levels deep." cr

	." Clone scanned " cl-num-refs @ . ." secondaries." cr

	." New dictionary size =  " cl-dict-ptr @ cl-dict-base @ - . cr

;





\ ------------------------------------------------------------------

: CL.TERM ( -- , cleanup )

	cl.free.refs

	cl.free.dict

;



: CL.INIT ( -- )

	cl.term

	0 cl-dict-size !

	['] first_colon cl-dict-ptr !

	cl.alloc.dict

	cl.alloc.refs

;



: 'CLONE ( xt -- , clone dictionary from this word )

	cl.init

	cl.clone.xt

	cl.report

	cl.dump.refs

	cl-test-mode @

	IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr

	THEN

;



: SAVE-CLONE  ( <filename> -- )

	bl word

	." Save cloned image in " dup count type

	drop ." SAVE-CLONE unimplemented!" \ %Q

;



: CLONE ( <name> -- )

	' 'clone

;



if.forgotten cl.term



\ ---------------------------------- TESTS --------------------





: TEST.CLONE ( -- )

	cl-test-mode @ not abort" CL-TEST-MODE not on!"

	0 cl.ref[] s@ clr_NewXT  execute

;





: TEST.CLONE.REAL ( -- )

	cl-test-mode @ abort" CL-TEST-MODE on!"

	code-base @

	0 cl.ref[] s@ clr_NewXT  \ get cloned execution token

	cl-dict-base @ code-base !

\ WARNING - code-base munged, only execute primitives or cloned code

	execute

	code-base !   \ restore code base for normal 

;





: TCL1

	34 dup +

;



: TCL2

	." Hello " tcl1  . cr

;



: TCL3

	4 0

	DO

		tcl2

		i . cr

		i 100 + . cr

	LOOP

;



create VAR1 567 ,

: TCL4

	345 var1 !

	." VAR1 = " var1 @ . cr

	var1 @ 345 -

	IF

		." TCL4 failed!" cr

	ELSE

		." TCL4 succeded! Yay!" cr

	THEN

;



\ do deferred words get cloned!

defer tcl.vector



: TCL.DOIT ." Hello Fred!" cr ;

' tcl.doit is tcl.vector



: TCL.DEFER

	12 . cr

	tcl.vector

	999 dup + . cr

;



trace-stack on

cl-test-mode on