git.gag.com Git - debian/pforth/blob - 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