| 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 | |