urflibs/sinopt-whole-word/sinopt.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; superinstruction optimiser
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 (*
  11 optimiser process basic blocks. to do this, it records all branch
  12 instruction addresses, and all branch destinations. then it processes
  13 blocks between those things. if it needs to remove an instruction,
  14 it fixes all branches.
  15
  16 it also fixes branch to branch to the final destination.
  17
  18 as our words are small, we can simply build a map with block ids.
  19 each instruction is aligned at 4 bytes, which is very handy.
  20
  21 superinstructions are:
  22   constant
  23     replaced with literal (this is longer, but faster)
  24   variable
  25     replaced with a pfa-literal (this adds one more instruction, but is faster)
  26   variable @
  27     replaced with direct-@
  28   variable !
  29     replaced with direct-!
  30   value
  31     replaced with direct-@
  32   to value
  33     replaced with direct-!
  34 *)
  35
  36
  37 vocabulary (sinopt) (hidden)
  38 also-defs: (sinopt)
  39
  40 $define DEBUG-SINOPT-SYSTIME-STATS
  41 \ $define DEBUG-SINOPT-STATS
  42 \ $define DEBUG-SINOPT-OPTHIT
  43 \ $define DEBUG-SINOPT-VERBOSE
  44 \ $define DEBUG-SINOPT-BRANCHES
  45
  46
  47 0 value word-start
  48 0 value word-end
  49 0 value branch-map  ;; holds branch argument addrs; ends with 0
  50 0 value branch-count
  51 0 value block-map
  52 ;; statistics
  53 0 value instr-removed
  54 0 value optim-count
  55
  56 : align-dword  ( addr -- addr )
  57   3 + [ 3 bitnot ] imm-literal and
  58 ;
  59
  60 : branch-addr-addr  ( idx -- addr )
  61   dup 0 branch-count within " invalid index" ?not-error
  62   cells branch-map +
  63 ;
  64
  65 : branch-addr  ( idx -- addr )
  66   branch-addr-addr @
  67 ;
  68
  69 : block-info  ( addr -- info-addr )
  70   dup word-start word-end cell+ bounds? " invalid block address" ?not-error
  71   word-start - [ 3 bitnot ] imm-literal and block-map +
  72 ;
  73
  74 : block-info@  ( addr -- value )  block-info @ ;
  75 : block-info!  ( addr -- value )  block-info ! ;
  76
  77 ;; get VM instruction argument type
  78 : get-instruction-arg-type  ( addr -- atype )
  79   @ cfa->nfa @ compiler:(warg-mask) and
  80 ;
  81
  82 ;; skip VM instruction
  83 : skip-instruction  ( addr -- next-addr )
  84   dup cell+ swap get-instruction-arg-type
  85   case
  86     compiler:(warg-branch) of cell+ endof
  87     compiler:(warg-lit) of cell+ endof
  88     compiler:(warg-c4strz) of abort endof  ;; we don't have such words yet
  89     compiler:(warg-cfa) of cell+ endof
  90     compiler:(warg-pfa) of cell+ endof
  91     compiler:(warg-cblock) of abort endof  ;; we don't have such words yet
  92     compiler:(warg-vocid) of cell+ endof
  93     compiler:(warg-c1strz) of bcount + 1+ ( trailing zero ) align-dword endof
  94     compiler:(warg-dataskip) of count + align-dword endof
  95   endcase
  96 ;
  97
  98 ;; VM instruction length in bytes (including opcode)
  99 : instruction-length  ( addr -- len )
 100   dup skip-instruction swap -
 101 ;
 102
 103
 104 : good-branch-addr?  ( brdest -- )
 105   word-start word-end cell- bounds?
 106 ;
 107
 108 ;; this expects `word-start` and `word-end` to be set
 109 ;; collect all branches into branch map
 110 : collect-branches  ( -- )
 111   forth:(addr-temp-bit) 32768 + to branch-map
 112   0 to branch-count branch-map
 113   word-start begin dup word-end u< while  ( brdest addr )
 114     dup get-instruction-arg-type compiler:(warg-branch) = if
 115       2dup cell+ swap!  swap cell+ swap
 116       +1-to branch-count
 117     endif
 118   skip-instruction repeat drop
 119   0!  ;; final zero
 120 ;
 121
 122 : dump-branch-addrs  ( -- )
 123   branch-count for i branch-addr 0 .r cr endfor
 124 ;
 125
 126
 127 ;; mark all branch destinations with non-zero values in block map
 128 ;; this is used in block marker
 129 : temp-mark-brdests  ( -- )
 130   branch-count for
 131     i branch-addr compiler:(branch-addr@)
 132     dup good-branch-addr? if block-info 1! else drop endif
 133     ;; also, always mark instruction after the branch as a new block
 134     i branch-addr cell+ block-info 1!
 135   endfor
 136   ;; always mark first instruction, to bump block id
 137   word-start block-info 1!
 138 ;
 139
 140 ;; branches must be collected
 141 : mark-blocks  ( -- )
 142   branch-map branch-count 1+ cells + to block-map
 143   block-map word-end word-start - 4 +cells erase  ;; slightly too much, why not
 144   temp-mark-brdests
 145   $IF 0
 146     word-start begin dup word-end u< while
 147       dup 5 .r ." : " dup block-info@ 0 .r cr
 148     cell+ repeat
 149   $ENDIF
 150     \ ." word end: " word-end 0 u.r cr
 151   ;; start with block id #0, because first instruction is always marked as branch dest
 152   0 word-start begin dup word-end u< while  ( block-id addr )
 153     dup block-info@ if  ;; we have a branch to here, new block
 154       swap 1+ swap
 155     endif
 156      \ debug:dump-stack
 157      \ 2dup block-info!  ;; set block id
 158     dup instruction-length
 159     dup 3 and " invalid instruction length" ?error -- assertion
 160       \ ." ***len: " dup . cr
 161       \ dup . cr
 162     /cells for 2dup block-info! cell+ endfor
 163   repeat
 164   \ over . ." blocks found" cr
 165   2drop
 166 ;
 167
 168
 169 0 value (adj-staddr)
 170 0 value (adj-dbytes)
 171
 172 ;; adjust branches after staddr by delta *cells*
 173 ;; subtracts delta
 174 : adjust-branches  ( -- )
 175   (adj-staddr) ( staddr )
 176   branch-count for  ( staddr )
 177     i branch-addr compiler:(branch-addr@)
 178     dup good-branch-addr? if
 179       2dup u< if  ( staddr braddr )
 180         (adj-dbytes) - i branch-addr compiler:(branch-addr!)
 181       else drop endif
 182     else drop endif
 183   endfor drop
 184 ;
 185
 186 ;; subtracts delta
 187 : adjust-branch-addrs  ( -- )
 188   (adj-staddr) cell- ( staddr )
 189   branch-count for
 190     i branch-addr
 191     over u> if  ( staddr )
 192       (adj-dbytes) i branch-addr-addr -!
 193     endif
 194   endfor drop
 195 ;
 196
 197 : (move-instrs)  ( -- )
 198   (adj-staddr) dup (adj-dbytes) +  ;; from
 199   swap dup                         ;; to
 200   word-end swap - (adj-dbytes) -   ;; count
 201   move
 202 ;
 203
 204 : (move-blockids)  ( -- )
 205   (adj-staddr) block-info dup (adj-dbytes) +         ;; from
 206   swap                                               ;; to
 207   (adj-staddr) word-end swap - (adj-dbytes) - cell+  ;; count, and one more cell
 208   move
 209 ;
 210
 211 ;; remove `instcount` instructions at staddr
 212 : remove-instrs  ( staddr instcount -- )
 213   dup 0< " invalid instcount" ?error
 214   ?dup if
 215     cells to (adj-dbytes) to (adj-staddr)
 216     adjust-branches
 217     adjust-branch-addrs
 218     (move-instrs)
 219     (move-blockids)
 220     (adj-dbytes) -to word-end
 221   else drop endif
 222 ;
 223
 224
 225 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 226 ;; instruction pattern matcher
 227 ;;
 228 $include <sinopt-pats.f>
 229
 230 0 value prev-optim-count
 231 0 value first-dumped
 232
 233
 234 : .hex8  ( n -- )  base @ hex swap <# # # # # # # # # #> type base ! ;
 235
 236 : disasm-word-arg  ( addr -- )
 237   dup get-instruction-arg-type
 238   case
 239     compiler:(warg-branch) of cell+ @ space 0 u.r endof
 240     compiler:(warg-lit) of cell+ @ space 0 .r endof
 241     compiler:(warg-c4strz) of abort endof  ;; we don't have such words yet
 242     compiler:(warg-cfa) of cell+ @ space 0 u.r endof
 243     compiler:(warg-pfa) of cell+ @ space 0 u.r endof
 244     compiler:(warg-cblock) of abort endof  ;; we don't have such words yet
 245     compiler:(warg-vocid) of cell+ @ space u. endof
 246     compiler:(warg-c1strz) of drop ( dup bcount + align-dword ) endof
 247     compiler:(warg-dataskip) of drop ( dup @ + cell+ align-dword ) endof
 248     otherwise 2drop
 249   endcase
 250 ;
 251
 252 : disasm-word  ( -- )
 253   ." start: " word-start 0 .r cr
 254   ."   end: " word-end 0 .r cr
 255   word-start begin dup word-end u< while  ( addr )
 256     dup 6 u.r ." ("
 257     dup block-info@ 4 .r ." ): "
 258     dup @ .hex8 ." : "
 259     dup @ cfa->nfa id-count xtype
 260     dup disasm-word-arg
 261     cr
 262   skip-instruction repeat drop
 263 ;
 264
 265
 266 ;; guess current word end
 267 ;; we need this because some words may appear longer than they are
 268 ;; scanner remembers the furthest branch, and stops on "FORTH:(EXIT)"
 269
 270 0 value furthest-branch
 271
 272 : branch-back?  ( addr -- bool )
 273   dup @ ['] forth:(branch) = if
 274     \ cell+ dup compiler:(branch-addr@) swap cell+ ( braddr addr ) u<
 275     cell+ compiler:(branch-addr@) good-branch-addr? not
 276   else drop false endif
 277 ;
 278
 279 : stop-word?  ( addr -- bool )
 280   dup branch-back? ?dup ifnot
 281     @ case
 282       ['] forth:(exit) of true endof
 283       ['] forth:abort of true endof
 284       ['] forth:error of true endof
 285       ['] forth:fatal-error of true endof
 286       ['] forth:@execute-tail of true endof
 287       ['] forth:execute-tail of true endof
 288       ['] forth:bye of true endof
 289       \ ['] forth:nbye of true endof
 290     otherwise drop false endcase
 291   else nip
 292   endif
 293 ;
 294
 295 : guess-word-end  ( -- )
 296   word-start to furthest-branch  ;; nothing yet
 297   word-start begin dup word-end u< while  ( addr )
 298     dup get-instruction-arg-type
 299     compiler:(warg-branch) = if
 300       dup cell+ compiler:(branch-addr@)
 301       dup word-end u< if furthest-branch umax to furthest-branch else drop endif
 302         \ ." furthest branch: " furthest-branch 0 u.r cr
 303     endif
 304     dup stop-word? if
 305         \ ." possible EXIT: " dup 0 u.r cr
 306         \ ." fbranch: " furthest-branch 0 u.r cr
 307       dup furthest-branch u>= if
 308         skip-instruction to word-end exit
 309       endif
 310     endif
 311   skip-instruction repeat drop
 312 ;
 313
 314 : prepare-word-cfa  ( cfa -- )
 315   dup cfa->pfa to word-start
 316   cfa->wend to word-end
 317   0 to instr-removed
 318   0 to optim-count
 319     \ ." system word end at: " word-end 0 u.r cr
 320   guess-word-end
 321     \ ." guessed word end at: " word-end 0 u.r cr
 322 ;
 323
 324 : prepare-word:  ( -- )  \ name
 325   -find-required prepare-word-cfa
 326 ;
 327
 328 : optim-run  ( -- )
 329   collect-branches
 330   $IF $DEBUG-SINOPT-BRANCHES
 331   branch-count . ." branches found." cr
 332   $ENDIF
 333   mark-blocks
 334   \ ." === BEFORE ===" cr disasm-word
 335   $IF $DEBUG-SINOPT-BRANCHES
 336   dump-branch-addrs
 337   $ENDIF
 338   \ optim-cells+
 339   \ (cells_+) optim-match
 340
 341   0 to prev-optim-count
 342   false to first-dumped
 343   optim-matches
 344
 345   $IF $DEBUG-SINOPT-STATS
 346   optim-count if
 347     \ ." === AFTER ===" cr
 348     \ disasm-word
 349     \ dump-branch-addrs
 350     word-start pfa->nfa id-count ." OPTIMISED: WORD: " xtype cr
 351     2 spaces optim-count . ." optimisation(s) done, "
 352     2 spaces instr-removed . ." instruction(s) removed." cr
 353   endif
 354   $ENDIF
 355 ;
 356
 357 0 value words-optimised
 358 0 value optim-total
 359 0 value instr-total
 360
 361 : optim-vocab  ( vocid -- )
 362   0 to words-optimised
 363   0 to optim-total
 364   0 to instr-total
 365   voc-latest ( vocid )
 366   begin ?dup while
 367       \ ." word at: " dup 0 u.r cr
 368     dup
 369     lfa->nfa
 370     @
 371     compiler:(wflag-smudge) (* compiler:(wflag-hidden) or *) and
 372     ifnot
 373       dup lfa->cfa compiler:forth-word? if
 374         dup lfa->cfa compiler:cfa-scolon? ifnot
 375             \ dup lfa->nfa id-count ." <<< " xtype ."  >>>" cr
 376           dup lfa->cfa (sinopt):prepare-word-cfa
 377           (sinopt):optim-run
 378           (sinopt):optim-count if
 379             (sinopt):optim-count +to optim-total
 380             (sinopt):instr-removed +to instr-total
 381             +1-to words-optimised
 382           endif
 383         endif
 384       endif
 385     endif
 386       \ ." word at: " dup 0 u.r cr
 387   @ repeat
 388
 389   $IF $DEBUG-SINOPT-STATS
 390   words-optimised if
 391     ." words optimised: " words-optimised 0 .r cr
 392     ." optimisations done: " optim-total 0 .r cr
 393     ." instructions removed: " instr-total 0 .r cr
 394   endif
 395   $ENDIF
 396 ;
 397
 398
 399 $IF $DEBUG-SINOPT-VERBOSE
 400 : dbg-first-dump  ( optaddr -- )
 401   ." optim at " 0 u.r cr \ debug:dump-stack
 402   first-dumped ifnot
 403     true to first-dumped
 404     ." === BEFORE: " word-start pfa->cfa cfa->lfa lfa->nfa id-count xtype
 405     ."  ===" cr disasm-word
 406   endif
 407 ;
 408
 409 ' dbg-first-dump to first-dump
 410
 411
 412 : dbg-intermid-dump  ( match-tbl-addr -- )
 413   optim-count prev-optim-count <> if
 414     ." MATCH HIT: " @ pfa->nfa id-count xtype cr
 415     ." === intermid ===" cr
 416     disasm-word
 417     $IF $DEBUG-SINOPT-BRANCHES
 418     dump-branch-addrs
 419     $ENDIF
 420     optim-count to prev-optim-count
 421   else drop endif
 422 ;
 423
 424 ' dbg-intermid-dump to intermid-dump
 425 $ELSIF $DEBUG-SINOPT-OPTHIT
 426 : dbg-intermid-mthit  ( match-tbl-addr -- )
 427   optim-count prev-optim-count <> if
 428     ." ...MATCH HIT: " @ pfa->nfa id-count xtype cr
 429     optim-count to prev-optim-count
 430   else drop endif
 431 ;
 432
 433 ' dbg-intermid-mthit to intermid-dump
 434 $ENDIF
 435
 436
 437 : optimise-system  ( -- )
 438   $IF $DEBUG-SINOPT-SYSTIME-STATS
 439   get-msecs negate
 440   $ENDIF
 441   vocid: forth optim-vocab
 442   vocid: compiler optim-vocab
 443   vocid: string optim-vocab
 444   $IF $DEBUG-SINOPT-SYSTIME-STATS
 445   get-msecs + ." System optimisation time: " 0 .r cr
 446   $ENDIF
 447   \ vocid: linore optim-vocab
 448 ;
 449
 450
 451 : semicolon-optim  ( -- )
 452   \ ." optimiser invoked for " latest-nfa id-count xtype cr
 453   $IF $DEBUG-SINOPT-STATS
 454   get-msecs negate
 455   $ENDIF
 456   latest-cfa prepare-word-cfa optim-run
 457   $IF $DEBUG-SINOPT-STATS
 458   optim-count if
 459     get-msecs + ." word optimisation time: " 0 .r cr
 460   else drop endif
 461   $ENDIF
 462 ;
 463
 464 : activate  ( -- )
 465   ['] semicolon-optim to compiler:(;-optimise)
 466 ;
 467
 468 : deactivate  ( -- )
 469   ['] forth:noop to compiler:(;-optimise)
 470 ;
 471
 472
 473 prev-defs
 474
 475 \ debug:dump-stack