git.gag.com Git - debian/pforth/blob - fth/utils/clone.fth

   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