urflibs/sinopt-peephole/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 ;; simple superinstruction optimiser
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 (*
  11 this is very simple peephole optimiser. it is called by "INTERPRET" after
  12 compiling a literal or a word. also, compiler words which create branches
  13 take care of resetting the optimiser, to avoid optimising things like
  14 "7 begin and" to "(lit-and)" (to avoid breaking branches).
  15
  16 compiler words to mark/resolve branches are aware of the optimiser. you
  17 should use those words in your code instead of direct poking.
  18
  19 we are using the ring buffer to record recent commands, because it is cheap.
  20 reseting the buffer is cheap too: just write "0" to the current ring buffer
  21 entry. it works because all optimisers check buffer validity first.
  22 *)
  23
  24
  25 vocabulary (sinopt-peephole) (hidden)
  26 also-defs: (sinopt-peephole)
  27
  28
  29 \ $DEFINE DEBUG-SINOPT-DUMP-PUSHES
  30
  31 \ $DEFINE DEBUG-SINOPT
  32
  33 $DEFINE DEBUG-SINOPT-SIMPLE-BITWISE
  34 $DEFINE DEBUG-SINOPT-SIMPLE-SWAP-INC-SWAP
  35 $DEFINE DEBUG-SINOPT-SIMPLE-INC-DEC
  36 $DEFINE DEBUG-SINOPT-SIMPLE-CELLS
  37 $DEFINE DEBUG-SINOPT-SIMPLE-CELLS-INC-DEC
  38 $DEFINE DEBUG-SINOPT-SIMPLE-DIRECT-POKES
  39 $DEFINE DEBUG-SINOPT-SIMPLE-DIRECT-POKES-INCS
  40 $DEFINE DEBUG-SINOPT-SIMPLE-DIRECT-POKE-INCS
  41 $DEFINE DEBUG-SINOPT-SIMPLE-SHIFTS
  42 $DEFINE DEBUG-SINOPT-SIMPLE-MULS
  43 $DEFINE DEBUG-SINOPT-SIMPLE-DIVS
  44 $DEFINE DEBUG-SINOPT-VARS
  45 $DEFINE DEBUG-SINOPT-STACK-OPS
  46
  47
  48 false value enabled?
  49
  50
  51 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52 ;; utils
  53 ;;
  54
  55 ;; last compiled word address
  56 : prev-cw   ( -- addr )  postpone here postpone 8- ; immediate
  57 : prev-lit-cw   ( -- addr )  postpone here postpone 12 postpone - ; immediate
  58 \ debug:decompile prev-lit-cw
  59
  60 : last-cw   ( -- addr )  postpone here postpone cell- ; immediate
  61
  62 : 2cells  ( n -- n-8 )  compiler:?comp [ 2 cells ] imm-literal literal ; immediate
  63 : 3cells  ( n -- n-8 )  compiler:?comp [ 3 cells ] imm-literal literal ; immediate
  64 : 2:-cells  ( n -- n-8 )  postpone 8- ; immediate
  65 : 3:-cells  ( n -- n-8 )  compiler:?comp [ 3 cells ] imm-literal literal postpone - ; immediate
  66
  67 ;; for clarity
  68 : compile!  ( val addr -- )  compiler:?comp compile ! ; immediate
  69
  70
  71 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72 ;; ring buffer with instruction addresses
  73 ;;
  74
  75 ;; ring buffer for 8 instructions.
  76 ;; WARNING! should be power of 2!
  77 8 constant buffer-size
  78 buffer-size cells 1- constant buffer-pos-mask
  79
  80 create buffer buffer-size cells allot create;
  81 buffer buffer-size cells erase
  82
  83 ;; positions are byte offsets!
  84 0 value buffer-lit-pos  ;; position of the last compiled (LIT); -1 means "not there"
  85 0 value buffer-tail     ;; last used buffer entry
  86
  87 : buffer-reset  ( -- )
  88   -1 to buffer-lit-pos
  89   ;; put zeroes to the last ring buffer element.
  90   ;; this way any check will definitely fail.
  91   buffer-tail buffer + 0!
  92 ;
  93
  94 ;; rollback one instruction
  95 : buffer-rollback-one  ( -- )  buffer-tail cell- buffer-pos-mask and to buffer-tail ;
  96
  97 : buffer+@  ( ofs -- )  buffer + @ ;
  98
  99 : buffer-tail@  ( -- )  buffer-tail buffer+@ ;
 100 : buffer-prev@  ( -- )  buffer-tail cell- buffer-pos-mask and buffer+@ ;
 101 : buffer-third@ ( -- )  buffer-tail 8- buffer-pos-mask and buffer+@ ;
 102
 103 : (put-addr)  ( addr newofs -- )  buffer + ! ;
 104 : (advance-buf)  ( -- newofs ) buffer-tail cell+ buffer-pos-mask and dup to buffer-tail ;
 105 : lit-reset  ( -- )  -1 to buffer-lit-pos ;
 106
 107 ;; called when new literal compiled
 108 : push-literal  ( addr -- )
 109   (advance-buf) dup to buffer-lit-pos (put-addr)
 110   $IF $DEBUG-SINOPT-DUMP-PUSHES
 111     ." 3LIT(" buffer-tail 0 u.r ." ): " buffer-tail@ 0 u.r space buffer-prev@ 0 u.r space buffer-third@ 0 u.r cr
 112   $ENDIF
 113 ;
 114
 115 ;; push last compiled word address to the ring buffer.
 116 ;; this will reset "lit-pos" if necessary.
 117 : push-last-instr  ( addr -- )
 118   (advance-buf) dup buffer-lit-pos = if lit-reset endif (put-addr)
 119   $IF $DEBUG-SINOPT-DUMP-PUSHES
 120     ." 3BUF(" buffer-tail 0 u.r ." ): " buffer-tail@ 0 u.r space buffer-prev@ 0 u.r space buffer-third@ 0 u.r cr
 121   $ENDIF
 122 ;
 123
 124 ;; set by checker, for speed
 125 0 value lit-instr-addr
 126 0 value lit-arg-addr
 127 0 value lit-value
 128 0 value last-instr-addr
 129 0 value last-instr-cfa
 130
 131 : prepare-globals  ( lit-instr-addr last-instr-addr -- )
 132   dup to last-instr-addr @ to last-instr-cfa
 133   dup to lit-instr-addr cell+ dup to lit-arg-addr @ to lit-value
 134 ;
 135
 136 ;; check if we have a valid "(LIT)" and instructions without arguments.
 137 ;; they must be two latest instructions at HERE.
 138 ;; explicit "exit" used for slight speedup. sorry.
 139 : lit-and-instr?  ( -- bool )
 140   buffer-lit-pos dup -if drop false exit endif
 141   buffer+@ dup prev-lit-cw = ifnot drop false exit endif  ( lit-instr-addr )
 142   buffer-tail@ dup last-cw = ifnot 2drop false exit endif   ( lit-instr-addr last-instr-addr )
 143   prepare-globals true
 144 ;
 145
 146 : dp!  ( addr -- ) forth:(dp-here) @ ! ;
 147
 148 ;; replace last "(LIT)" value, remove other instructions.
 149 : set-lit-value-only  ( value -- )
 150   lit-arg-addr !
 151   buffer-lit-pos to buffer-tail
 152   lit-arg-addr cell+ dp!
 153 ;
 154
 155 ;; replace last "(LIT)" value, replace last instruction.
 156 : set-lit-value-instr  ( value cfa -- )
 157   ;; fix those, because the only place where this is used is "+cells" optimisation,
 158   ;; and that optimisation rely on further optimisers.
 159   over to lit-value
 160   dup to last-instr-cfa
 161   last-instr-addr compile!
 162   lit-arg-addr !
 163 ;
 164
 165 ;; replace last "(LIT)" with lit-arg instruction.
 166 ;; remove last instruction.
 167 : replace-lit-with-arginstr  ( cfa -- )
 168   lit-instr-addr compile!
 169   last-instr-addr dp! lit-reset buffer-rollback-one
 170 ;
 171
 172 ;; replace last "(LIT)" with simple instruction without operands.
 173 : replace-lit  ( cfa -- )
 174   $IF 0
 175     ." REPLACE LIT! "
 176     buffer-tail@ 0 u.r space buffer-prev@ 0 u.r space buffer-third@ 0 u.r
 177     4 spaces buffer-lit-pos 0 u.r space buffer-tail 0 u.r
 178     cr
 179   $ENDIF
 180   lit-instr-addr compile!
 181   buffer-lit-pos to buffer-tail lit-reset
 182   lit-arg-addr dp!
 183 ;
 184
 185 ;; remove last "(LIT)", and everything after it.
 186 : remove-lit  ( cfa -- )
 187   lit-instr-addr dp!
 188   buffer-lit-pos cell- buffer-pos-mask and to buffer-tail lit-reset
 189 ;
 190
 191
 192 ;; check if we have a valid "(LIT)" and instruction with one argument.
 193 ;; they must be two latest instructions at HERE.
 194 ;; explicit "exit" used for slight speedup. sorry.
 195 : lit-and-one-arg?  ( -- bool )
 196   buffer-lit-pos dup -if drop false exit endif
 197   buffer+@ dup here [ 4 cells ] imm-literal - = ifnot drop false exit endif  ( lit-instr-addr )
 198   buffer-tail@ dup here 8- = ifnot 2drop false exit endif   ( lit-instr-addr last-instr-addr )
 199   prepare-globals true
 200 ;
 201
 202 ;; remove last "(LIT)". set direct poke instead.
 203 ;; note that "(LIT)" must be followed by direct poke.
 204 : remove-lit-set-direct  ( cfa -- )
 205   lit-instr-addr compile!
 206   last-instr-addr cell+ @ lit-arg-addr !  ;; copy argument
 207   last-instr-addr dp! lit-reset buffer-rollback-one
 208 ;
 209
 210
 211 0 value prev-instr-addr
 212 0 value t/f-value
 213
 214 ;; check if we have a valid "(LIT)" and instruction with one argument.
 215 ;; they must be two latest instructions at HERE.
 216 ;; explicit "exit" used for slight speedup. sorry.
 217 : true/false-and-one-arg?  ( -- bool )
 218   buffer-tail@ dup here 8- = ifnot drop false exit endif   ( last-instr-addr )
 219   buffer-prev@ dup here [ 3 cells ] imm-literal - = ifnot 2drop false exit endif  ( lia pia )
 220   dup @ case
 221     ['] true of true to t/f-value endof
 222     ['] false of false to t/f-value endof
 223   otherwise drop 2drop false exit endcase
 224   to prev-instr-addr
 225   dup to last-instr-addr @ to last-instr-cfa true
 226 ;
 227
 228 ;; replace previous instruction with direct poke.
 229 ;; last instruction must be a direct poke.
 230 : replace-prev-with-direct  ( cfa -- )
 231   prev-instr-addr compile!
 232   ;; copy argument
 233   last-instr-addr cell+ @ prev-instr-addr cell+ dup cell+ dp! !
 234   \ buffer-reset  ;; don't bother
 235   buffer-rollback-one
 236 ;
 237
 238 : remove-prev-and-direct  ( -- )
 239   prev-instr-addr dp!
 240   buffer-reset  ;; don't bother
 241 ;
 242
 243
 244 0 value v/c-value   ;; var/const value
 245
 246 ;; check if we have a variable/constant as previous instruction,
 247 ;; folowed by simple instruction.
 248 ;; they must be two latest instructions at HERE.
 249 : prev-var/const-and-instr?  ( -- bool )
 250   buffer-tail@ dup here 4- = ifnot drop false exit endif   ( last-instr-addr )
 251   buffer-prev@ dup here 8- = ifnot 2drop false exit endif  ( lia pia )
 252   dup @ dup compiler:variable-word? if drop false
 253   else compiler:constant-word? if true
 254   else 2drop false exit endif endif
 255   over to prev-instr-addr
 256   swap @ cfa->pfa swap if @ endif to v/c-value
 257   dup to last-instr-addr @ to last-instr-cfa true
 258 ;
 259
 260 ;; use v/c-value as address
 261 : replace-v/c-with-direct  ( cfa -- )
 262   prev-instr-addr compile!
 263   prev-instr-addr cell+ v/c-value over ! cell+ dp!
 264   buffer-rollback-one
 265 ;
 266
 267
 268 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 269 ;; debug
 270 ;;
 271 $IF $DEBUG-SINOPT
 272 : .curr-word   ( -- )  latest-nfa id-count xtype ;
 273 : .last-instr  ( -- )  last-instr-cfa cfa->nfa id-count xtype ;
 274 : .optim  ( addr count -- )  ." ***SINOPT(" here 0 u.r ." ) at `" .curr-word ." `:" type ." : " ;
 275 $ENDIF
 276
 277
 278 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 279 ;; {lit} <and|or|xor|~and>  -->  (lit-...)
 280 ;;
 281
 282 : optimise-direct-bitwise  ( -- done? )
 283   last-instr-cfa case
 284     ['] forth:and of
 285         lit-value dup 0xff = if
 286           $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-BITWISE
 287             " direct-bitwise" .optim ." LO-BYTE" cr
 288           $ENDIF
 289           drop ['] forth:lo-byte replace-lit true exit
 290         endif
 291         0xffff = if
 292           $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-BITWISE
 293             " direct-bitwise" .optim ." LO-WORD" cr
 294           $ENDIF
 295           ['] forth:lo-word replace-lit true exit
 296         endif
 297         ['] forth:(lit-and)
 298       endof
 299     ['] forth:~and of ['] forth:(lit-~and) endof
 300     ['] forth:or of ['] forth:(lit-or) endof
 301     ['] forth:xor of ['] forth:(lit-xor) endof
 302   otherwise drop false exit endcase
 303   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-BITWISE
 304     " direct-bitwise" .optim lit-value 0 .r cr
 305   $ENDIF
 306   replace-lit-with-arginstr true
 307 ;
 308
 309
 310 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 311 ;; table utilities
 312 ;;
 313
 314 : tw:  ( -- )  \ name
 315   -find-required dup compiler:constant-word? if cfa->pfa @ endif ,
 316 ;
 317
 318 ;; special table values
 319 -2 constant tbl-remove
 320 -1 constant tbl-keep
 321  0 constant tbl-lit-0
 322  1 constant tbl-lit-1
 323
 324 : process-table  ( tbl index repl-cfa -- did-repl? )
 325   nrot +cells @ case
 326     tbl-remove of drop remove-lit true exit endof
 327     tbl-keep of drop false exit endof
 328     tbl-lit-0 of drop 0 set-lit-value-only true exit endof
 329     tbl-lit-1 of drop 1 set-lit-value-only true exit endof
 330   otherwise swap execute true exit endcase
 331 ;
 332
 333 : simple-replace-from-table  ( tbl index -- did-repl? )
 334   ['] replace-lit process-table
 335 ;
 336
 337 : direct-replace-from-table  ( tbl index -- did-repl? )
 338   ['] remove-lit-set-direct process-table
 339 ;
 340
 341
 342 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 343 ;; {lit} +
 344 ;; {lit} -
 345 ;;
 346
 347 ;; starts with -8
 348 create inc-cfa-tbl
 349   tw: forth:8-   ;; -8
 350   tw: tbl-keep   ;; -7
 351   tw: tbl-keep   ;; -6
 352   tw: tbl-keep   ;; -5
 353   tw: forth:4-   ;; -4
 354   tw: tbl-keep   ;; -6
 355   tw: forth:2-   ;; -2
 356   tw: forth:1-   ;; -1
 357   tw: tbl-remove ;;  0
 358   tw: forth:1+   ;; +1
 359   tw: forth:2+   ;; +2
 360   tw: tbl-keep   ;; +3
 361   tw: forth:4+   ;; +4
 362   tw: tbl-keep   ;; +5
 363   tw: tbl-keep   ;; +6
 364   tw: tbl-keep   ;; +7
 365   tw: forth:8+   ;; +8
 366 create;
 367
 368 : optimise-inc-dec  ( -- done? )
 369   lit-value -8 9 within ifnot false exit endif
 370   inc-cfa-tbl last-instr-cfa case
 371     ['] forth:+ of lit-value endof
 372     ['] forth:- of lit-value negate endof
 373   otherwise 2drop false exit endcase
 374   8+ simple-replace-from-table
 375   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-INC-DEC
 376     dup if
 377       " inc-dec" .optim lit-value . cr
 378     endif
 379   $ENDIF
 380 ;
 381
 382
 383 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 384 ;; {lit} *
 385 ;; {lit} u*
 386 ;;
 387
 388 ;; starts with -1
 389 create lit-mul-tbl
 390   tw: forth:negate ;; -1
 391   tw: tbl-lit-0    ;;  0
 392   tw: tbl-remove   ;; +1
 393   tw: forth:2*     ;; +2
 394   tw: tbl-keep     ;; +3
 395   tw: forth:4*     ;; +4
 396   tw: tbl-keep     ;; +5
 397   tw: tbl-keep     ;; +6
 398   tw: tbl-keep     ;; +7
 399   tw: forth:8*     ;; +8
 400 create;
 401
 402 : optimise-mul  ( -- done? )
 403   lit-value -1 9 within ifnot false exit endif
 404   last-instr-cfa case
 405     ['] * of lit-mul-tbl endof
 406     ['] u* of lit-mul-tbl endof
 407   otherwise drop false exit endcase
 408   lit-value 1+ simple-replace-from-table
 409   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-MULS
 410     dup if
 411       " mul" .optim lit-value 0 .r cr
 412     endif
 413   $ENDIF
 414 ;
 415
 416
 417 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 418 ;; {lit} /
 419 ;; {lit} u/
 420 ;;
 421
 422 ;; starts with -1
 423 create lit-div-tbl
 424   tw: forth:negate ;; -1
 425   tw: tbl-keep     ;;  0
 426   tw: tbl-remove   ;; +1
 427   tw: forth:2/     ;; +2
 428   tw: tbl-keep     ;; +3
 429   tw: forth:4/     ;; +4
 430   tw: tbl-keep     ;; +5
 431   tw: tbl-keep     ;; +6
 432   tw: tbl-keep     ;; +7
 433   tw: forth:8/     ;; +8
 434 create;
 435
 436 ;; starts with -1
 437 create lit-udiv-tbl
 438   tw: tbl-keep     ;; -1
 439   tw: tbl-keep     ;;  0
 440   tw: tbl-remove   ;; +1
 441   tw: forth:2u/    ;; +2
 442   tw: tbl-keep     ;; +3
 443   tw: forth:4u/    ;; +4
 444   tw: tbl-keep     ;; +5
 445   tw: tbl-keep     ;; +6
 446   tw: tbl-keep     ;; +7
 447   tw: forth:8u/    ;; +8
 448 create;
 449
 450 : optimise-div  ( -- done? )
 451   lit-value -1 9 within ifnot false exit endif
 452   last-instr-cfa case
 453     ['] / of lit-div-tbl endof
 454     ['] u/ of lit-udiv-tbl endof
 455   otherwise drop false exit endcase
 456   lit-value 1+ simple-replace-from-table
 457   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-MULS
 458     dup if
 459       " div" .optim lit-value 0 .r cr
 460     endif
 461   $ENDIF
 462 ;
 463
 464
 465 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 466 ;; {lit} lsh
 467 ;; {lit} ash
 468 ;; {lit} lshift
 469 ;; {lit} rshift
 470 ;; {lit} arshift
 471 ;;
 472
 473 ;; starts with -3
 474 create lit-lsh-tbl
 475   tw: forth:8u/  ;; -3
 476   tw: forth:4u/  ;; -2
 477   tw: forth:2u/  ;; -1
 478   tw: tbl-remove ;;  0
 479   tw: forth:2*   ;; +1
 480   tw: forth:4*   ;; +2
 481   tw: forth:8*   ;; +3
 482 create;
 483
 484 ;; starts with -3
 485 create lit-ash-tbl
 486   tw: forth:8/   ;; -3
 487   tw: forth:4/   ;; -2
 488   tw: forth:2/   ;; -1
 489   tw: tbl-remove ;;  0
 490   tw: forth:2*   ;; +1
 491   tw: forth:4*   ;; +2
 492   tw: forth:8*   ;; +3
 493 create;
 494
 495 : optimise-shifts  ( -- done? )
 496   lit-value -3 4 within ifnot false exit endif
 497   lit-value last-instr-cfa case
 498     ['] forth:lsh of 3 + lit-lsh-tbl endof
 499     ['] forth:ash of 3 + lit-ash-tbl endof
 500     ['] forth:lshift of dup -if drop false exit endif 3 + lit-lsh-tbl endof
 501     ['] forth:rshift of dup -if drop false exit endif negate 3 + lit-lsh-tbl endof
 502     ['] forth:arshift of dup -if drop false exit endif negate 3 + lit-ash-tbl endof
 503   otherwise 2drop false exit endcase
 504   swap simple-replace-from-table
 505   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-MULS
 506     dup if
 507       " shift" .optim lit-value 0 .r cr
 508     endif
 509   $ENDIF
 510 ;
 511
 512
 513 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 514 ;; {lit} cells
 515 ;;
 516
 517 : optimise-cells  ( -- done? )
 518   last-instr-cfa ['] cells = ifnot false exit endif
 519   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-CELLS
 520     " cells" .optim lit-value 0 .r cr
 521   $ENDIF
 522   lit-value cells set-lit-value-only true
 523 ;
 524
 525
 526 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 527 ;; {lit} +cells
 528 ;; {lit} -cells
 529 ;;
 530
 531 : optimise-cells-inc-dec  ( -- done? )
 532   last-instr-cfa case
 533     ['] +cells of ['] + endof
 534     ['] -cells of ['] - endof
 535   otherwise drop false exit endcase
 536   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-CELLS-INC-DEC
 537     " cells-inc-dec " .optim lit-value 0 .r cr
 538   $ENDIF
 539   lit-value cells swap set-lit-value-instr true
 540 ;
 541
 542
 543 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 544 ;; {lit} (direct:!)
 545 ;;
 546
 547 : optimise-direct-poke  ( -- done? )
 548   last-instr-cfa ['] (direct:!) = ifnot false exit endif
 549   lit-value case
 550     -1 of ['] forth:(direct:-1:!) endof
 551      0 of ['] forth:(direct:0:!) endof
 552      1 of ['] forth:(direct:1:!) endof
 553   otherwise drop false exit endcase
 554   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-DIRECT-POKES
 555     " direct-poke" .optim lit-value 0 .r cr
 556   $ENDIF
 557   remove-lit-set-direct true
 558 ;
 559
 560
 561 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 562 ;; {lit} (direct:+!)
 563 ;; {lit} (direct:-!)
 564 ;;
 565
 566 ;; starts with -8
 567 create direct-inc-tbl
 568   tw: (direct:8-!) ;; -8
 569   tw: tbl-keep     ;; -7
 570   tw: tbl-keep     ;; -6
 571   tw: tbl-keep     ;; -5
 572   tw: (direct:4-!) ;; -4
 573   tw: tbl-keep     ;; -3
 574   tw: (direct:2-!) ;; -2
 575   tw: (direct:1-!) ;; -1
 576   tw: tbl-remove   ;;  0
 577   tw: (direct:1+!) ;; +1
 578   tw: (direct:2+!) ;; +2
 579   tw: tbl-keep     ;; +3
 580   tw: (direct:4+!) ;; +4
 581   tw: tbl-keep     ;; +5
 582   tw: tbl-keep     ;; +6
 583   tw: tbl-keep     ;; +7
 584   tw: (direct:8+!) ;; +8
 585 create;
 586
 587 : optimise-direct-poke-inc  ( -- done? )
 588   lit-value -8 9 within ifnot false exit endif
 589   last-instr-cfa case
 590     ['] (direct:+!) of lit-value endof
 591     ['] (direct:-!) of lit-value negate endof
 592   otherwise drop false exit endcase
 593   8+ direct-inc-tbl swap direct-replace-from-table
 594   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-DIRECT-POKE-INCS
 595     dup if
 596       " direct-poke-inc" .optim lit-value 0 .r cr
 597     endif
 598   $ENDIF
 599 ;
 600
 601
 602 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 603 ;;  false (direct:!)
 604 ;;  true (direct:!)
 605 ;;
 606
 607 : optimise-direct-poke-bool  ( -- done? )
 608   last-instr-cfa ['] (direct:!) = ifnot false exit endif
 609   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-DIRECT-POKES
 610     " direct-poke-bool" .optim lit-value 0 .r cr
 611   $ENDIF
 612   t/f-value case
 613     -1 of ['] forth:(direct:-1:!) endof
 614      0 of ['] forth:(direct:0:!) endof
 615      1 of ['] forth:(direct:1:!) endof
 616   otherwise " wuta?!" error endcase -- assertion
 617   replace-prev-with-direct true
 618 ;
 619
 620
 621 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 622 ;;  false (direct:+!)  -->  none
 623 ;;  false (direct:-!)  -->  none
 624 ;;  true (direct:+!)  -->  (direct:1-!)
 625 ;;  true (direct:-!)  -->  (direct:1+!)
 626 ;;
 627
 628 : optimise-direct-poke-inc-bool  ( -- done? )
 629   last-instr-cfa case
 630     ['] (direct:+!) of
 631         t/f-value ifnot remove-prev-and-direct true exit endif
 632         t/f-value
 633       endof
 634     ['] (direct:-!) of
 635         t/f-value ifnot remove-prev-and-direct true exit endif
 636         t/f-value negate
 637       endof
 638   otherwise drop false exit endcase
 639   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-DIRECT-POKES
 640     " direct-poke-inc-bool" .optim dup 0 .r cr
 641   $ENDIF
 642   case
 643     -1 of ['] forth:(direct:1-!) endof
 644      1 of ['] forth:(direct:1+!) endof
 645   otherwise " wuta?!" error endcase -- assertion
 646   replace-prev-with-direct true
 647 ;
 648
 649
 650 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 651 ;; var @
 652 ;; var !
 653 ;; var +!
 654 ;; var -!
 655 ;; with this optimisation, vars are as fast as direct memory access
 656 ;;
 657
 658 : optimise-vars  ( -- done? )
 659   last-instr-cfa case
 660     ['] @ of ['] forth:(direct:@) endof
 661     ['] ! of ['] forth:(direct:!) endof
 662     ['] +! of ['] forth:(direct:+!) endof
 663     ['] -! of ['] forth:(direct:-!) endof
 664   otherwise drop false exit endcase
 665   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-VARS
 666     " var-access" .optim
 667     ." var:`" prev-instr-addr @ cfa->nfa id-count xtype
 668     ." `; op:" last-instr-cfa cfa->nfa id-count xtype
 669     \ ."  addr: " v/c-value 0 u.r
 670     cr
 671   $ENDIF
 672   replace-v/c-with-direct true
 673 ;
 674
 675
 676 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 677 ;; swap drop  -->  nip
 678 ;; rot rot    -->  nrot
 679 ;; swap !     -->  swap!
 680 ;;
 681
 682 : optimise-stack-ops  ( -- done? )
 683   buffer-tail@ dup last-cw = ifnot drop false exit endif
 684   buffer-prev@ dup prev-cw = ifnot 2drop false exit endif
 685   @ swap @ case  ;; prev tail
 686     ['] drop of
 687         ['] swap = ifnot false exit endif
 688         ['] nip
 689       endof
 690     ['] rot of
 691         ['] rot = ifnot false exit endif
 692         ['] nrot
 693       endof
 694     ['] ! of
 695         ['] swap = ifnot false exit endif
 696         ['] swap!
 697       endof
 698   otherwise 2drop false exit endcase
 699   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-STACK-OPS
 700     " stack-ops" .optim
 701     dup cfa->nfa id-count xtype
 702     cr
 703   $ENDIF
 704   buffer-prev@ swap over compile! cell+ dp!
 705   buffer-reset true  ;; don't bother restoring the buffer for now
 706 ;
 707
 708
 709 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 710 ;; swap 1+ swap  -->  (swap:1+:swap)
 711 ;;
 712
 713 : optimise-swap-1+-swap  ( -- done? )
 714   ;; last swap
 715   buffer-tail@ dup last-cw = ifnot drop false exit endif
 716   @ ['] swap = ifnot false exit endif
 717   ;; 1+
 718   buffer-prev@ dup prev-cw = ifnot drop false exit endif
 719   @ ['] 1+ = ifnot false exit endif
 720   ;; first swap
 721   buffer-third@ dup here 12 - = ifnot drop false exit endif
 722   @ ['] swap = ifnot false exit endif
 723   $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-SWAP-INC-SWAP
 724     " swap-1+-swap" .optim cr
 725   $ENDIF
 726   buffer-third@ ['] forth:(swap:1+:swap) over compile! cell+ dp!
 727   buffer-reset true  ;; don't bother restoring the buffer for now
 728 ;
 729
 730
 731 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 732 ;; main dispatcher
 733 ;;
 734
 735 : instr-compiled  ( addr -- )
 736   push-last-instr
 737   lit-and-instr? if  ;; we just compiled a literal
 738     optimise-direct-bitwise
 739     dup ifnot drop optimise-cells endif
 740     dup ifnot drop optimise-cells-inc-dec drop false endif -- keep optimising, inc/dec might do more
 741     dup ifnot drop optimise-inc-dec endif
 742     dup ifnot drop optimise-mul endif
 743     dup ifnot drop optimise-div endif
 744     dup ifnot drop optimise-shifts endif
 745     drop
 746   endif
 747   prev-var/const-and-instr? if
 748     optimise-vars drop \ if exit endif -- direct optimisers below will do more this way
 749   endif
 750   ;; direct pokes
 751   lit-and-one-arg? if
 752     optimise-direct-poke if exit endif
 753     optimise-direct-poke-inc if exit endif
 754   endif
 755   true/false-and-one-arg? if
 756     optimise-direct-poke-bool if exit endif
 757     optimise-direct-poke-inc-bool if exit endif
 758   endif
 759   optimise-swap-1+-swap if exit endif
 760   optimise-stack-ops if exit endif
 761 ;
 762 buffer-reset
 763
 764
 765 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 766 ;; reset
 767 ;;
 768
 769 : install  ( -- )
 770   enabled? ifnot
 771     true to enabled?
 772     buffer-reset
 773     ;; called by "compiler:(<j-mark)"
 774     ;; erase literal address, so "lit begin and" will not be optimised to shit
 775     ['] buffer-reset to compiler:(jump-here-marked)
 776     ['] buffer-reset to compiler:(reset-sinopt)
 777     ['] push-literal to compiler:(after-compile-lit)
 778     ['] instr-compiled to compiler:(after-compile-word)
 779   endif
 780 ;
 781
 782 : uninstall  ( -- )
 783   enabled? if
 784     false to enabled?
 785     buffer-reset
 786     ;; called by "compiler:(<j-mark)"
 787     ;; erase literal address, so "lit begin and" will not be optimised to shit
 788     ['] forth:noop to compiler:(jump-here-marked)
 789     ['] forth:noop to compiler:(reset-sinopt)
 790     ['] forth:drop to compiler:(after-compile-lit)
 791     ['] forth:drop to compiler:(after-compile-word)
 792   endif
 793 ;
 794
 795 install
 796
 797 : temp-disable  ( -- )
 798   enabled? if
 799     ['] forth:drop to compiler:(after-compile-lit)
 800     ['] forth:drop to compiler:(after-compile-word)
 801   endif
 802 ;
 803
 804 : temp-restore  ( -- )
 805   enabled? if
 806     ['] push-literal to compiler:(after-compile-lit)
 807     ['] instr-compiled to compiler:(after-compile-word)
 808   endif
 809 ;
 810
 811 prev-defs
 812
 813
 814 : sinopt-enable  ( -- )  forth:(sinopt-peephole):install ;
 815 : sinopt-disable  ( -- )  forth:(sinopt-peephole):uninstall ;
 816 : sinopt-enabled?  ( -- bool )  forth:(sinopt-peephole):enabled? ;
 817 : sinopt-enabled!  ( bool -- )  if forth:(sinopt-peephole):install else forth:(sinopt-peephole):uninstall endif ;
 818
 819 ;; optimising compiled UrAsm code slows everything down a lot
 820 : sinopt-temp-restore  ( -- )  forth:(sinopt-peephole):temp-restore ;
 821 : sinopt-temp-disable  ( -- )  forth:(sinopt-peephole):temp-disable ;