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

   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