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