1 \ @(#) clone.fth 97/12/10 1.1
\r
4 \ Create the smallest dictionary required to run an application.
\r
6 \ Clone decompiles the Forth dictionary starting with the top
\r
7 \ word in the program. It then moves all referenced secondaries
\r
8 \ into a new dictionary.
\r
10 \ This work was inspired by the CLONE feature that Mike Haas wrote
\r
11 \ for JForth. Mike's CLONE disassembled 68000 machine code then
\r
12 \ reassembled it which is much more difficult.
\r
14 \ Copyright Phil Burk & 3DO 1994
\r
16 \ O- trap custom 'C' calls
\r
17 \ O- investigate ALITERAL, XLITERAL, use XLITERAL in [']
\r
23 : PRIMITIVE? ( xt -- flag , true if primitive )
\r
27 : 'SELF ( -- xt , return xt of word being compiled )
\r
34 :struct CL.REFERENCE
\r
35 long clr_OriginalXT \ original XT of word
\r
36 long clr_NewXT \ corresponding XT in cloned dictionary
\r
37 long clr_TotalSize \ size including data in body
\r
40 variable CL-INITIAL-REFS \ initial number of refs to allocate
\r
41 100 cl-initial-refs !
\r
42 variable CL-REF-LEVEL \ level of threading while scanning
\r
43 variable CL-NUM-REFS \ number of secondaries referenced
\r
44 variable CL-MAX-REFS \ max number of secondaries allocated
\r
45 variable CL-LEVEL-MAX \ max level reached while scanning
\r
46 variable CL-LEVEL-ABORT \ max level before aborting
\r
48 variable CL-REFERENCES \ pointer to cl.reference array
\r
49 variable CL-TRACE \ print debug stuff if true
\r
51 \ Cloned dictionary builds in allocated memory but XTs are relative
\r
52 \ to normal code-base, if CL-TEST-MODE true.
\r
53 variable CL-TEST-MODE
\r
55 variable CL-INITIAL-DICT \ initial size of dict to allocate
\r
56 20 1024 * cl-initial-dict !
\r
57 variable CL-DICT-SIZE \ size of allocated cloned dictionary
\r
58 variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary
\r
59 variable CL-DICT-ALLOC \ pointer to allocated dictionary memory
\r
60 variable CL-DICT-PTR \ rel pointer index into cloned dictionary
\r
65 cl-ref-level @ 2* 2* spaces
\r
67 : CL.DUMP.NAME ( xt -- )
\r
72 : CL.DICT[] ( relptr -- addr )
\r
76 : CL, ( cell -- , comma into clone dictionary )
\r
77 cl-dict-ptr @ cl.dict[] !
\r
82 : CL.FREE.DICT ( -- , free dictionary we built into )
\r
83 cl-dict-alloc @ ?dup
\r
90 : CL.FREE.REFS ( -- , free dictionary we built into )
\r
91 cl-references @ ?dup
\r
98 : CL.ALLOC.REFS ( -- , allocate references to track )
\r
99 cl-initial-refs @ \ initial number of references
\r
100 dup cl-max-refs ! \ maximum allowed
\r
101 sizeof() cl.reference *
\r
102 allocate dup ?error
\r
106 : CL.RESIZE.REFS ( -- , allocate references to track )
\r
107 cl-max-refs @ \ current number of references allocated
\r
108 5 * 4 / dup cl-max-refs ! \ new maximum allowed
\r
109 \ cl.indent ." Resize # references to " dup . cr
\r
110 sizeof() cl.reference *
\r
111 cl-references @ swap resize dup ?error
\r
116 : CL.ALLOC.DICT ( -- , allocate dictionary to build into )
\r
117 cl-initial-dict @ \ initial dictionary size
\r
119 allocate dup ?error
\r
122 \ kludge dictionary if testing
\r
125 cl-dict-alloc @ code-base @ - cl-dict-ptr +!
\r
126 code-base @ cl-dict-base !
\r
128 cl-dict-alloc @ cl-dict-base !
\r
130 ." CL.ALLOC.DICT" cr
\r
131 ." cl-dict-alloc = $" cl-dict-alloc @ .hex cr
\r
132 ." cl-dict-base = $" cl-dict-base @ .hex cr
\r
133 ." cl-dict-ptr = $" cl-dict-ptr @ .hex cr
\r
136 : CODEADDR>DATASIZE { code-addr -- datasize }
\r
137 \ Determine size of any literal data following execution token.
\r
138 \ Examples are text following (."), or branch offsets.
\r
141 ['] (literal) OF cell ENDOF \ a number
\r
142 ['] 0branch OF cell ENDOF \ branch offset
\r
143 ['] branch OF cell ENDOF
\r
144 ['] (do) OF 0 ENDOF
\r
145 ['] (?do) OF cell ENDOF
\r
146 ['] (loop) OF cell ENDOF
\r
147 ['] (+loop) OF cell ENDOF
\r
148 ['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text
\r
149 ['] (s") OF code-addr cell+ c@ 1+ ENDOF
\r
150 ['] (c") OF code-addr cell+ c@ 1+ ENDOF
\r
155 : XT>SIZE ( xt -- wordsize , including code and data )
\r
162 dup c@ 1+ + aligned 8 + \ get next name
\r
163 name> >code \ where is next word
\r
168 \ ------------------------------------------------------------------
\r
169 : CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize -- }
\r
170 \ scan secondary and pass each code-address to ca-process
\r
171 \ CA-PROCESS ( code-addr -- , required stack action for vector )
\r
173 cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL"
\r
176 \ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr
\r
177 code-addr codeaddr>datasize -> dsize \ any data after this?
\r
178 code-addr ca-process execute \ process it
\r
179 code-addr cell+ dsize + aligned -> code-addr \ skip past data
\r
180 \ !!! Bummer! EXIT called in middle of secondary will cause early stop.
\r
181 xt ['] EXIT = \ stop when we get to EXIT
\r
186 \ ------------------------------------------------------------------
\r
188 : CL.DUMP.XT ( xt -- )
\r
201 \ ------------------------------------------------------------------
\r
202 : CL.REF[] ( index -- clref )
\r
203 sizeof() cl.reference *
\r
207 : CL.DUMP.REFS ( -- , print references )
\r
212 dup s@ clr_OriginalXT >name id. ." => "
\r
215 dup s@ clr_TotalSize . cr
\r
220 : CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found }
\r
222 \ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr
\r
223 indx cl-num-refs @ >=
\r
227 indx cl.ref[] s@ clr_OriginalXT
\r
228 \ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr
\r
240 \ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr
\r
243 : CL.ADD.REF { xt | clref -- , add referenced secondary to list }
\r
244 cl-references @ 0= abort" CL.ADD.REF - References not allocated!"
\r
246 \ do we need to allocate more room?
\r
247 cl-num-refs @ cl-max-refs @ >=
\r
252 cl-num-refs @ cl.ref[] -> clref \ index into array
\r
253 xt clref s! clr_OriginalXT
\r
254 0 clref s! clr_NewXT
\r
255 xt xt>size clref s! clr_TotalSize
\r
260 \ ------------------------------------------------------------------
\r
262 \ called by cl.traverse.secondary to compile each piece of secondary
\r
263 : CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- , }
\r
264 \ recompile to new location
\r
265 \ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr
\r
267 \ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr
\r
277 dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT"
\r
280 cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr
\r
285 \ transfer any literal data
\r
286 code-addr codeaddr>datasize -> dsize
\r
289 \ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr
\r
290 code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move
\r
291 cl-dict-ptr @ dsize + aligned cl-dict-ptr !
\r
293 \ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr
\r
296 : CL.RECOMPILE.REF { indx | clref codesize datasize -- }
\r
297 \ all references have been resolved so recompile new secondary
\r
299 indx cl.ref[] -> clref
\r
303 clref s@ clr_OriginalXT >name id. ." recompiled at $"
\r
304 cl-dict-ptr @ .hex cr \ new address
\r
306 cl-dict-ptr @ clref s! clr_NewXT
\r
308 \ traverse this secondary and compile into new dictionary
\r
309 clref s@ clr_OriginalXT
\r
310 >code ['] cl.recompile.secondary cl.traverse.secondary
\r
312 \ determine whether there is any data following definition
\r
314 clref s@ clr_NewXT - -> codesize \ size of cloned code
\r
315 clref s@ clr_TotalSize \ total bytes
\r
316 codesize - -> datasize
\r
320 ." Move data: data size = " datasize . ." codesize = " codesize . cr
\r
323 \ copy any data that followed definition
\r
326 clref s@ clr_OriginalXT >code codesize +
\r
327 clref s@ clr_NewXT cl-dict-base @ + codesize +
\r
329 datasize cl-dict-ptr +! \ allot space in clone dictionary
\r
332 depth r> - abort" Stack depth change in CL.RECOMPILE.REF"
\r
335 \ ------------------------------------------------------------------
\r
336 : CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list )
\r
338 \ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr
\r
339 cl-ref-level @ cl-level-max @ MAX cl-level-max !
\r
341 \ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr
\r
346 \ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr
\r
348 dup CL.XT>REF_INDEX
\r
350 drop \ indx \ already referenced once so ignore
\r
355 >code 'self cl.traverse.secondary \ use 'self for recursion!
\r
356 r> cl.recompile.ref \ now that all refs resolved, recompile
\r
359 \ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr
\r
360 depth r> - abort" Stack depth change in CL.SCAN.SECONDARY"
\r
363 : CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list )
\r
364 dup primitive? abort" Cannot CLONE a PRIMITIVE word!"
\r
368 dup cl.add.ref \ word being cloned is top of ref list
\r
369 >code ['] cl.scan.secondary cl.traverse.secondary
\r
373 \ ------------------------------------------------------------------
\r
374 : CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict )
\r
375 cl.xt>ref_index 0= abort" not in cloned dictionary!"
\r
376 cl.ref[] s@ clr_NewXT
\r
378 : CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict )
\r
384 ." Clone scan went " cl-level-max @ . ." levels deep." cr
\r
385 ." Clone scanned " cl-num-refs @ . ." secondaries." cr
\r
386 ." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr
\r
390 \ ------------------------------------------------------------------
\r
391 : CL.TERM ( -- , cleanup )
\r
399 ['] first_colon cl-dict-ptr !
\r
404 : 'CLONE ( xt -- , clone dictionary from this word )
\r
410 IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr
\r
414 : SAVE-CLONE ( <filename> -- )
\r
416 ." Save cloned image in " dup count type
\r
417 drop ." SAVE-CLONE unimplemented!" \ %Q
\r
420 : CLONE ( <name> -- )
\r
424 if.forgotten cl.term
\r
426 \ ---------------------------------- TESTS --------------------
\r
429 : TEST.CLONE ( -- )
\r
430 cl-test-mode @ not abort" CL-TEST-MODE not on!"
\r
431 0 cl.ref[] s@ clr_NewXT execute
\r
435 : TEST.CLONE.REAL ( -- )
\r
436 cl-test-mode @ abort" CL-TEST-MODE on!"
\r
438 0 cl.ref[] s@ clr_NewXT \ get cloned execution token
\r
439 cl-dict-base @ code-base !
\r
440 \ WARNING - code-base munged, only execute primitives or cloned code
\r
442 code-base ! \ restore code base for normal
\r
451 ." Hello " tcl1 . cr
\r
466 ." VAR1 = " var1 @ . cr
\r
469 ." TCL4 failed!" cr
\r
471 ." TCL4 succeded! Yay!" cr
\r
475 \ do deferred words get cloned!
\r
478 : TCL.DOIT ." Hello Fred!" cr ;
\r
479 ' tcl.doit is tcl.vector
\r