projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial import.
[pforth] / fth / utils / clone.fth
CommitLineData
bb6b2dcd 1\ @(#) clone.fth 97/12/10 1.1\r
2\ Clone for PForth\r
3\\r
4\ Create the smallest dictionary required to run an application.\r
5\\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
9\\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
13\\r
14\ Copyright Phil Burk & 3DO 1994\r
15\\r
16\ O- trap custom 'C' calls\r
17\ O- investigate ALITERAL, XLITERAL, use XLITERAL in [']\r
18\r
19anew task-clone.fth\r
20decimal\r
21\r
22\ move to 'C'\r
23: PRIMITIVE? ( xt -- flag , true if primitive )\r
24 ['] FIRST_COLON <\r
25;\r
26\r
27: 'SELF ( -- xt , return xt of word being compiled )\r
28 ?comp\r
29 latest name>\r
30 [compile] literal\r
31; immediate\r
32\r
33\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
38;struct\r
39\r
40variable CL-INITIAL-REFS \ initial number of refs to allocate\r
41100 cl-initial-refs !\r
42variable CL-REF-LEVEL \ level of threading while scanning\r
43variable CL-NUM-REFS \ number of secondaries referenced\r
44variable CL-MAX-REFS \ max number of secondaries allocated\r
45variable CL-LEVEL-MAX \ max level reached while scanning\r
46variable CL-LEVEL-ABORT \ max level before aborting\r
4710 cl-level-abort !\r
48variable CL-REFERENCES \ pointer to cl.reference array\r
49variable CL-TRACE \ print debug stuff if true\r
50\r
51\ Cloned dictionary builds in allocated memory but XTs are relative\r
52\ to normal code-base, if CL-TEST-MODE true.\r
53variable CL-TEST-MODE\r
54 \r
55variable CL-INITIAL-DICT \ initial size of dict to allocate\r
5620 1024 * cl-initial-dict !\r
57variable CL-DICT-SIZE \ size of allocated cloned dictionary\r
58variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary\r
59variable CL-DICT-ALLOC \ pointer to allocated dictionary memory\r
60variable CL-DICT-PTR \ rel pointer index into cloned dictionary\r
610 cl-dict-base !\r
62\r
63 \r
64: CL.INDENT ( -- )\r
65 cl-ref-level @ 2* 2* spaces\r
66;\r
67: CL.DUMP.NAME ( xt -- )\r
68 cl.indent\r
69 >name id. cr\r
70;\r
71\r
72: CL.DICT[] ( relptr -- addr )\r
73 cl-dict-base @ +\r
74;\r
75\r
76: CL, ( cell -- , comma into clone dictionary )\r
77 cl-dict-ptr @ cl.dict[] !\r
78 cell cl-dict-ptr +!\r
79;\r
80\r
81\r
82: CL.FREE.DICT ( -- , free dictionary we built into )\r
83 cl-dict-alloc @ ?dup\r
84 IF\r
85 free dup ?error\r
86 0 cl-dict-alloc !\r
87 THEN\r
88;\r
89\r
90: CL.FREE.REFS ( -- , free dictionary we built into )\r
91 cl-references @ ?dup\r
92 IF\r
93 free dup ?error\r
94 0 cl-references !\r
95 THEN\r
96;\r
97\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
103 cl-references !\r
104;\r
105\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
112 cl-references !\r
113;\r
114\r
115\r
116: CL.ALLOC.DICT ( -- , allocate dictionary to build into )\r
117 cl-initial-dict @ \ initial dictionary size\r
118 dup cl-dict-size !\r
119 allocate dup ?error\r
120 cl-dict-alloc !\r
121\\r
122\ kludge dictionary if testing\r
123 cl-test-mode @\r
124 IF\r
125 cl-dict-alloc @ code-base @ - cl-dict-ptr +!\r
126 code-base @ cl-dict-base !\r
127 ELSE\r
128 cl-dict-alloc @ cl-dict-base !\r
129 THEN\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
134;\r
135\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
139 code-addr @\r
140 CASE\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
151 0 swap\r
152 ENDCASE\r
153;\r
154\r
155: XT>SIZE ( xt -- wordsize , including code and data )\r
156 dup >code\r
157 swap >name\r
158 dup latest =\r
159 IF\r
160 drop here\r
161 ELSE\r
162 dup c@ 1+ + aligned 8 + \ get next name\r
163 name> >code \ where is next word\r
164 THEN\r
165 swap -\r
166;\r
167\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
172 1 cl-ref-level +!\r
173 cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL"\r
174 BEGIN\r
175 code-addr @ -> xt\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
182 UNTIL\r
183 -1 cl-ref-level +!\r
184;\r
185\r
186\ ------------------------------------------------------------------\r
187\r
188: CL.DUMP.XT ( xt -- )\r
189 cl-trace @\r
190 IF\r
191 dup primitive?\r
192 IF ." PRI: "\r
193 ELSE ." SEC: "\r
194 THEN\r
195 cl.dump.name\r
196 ELSE\r
197 drop\r
198 THEN\r
199;\r
200\r
201\ ------------------------------------------------------------------\r
202: CL.REF[] ( index -- clref )\r
203 sizeof() cl.reference *\r
204 cl-references @ +\r
205;\r
206\r
207: CL.DUMP.REFS ( -- , print references )\r
208 cl-num-refs @ 0\r
209 DO\r
210 i 3 .r ." : "\r
211 i cl.ref[]\r
212 dup s@ clr_OriginalXT >name id. ." => "\r
213 dup s@ clr_NewXT .\r
214 ." , size = "\r
215 dup s@ clr_TotalSize . cr\r
216 drop \ clref\r
217 loop\r
218; \r
219 \r
220: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found }\r
221 BEGIN\r
222\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr\r
223 indx cl-num-refs @ >=\r
224 IF\r
225 true\r
226 ELSE\r
227 indx cl.ref[] s@ clr_OriginalXT\r
228\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr\r
229 xt =\r
230 IF\r
231 true\r
232 dup -> flag\r
233 ELSE\r
234 false\r
235 indx 1+ -> indx\r
236 THEN\r
237 THEN\r
238 UNTIL\r
239 indx flag\r
240\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr\r
241; \r
242\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
245\\r
246\ do we need to allocate more room?\r
247 cl-num-refs @ cl-max-refs @ >=\r
248 IF\r
249 cl.resize.refs\r
250 THEN\r
251\\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
256\\r
257 1 cl-num-refs +!\r
258;\r
259\r
260\ ------------------------------------------------------------------\r
261\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
266 code-addr @ -> xt\r
267\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr\r
268 xt cl.dump.xt\r
269 xt primitive?\r
270 IF\r
271 xt cl,\r
272 ELSE\r
273 xt CL.XT>REF_INDEX\r
274 IF\r
275 cl.ref[] -> clref\r
276 clref s@ clr_NewXT\r
277 dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT"\r
278 cl,\r
279 ELSE\r
280 cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr\r
281 abort\r
282 THEN\r
283 THEN\r
284\\r
285\ transfer any literal data\r
286 code-addr codeaddr>datasize -> dsize\r
287 dsize 0>\r
288 IF\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
292 THEN\r
293\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr\r
294;\r
295\r
296: CL.RECOMPILE.REF { indx | clref codesize datasize -- }\r
297\ all references have been resolved so recompile new secondary\r
298 depth >r\r
299 indx cl.ref[] -> clref\r
300 cl-trace @\r
301 IF\r
302 cl.indent\r
303 clref s@ clr_OriginalXT >name id. ." recompiled at $"\r
304 cl-dict-ptr @ .hex cr \ new address\r
305 THEN\r
306 cl-dict-ptr @ clref s! clr_NewXT\r
307\\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
311\\r
312\ determine whether there is any data following definition\r
313 cl-dict-ptr @\r
314 clref s@ clr_NewXT - -> codesize \ size of cloned code\r
315 clref s@ clr_TotalSize \ total bytes\r
316 codesize - -> datasize\r
317 cl-trace @\r
318 IF\r
319 cl.indent\r
320 ." Move data: data size = " datasize . ." codesize = " codesize . cr\r
321 THEN\r
322\\r
323\ copy any data that followed definition\r
324 datasize 0>\r
325 IF\r
326 clref s@ clr_OriginalXT >code codesize +\r
327 clref s@ clr_NewXT cl-dict-base @ + codesize +\r
328 datasize move\r
329 datasize cl-dict-ptr +! \ allot space in clone dictionary\r
330 THEN\r
331 \r
332 depth r> - abort" Stack depth change in CL.RECOMPILE.REF"\r
333;\r
334\r
335\ ------------------------------------------------------------------\r
336: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list )\r
337 depth 1- >r\r
338\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr\r
339 cl-ref-level @ cl-level-max @ MAX cl-level-max !\r
340 @ ( get xt )\r
341\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr\r
342 dup cl.dump.xt\r
343 dup primitive?\r
344 IF\r
345 drop\r
346\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr\r
347 ELSE\r
348 dup CL.XT>REF_INDEX\r
349 IF\r
350 drop \ indx \ already referenced once so ignore\r
351 drop \ xt\r
352 ELSE\r
353 >r \ indx\r
354 dup cl.add.ref\r
355 >code 'self cl.traverse.secondary \ use 'self for recursion!\r
356 r> cl.recompile.ref \ now that all refs resolved, recompile\r
357 THEN\r
358 THEN\r
359\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr\r
360 depth r> - abort" Stack depth change in CL.SCAN.SECONDARY"\r
361;\r
362\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
365 0 cl-ref-level !\r
366 0 cl-level-max !\r
367 0 cl-num-refs !\r
368 dup cl.add.ref \ word being cloned is top of ref list\r
369 >code ['] cl.scan.secondary cl.traverse.secondary\r
370 0 cl.recompile.ref\r
371;\r
372\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
377;\r
378: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict )\r
379 cl.xt>New_XT\r
380 cl-dict-base @ +\r
381;\r
382\r
383: CL.REPORT ( -- )\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
387;\r
388\r
389\r
390\ ------------------------------------------------------------------\r
391: CL.TERM ( -- , cleanup )\r
392 cl.free.refs\r
393 cl.free.dict\r
394;\r
395\r
396: CL.INIT ( -- )\r
397 cl.term\r
398 0 cl-dict-size !\r
399 ['] first_colon cl-dict-ptr !\r
400 cl.alloc.dict\r
401 cl.alloc.refs\r
402;\r
403\r
404: 'CLONE ( xt -- , clone dictionary from this word )\r
405 cl.init\r
406 cl.clone.xt\r
407 cl.report\r
408 cl.dump.refs\r
409 cl-test-mode @\r
410 IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr\r
411 THEN\r
412;\r
413\r
414: SAVE-CLONE ( <filename> -- )\r
415 bl word\r
416 ." Save cloned image in " dup count type\r
417 drop ." SAVE-CLONE unimplemented!" \ %Q\r
418;\r
419\r
420: CLONE ( <name> -- )\r
421 ' 'clone\r
422;\r
423\r
424if.forgotten cl.term\r
425\r
426\ ---------------------------------- TESTS --------------------\r
427\r
428\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
432;\r
433\r
434\r
435: TEST.CLONE.REAL ( -- )\r
436 cl-test-mode @ abort" CL-TEST-MODE on!"\r
437 code-base @\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
441 execute\r
442 code-base ! \ restore code base for normal \r
443;\r
444\r
445\r
446: TCL1\r
447 34 dup +\r
448;\r
449\r
450: TCL2\r
451 ." Hello " tcl1 . cr\r
452;\r
453\r
454: TCL3\r
455 4 0\r
456 DO\r
457 tcl2\r
458 i . cr\r
459 i 100 + . cr\r
460 LOOP\r
461;\r
462\r
463create VAR1 567 ,\r
464: TCL4\r
465 345 var1 !\r
466 ." VAR1 = " var1 @ . cr\r
467 var1 @ 345 -\r
468 IF\r
469 ." TCL4 failed!" cr\r
470 ELSE\r
471 ." TCL4 succeded! Yay!" cr\r
472 THEN\r
473;\r
474\r
475\ do deferred words get cloned!\r
476defer tcl.vector\r
477\r
478: TCL.DOIT ." Hello Fred!" cr ;\r
479' tcl.doit is tcl.vector\r
480\r
481: TCL.DEFER\r
482 12 . cr\r
483 tcl.vector\r
484 999 dup + . cr\r
485;\r
486\r
487trace-stack on\r
488cl-test-mode on\r
489\r
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.