Commit | Line | Data |
---|---|---|
8e9db35f PB |
1 | \ @(#) clone.fth 97/12/10 1.1 |
2 | \ Clone for PForth | |
3 | \ | |
4 | \ Create the smallest dictionary required to run an application. | |
5 | \ | |
6 | \ Clone decompiles the Forth dictionary starting with the top | |
7 | \ word in the program. It then moves all referenced secondaries | |
8 | \ into a new dictionary. | |
9 | \ | |
10 | \ This work was inspired by the CLONE feature that Mike Haas wrote | |
11 | \ for JForth. Mike's CLONE disassembled 68000 machine code then | |
12 | \ reassembled it which is much more difficult. | |
13 | \ | |
14 | \ Copyright Phil Burk & 3DO 1994 | |
15 | \ | |
16 | \ O- trap custom 'C' calls | |
17 | \ O- investigate ALITERAL, XLITERAL, use XLITERAL in ['] | |
18 | ||
19 | anew task-clone.fth | |
20 | decimal | |
21 | ||
22 | \ move to 'C' | |
23 | : PRIMITIVE? ( xt -- flag , true if primitive ) | |
24 | ['] FIRST_COLON < | |
25 | ; | |
26 | ||
27 | : 'SELF ( -- xt , return xt of word being compiled ) | |
28 | ?comp | |
29 | latest name> | |
30 | [compile] literal | |
31 | ; immediate | |
32 | ||
33 | ||
34 | :struct CL.REFERENCE | |
35 | long clr_OriginalXT \ original XT of word | |
36 | long clr_NewXT \ corresponding XT in cloned dictionary | |
37 | long clr_TotalSize \ size including data in body | |
38 | ;struct | |
39 | ||
40 | variable CL-INITIAL-REFS \ initial number of refs to allocate | |
41 | 100 cl-initial-refs ! | |
42 | variable CL-REF-LEVEL \ level of threading while scanning | |
43 | variable CL-NUM-REFS \ number of secondaries referenced | |
44 | variable CL-MAX-REFS \ max number of secondaries allocated | |
45 | variable CL-LEVEL-MAX \ max level reached while scanning | |
46 | variable CL-LEVEL-ABORT \ max level before aborting | |
47 | 10 cl-level-abort ! | |
48 | variable CL-REFERENCES \ pointer to cl.reference array | |
49 | variable CL-TRACE \ print debug stuff if true | |
50 | ||
51 | \ Cloned dictionary builds in allocated memory but XTs are relative | |
52 | \ to normal code-base, if CL-TEST-MODE true. | |
53 | variable CL-TEST-MODE | |
54 | ||
55 | variable CL-INITIAL-DICT \ initial size of dict to allocate | |
56 | 20 1024 * cl-initial-dict ! | |
57 | variable CL-DICT-SIZE \ size of allocated cloned dictionary | |
58 | variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary | |
59 | variable CL-DICT-ALLOC \ pointer to allocated dictionary memory | |
60 | variable CL-DICT-PTR \ rel pointer index into cloned dictionary | |
61 | 0 cl-dict-base ! | |
62 | ||
63 | ||
64 | : CL.INDENT ( -- ) | |
65 | cl-ref-level @ 2* 2* spaces | |
66 | ; | |
67 | : CL.DUMP.NAME ( xt -- ) | |
68 | cl.indent | |
69 | >name id. cr | |
70 | ; | |
71 | ||
72 | : CL.DICT[] ( relptr -- addr ) | |
73 | cl-dict-base @ + | |
74 | ; | |
75 | ||
76 | : CL, ( cell -- , comma into clone dictionary ) | |
77 | cl-dict-ptr @ cl.dict[] ! | |
78 | cell cl-dict-ptr +! | |
79 | ; | |
80 | ||
81 | ||
82 | : CL.FREE.DICT ( -- , free dictionary we built into ) | |
83 | cl-dict-alloc @ ?dup | |
84 | IF | |
85 | free dup ?error | |
86 | 0 cl-dict-alloc ! | |
87 | THEN | |
88 | ; | |
89 | ||
90 | : CL.FREE.REFS ( -- , free dictionary we built into ) | |
91 | cl-references @ ?dup | |
92 | IF | |
93 | free dup ?error | |
94 | 0 cl-references ! | |
95 | THEN | |
96 | ; | |
97 | ||
98 | : CL.ALLOC.REFS ( -- , allocate references to track ) | |
99 | cl-initial-refs @ \ initial number of references | |
100 | dup cl-max-refs ! \ maximum allowed | |
101 | sizeof() cl.reference * | |
102 | allocate dup ?error | |
103 | cl-references ! | |
104 | ; | |
105 | ||
106 | : CL.RESIZE.REFS ( -- , allocate references to track ) | |
107 | cl-max-refs @ \ current number of references allocated | |
108 | 5 * 4 / dup cl-max-refs ! \ new maximum allowed | |
109 | \ cl.indent ." Resize # references to " dup . cr | |
110 | sizeof() cl.reference * | |
111 | cl-references @ swap resize dup ?error | |
112 | cl-references ! | |
113 | ; | |
114 | ||
115 | ||
116 | : CL.ALLOC.DICT ( -- , allocate dictionary to build into ) | |
117 | cl-initial-dict @ \ initial dictionary size | |
118 | dup cl-dict-size ! | |
119 | allocate dup ?error | |
120 | cl-dict-alloc ! | |
121 | \ | |
122 | \ kludge dictionary if testing | |
123 | cl-test-mode @ | |
124 | IF | |
125 | cl-dict-alloc @ code-base @ - cl-dict-ptr +! | |
126 | code-base @ cl-dict-base ! | |
127 | ELSE | |
128 | cl-dict-alloc @ cl-dict-base ! | |
129 | THEN | |
130 | ." CL.ALLOC.DICT" cr | |
131 | ." cl-dict-alloc = $" cl-dict-alloc @ .hex cr | |
132 | ." cl-dict-base = $" cl-dict-base @ .hex cr | |
133 | ." cl-dict-ptr = $" cl-dict-ptr @ .hex cr | |
134 | ; | |
135 | ||
136 | : CODEADDR>DATASIZE { code-addr -- datasize } | |
137 | \ Determine size of any literal data following execution token. | |
138 | \ Examples are text following (."), or branch offsets. | |
139 | code-addr @ | |
140 | CASE | |
141 | ['] (literal) OF cell ENDOF \ a number | |
142 | ['] 0branch OF cell ENDOF \ branch offset | |
143 | ['] branch OF cell ENDOF | |
144 | ['] (do) OF 0 ENDOF | |
145 | ['] (?do) OF cell ENDOF | |
146 | ['] (loop) OF cell ENDOF | |
147 | ['] (+loop) OF cell ENDOF | |
148 | ['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text | |
149 | ['] (s") OF code-addr cell+ c@ 1+ ENDOF | |
150 | ['] (c") OF code-addr cell+ c@ 1+ ENDOF | |
151 | 0 swap | |
152 | ENDCASE | |
153 | ; | |
154 | ||
155 | : XT>SIZE ( xt -- wordsize , including code and data ) | |
156 | dup >code | |
157 | swap >name | |
158 | dup latest = | |
159 | IF | |
160 | drop here | |
161 | ELSE | |
162 | dup c@ 1+ + aligned 8 + \ get next name | |
163 | name> >code \ where is next word | |
164 | THEN | |
165 | swap - | |
166 | ; | |
167 | ||
168 | \ ------------------------------------------------------------------ | |
169 | : CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize -- } | |
170 | \ scan secondary and pass each code-address to ca-process | |
171 | \ CA-PROCESS ( code-addr -- , required stack action for vector ) | |
172 | 1 cl-ref-level +! | |
173 | cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL" | |
174 | BEGIN | |
175 | code-addr @ -> xt | |
176 | \ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr | |
177 | code-addr codeaddr>datasize -> dsize \ any data after this? | |
178 | code-addr ca-process execute \ process it | |
179 | code-addr cell+ dsize + aligned -> code-addr \ skip past data | |
180 | \ !!! Bummer! EXIT called in middle of secondary will cause early stop. | |
181 | xt ['] EXIT = \ stop when we get to EXIT | |
182 | UNTIL | |
183 | -1 cl-ref-level +! | |
184 | ; | |
185 | ||
186 | \ ------------------------------------------------------------------ | |
187 | ||
188 | : CL.DUMP.XT ( xt -- ) | |
189 | cl-trace @ | |
190 | IF | |
191 | dup primitive? | |
192 | IF ." PRI: " | |
193 | ELSE ." SEC: " | |
194 | THEN | |
195 | cl.dump.name | |
196 | ELSE | |
197 | drop | |
198 | THEN | |
199 | ; | |
200 | ||
201 | \ ------------------------------------------------------------------ | |
202 | : CL.REF[] ( index -- clref ) | |
203 | sizeof() cl.reference * | |
204 | cl-references @ + | |
205 | ; | |
206 | ||
207 | : CL.DUMP.REFS ( -- , print references ) | |
208 | cl-num-refs @ 0 | |
209 | DO | |
210 | i 3 .r ." : " | |
211 | i cl.ref[] | |
212 | dup s@ clr_OriginalXT >name id. ." => " | |
213 | dup s@ clr_NewXT . | |
214 | ." , size = " | |
215 | dup s@ clr_TotalSize . cr | |
216 | drop \ clref | |
217 | loop | |
218 | ; | |
219 | ||
220 | : CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found } | |
221 | BEGIN | |
222 | \ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr | |
223 | indx cl-num-refs @ >= | |
224 | IF | |
225 | true | |
226 | ELSE | |
227 | indx cl.ref[] s@ clr_OriginalXT | |
228 | \ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr | |
229 | xt = | |
230 | IF | |
231 | true | |
232 | dup -> flag | |
233 | ELSE | |
234 | false | |
235 | indx 1+ -> indx | |
236 | THEN | |
237 | THEN | |
238 | UNTIL | |
239 | indx flag | |
240 | \ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr | |
241 | ; | |
242 | ||
243 | : CL.ADD.REF { xt | clref -- , add referenced secondary to list } | |
244 | cl-references @ 0= abort" CL.ADD.REF - References not allocated!" | |
245 | \ | |
246 | \ do we need to allocate more room? | |
247 | cl-num-refs @ cl-max-refs @ >= | |
248 | IF | |
249 | cl.resize.refs | |
250 | THEN | |
251 | \ | |
252 | cl-num-refs @ cl.ref[] -> clref \ index into array | |
253 | xt clref s! clr_OriginalXT | |
254 | 0 clref s! clr_NewXT | |
255 | xt xt>size clref s! clr_TotalSize | |
256 | \ | |
257 | 1 cl-num-refs +! | |
258 | ; | |
259 | ||
260 | \ ------------------------------------------------------------------ | |
261 | ||
262 | \ called by cl.traverse.secondary to compile each piece of secondary | |
263 | : CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- , } | |
264 | \ recompile to new location | |
265 | \ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr | |
266 | code-addr @ -> xt | |
267 | \ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr | |
268 | xt cl.dump.xt | |
269 | xt primitive? | |
270 | IF | |
271 | xt cl, | |
272 | ELSE | |
273 | xt CL.XT>REF_INDEX | |
274 | IF | |
275 | cl.ref[] -> clref | |
276 | clref s@ clr_NewXT | |
277 | dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT" | |
278 | cl, | |
279 | ELSE | |
280 | cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr | |
281 | abort | |
282 | THEN | |
283 | THEN | |
284 | \ | |
285 | \ transfer any literal data | |
286 | code-addr codeaddr>datasize -> dsize | |
287 | dsize 0> | |
288 | IF | |
289 | \ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr | |
290 | code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move | |
291 | cl-dict-ptr @ dsize + aligned cl-dict-ptr ! | |
292 | THEN | |
293 | \ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr | |
294 | ; | |
295 | ||
296 | : CL.RECOMPILE.REF { indx | clref codesize datasize -- } | |
297 | \ all references have been resolved so recompile new secondary | |
298 | depth >r | |
299 | indx cl.ref[] -> clref | |
300 | cl-trace @ | |
301 | IF | |
302 | cl.indent | |
303 | clref s@ clr_OriginalXT >name id. ." recompiled at $" | |
304 | cl-dict-ptr @ .hex cr \ new address | |
305 | THEN | |
306 | cl-dict-ptr @ clref s! clr_NewXT | |
307 | \ | |
308 | \ traverse this secondary and compile into new dictionary | |
309 | clref s@ clr_OriginalXT | |
310 | >code ['] cl.recompile.secondary cl.traverse.secondary | |
311 | \ | |
312 | \ determine whether there is any data following definition | |
313 | cl-dict-ptr @ | |
314 | clref s@ clr_NewXT - -> codesize \ size of cloned code | |
315 | clref s@ clr_TotalSize \ total bytes | |
316 | codesize - -> datasize | |
317 | cl-trace @ | |
318 | IF | |
319 | cl.indent | |
320 | ." Move data: data size = " datasize . ." codesize = " codesize . cr | |
321 | THEN | |
322 | \ | |
323 | \ copy any data that followed definition | |
324 | datasize 0> | |
325 | IF | |
326 | clref s@ clr_OriginalXT >code codesize + | |
327 | clref s@ clr_NewXT cl-dict-base @ + codesize + | |
328 | datasize move | |
329 | datasize cl-dict-ptr +! \ allot space in clone dictionary | |
330 | THEN | |
331 | ||
332 | depth r> - abort" Stack depth change in CL.RECOMPILE.REF" | |
333 | ; | |
334 | ||
335 | \ ------------------------------------------------------------------ | |
336 | : CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list ) | |
337 | depth 1- >r | |
338 | \ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr | |
339 | cl-ref-level @ cl-level-max @ MAX cl-level-max ! | |
340 | @ ( get xt ) | |
341 | \ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr | |
342 | dup cl.dump.xt | |
343 | dup primitive? | |
344 | IF | |
345 | drop | |
346 | \ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr | |
347 | ELSE | |
348 | dup CL.XT>REF_INDEX | |
349 | IF | |
350 | drop \ indx \ already referenced once so ignore | |
351 | drop \ xt | |
352 | ELSE | |
353 | >r \ indx | |
354 | dup cl.add.ref | |
355 | >code 'self cl.traverse.secondary \ use 'self for recursion! | |
356 | r> cl.recompile.ref \ now that all refs resolved, recompile | |
357 | THEN | |
358 | THEN | |
359 | \ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr | |
360 | depth r> - abort" Stack depth change in CL.SCAN.SECONDARY" | |
361 | ; | |
362 | ||
363 | : CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list ) | |
364 | dup primitive? abort" Cannot CLONE a PRIMITIVE word!" | |
365 | 0 cl-ref-level ! | |
366 | 0 cl-level-max ! | |
367 | 0 cl-num-refs ! | |
368 | dup cl.add.ref \ word being cloned is top of ref list | |
369 | >code ['] cl.scan.secondary cl.traverse.secondary | |
370 | 0 cl.recompile.ref | |
371 | ; | |
372 | ||
373 | \ ------------------------------------------------------------------ | |
374 | : CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict ) | |
375 | cl.xt>ref_index 0= abort" not in cloned dictionary!" | |
376 | cl.ref[] s@ clr_NewXT | |
377 | ; | |
378 | : CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict ) | |
379 | cl.xt>New_XT | |
380 | cl-dict-base @ + | |
381 | ; | |
382 | ||
383 | : CL.REPORT ( -- ) | |
384 | ." Clone scan went " cl-level-max @ . ." levels deep." cr | |
385 | ." Clone scanned " cl-num-refs @ . ." secondaries." cr | |
386 | ." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr | |
387 | ; | |
388 | ||
389 | ||
390 | \ ------------------------------------------------------------------ | |
391 | : CL.TERM ( -- , cleanup ) | |
392 | cl.free.refs | |
393 | cl.free.dict | |
394 | ; | |
395 | ||
396 | : CL.INIT ( -- ) | |
397 | cl.term | |
398 | 0 cl-dict-size ! | |
399 | ['] first_colon cl-dict-ptr ! | |
400 | cl.alloc.dict | |
401 | cl.alloc.refs | |
402 | ; | |
403 | ||
404 | : 'CLONE ( xt -- , clone dictionary from this word ) | |
405 | cl.init | |
406 | cl.clone.xt | |
407 | cl.report | |
408 | cl.dump.refs | |
409 | cl-test-mode @ | |
410 | IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr | |
411 | THEN | |
412 | ; | |
413 | ||
414 | : SAVE-CLONE ( <filename> -- ) | |
415 | bl word | |
416 | ." Save cloned image in " dup count type | |
417 | drop ." SAVE-CLONE unimplemented!" \ %Q | |
418 | ; | |
419 | ||
420 | : CLONE ( <name> -- ) | |
421 | ' 'clone | |
422 | ; | |
423 | ||
424 | if.forgotten cl.term | |
425 | ||
426 | \ ---------------------------------- TESTS -------------------- | |
427 | ||
428 | ||
429 | : TEST.CLONE ( -- ) | |
430 | cl-test-mode @ not abort" CL-TEST-MODE not on!" | |
431 | 0 cl.ref[] s@ clr_NewXT execute | |
432 | ; | |
433 | ||
434 | ||
435 | : TEST.CLONE.REAL ( -- ) | |
436 | cl-test-mode @ abort" CL-TEST-MODE on!" | |
437 | code-base @ | |
438 | 0 cl.ref[] s@ clr_NewXT \ get cloned execution token | |
439 | cl-dict-base @ code-base ! | |
440 | \ WARNING - code-base munged, only execute primitives or cloned code | |
441 | execute | |
442 | code-base ! \ restore code base for normal | |
443 | ; | |
444 | ||
445 | ||
446 | : TCL1 | |
447 | 34 dup + | |
448 | ; | |
449 | ||
450 | : TCL2 | |
451 | ." Hello " tcl1 . cr | |
452 | ; | |
453 | ||
454 | : TCL3 | |
455 | 4 0 | |
456 | DO | |
457 | tcl2 | |
458 | i . cr | |
459 | i 100 + . cr | |
460 | LOOP | |
461 | ; | |
462 | ||
463 | create VAR1 567 , | |
464 | : TCL4 | |
465 | 345 var1 ! | |
466 | ." VAR1 = " var1 @ . cr | |
467 | var1 @ 345 - | |
468 | IF | |
469 | ." TCL4 failed!" cr | |
470 | ELSE | |
471 | ." TCL4 succeded! Yay!" cr | |
472 | THEN | |
473 | ; | |
474 | ||
475 | \ do deferred words get cloned! | |
476 | defer tcl.vector | |
477 | ||
478 | : TCL.DOIT ." Hello Fred!" cr ; | |
479 | ' tcl.doit is tcl.vector | |
480 | ||
481 | : TCL.DEFER | |
482 | 12 . cr | |
483 | tcl.vector | |
484 | 999 dup + . cr | |
485 | ; | |
486 | ||
487 | trace-stack on | |
488 | cl-test-mode on | |
489 |