\ @(#) 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