| 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 |
| 19 | anew task-clone.fth\r |
| 20 | decimal\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 |
| 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 |
| 47 | 10 cl-level-abort !\r |
| 48 | variable CL-REFERENCES \ pointer to cl.reference array\r |
| 49 | variable 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 |
| 53 | variable CL-TEST-MODE\r |
| 54 | \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 |
| 61 | 0 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 |
| 424 | if.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 |
| 463 | create 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 |
| 476 | defer 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 |
| 487 | trace-stack on\r |
| 488 | cl-test-mode on\r |
| 489 | \r |