
\ -----------------------------------------------------------------------------
\
\    Acrobatics - A register allocator for Mecrisp-Quintus
\    Copyright (C) 2019  Matthias Koch
\
\    This program is free software: you can redistribute it and/or modify
\    it under the terms of the GNU General Public License as published by
\    the Free Software Foundation, either version 3 of the License, or
\    (at your option) any later version.
\
\    This program is distributed in the hope that it will be useful,
\    but WITHOUT ANY WARRANTY; without even the implied warranty of
\    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\    GNU General Public License for more details.
\
\    You should have received a copy of the GNU General Public License
\    along with this program.  If not, see <http://www.gnu.org/licenses/>.
\
\
\  I am happy to share my first experimental release,
\  but consider this code to be a highly experimental mess
\  at this point in time.
\
\  How to use:
\
\    acro-on  ( -- ) Switch into the fresh compiler.
\
\    acro-off ( -- ) Go back to the classic compiler in the Forth core.
\
\    maximum-inlining ( -- ) Inline-Cache accepts up to 24 primitives+literals
\    normal-inlining  ( -- ) Inline-Cache accepts up to  6 primitives+literals (default)
\    no-inlining      ( -- ) Inline-Cache will not be written for definitions compiled in this mode
\
\    You can mix freely, with individual options for each definition separately.
\
\ -----------------------------------------------------------------------------

compiletoflash

\ -----------------------------------------------------------------------------

\ Conditional compilation

\ Idea similar to http://lars.nocrew.org/dpans/dpansa15.htm#A.15.6.2.2532

: nexttoken ( -- addr len )
  begin
    token          \ Fetch new token.
  dup 0= while      \ If length of token is zero, end of line is reached.
    2drop cr query   \ Fetch new line.
  repeat
;

: [else] ( -- )
  1 \ Initial level of nesting
  begin
    nexttoken ( level addr len )

    2dup s" [if]"     compare
 >r 2dup s" [ifdef]"  compare r> or
 >r 2dup s" [ifndef]" compare r> or

    if
      2drop 1+  \ One more level of nesting
    else
      2dup s" [else]" compare
      if
        2drop 1- dup if 1+ then  \ Finished if [else] is reached in level 1. Skip [else] branch otherwise.
      else
        s" [then]" compare if 1- then  \ Level completed.
      then
    then

    ?dup 0=
  until

  immediate 0-foldable
;

: [then] ( -- ) immediate 0-foldable ;

: [if]   ( ? -- )                 0=  if postpone [else] then immediate 1-foldable ;
: [ifdef]  ( -- ) token find drop 0=  if postpone [else] then immediate 0-foldable ;
: [ifndef] ( -- ) token find drop 0<> if postpone [else] then immediate 0-foldable ;

\ -----------------------------------------------------------------------------
\  Tools for building Opcodes
\ -----------------------------------------------------------------------------

2 constant rsp-register
3 constant loop-index-register
4 constant loop-limit-register
8 constant tos-register
9 constant psp-register

[ifdef] mips

31 constant link-register \ Link register is hardwired, just to give it a name

: >source1       ( opcode register -- opcode* ) 21 lshift or 2-foldable ;
: >source2       ( opcode register -- opcode* ) 16 lshift or 2-foldable ;
: >destination-i ( opcode register -- opcode* ) 16 lshift or 2-foldable ;
: >destination   ( opcode register -- opcode* ) 11 lshift or 2-foldable ;
: >imm-i         ( opcode n        -- opcode* ) $FFFF and or 2-foldable ;
: >imm-store     ( opcode offset   -- opcode* ) $FFFF and or 2-foldable ;
: >imm-shift     ( opcode shift    -- opcode* ) $1F and 6 lshift or 2-foldable ;

[else]

1 constant link-register \ Link register is hardwired, just to give it a name

: >source1       ( opcode register -- opcode* ) 15 lshift or 2-foldable ;
: >source2       ( opcode register -- opcode* ) 20 lshift or 2-foldable ;
: >destination-i ( opcode register -- opcode* )  7 lshift or 2-foldable ;
: >destination   ( opcode register -- opcode* )  7 lshift or 2-foldable ;
: >imm-i         ( opcode n        -- opcode* ) 20 lshift or 2-foldable ;
: >imm-store     ( opcode offset   -- opcode* ) dup $1F and 7 lshift swap $FE0 and 20 lshift or or 2-foldable ;

[then]

\ -----------------------------------------------------------------------------
\  Data structures for stack model
\ -----------------------------------------------------------------------------

-1 constant state-unknown
-2 constant state-literal

8 constant cached-d-elements \ Minimum: 2 Sinnvoll: ab 5
5 constant cached-r-elements \ Minimum: 2 Sinnvoll: ab 3

create canonical-state \ Adjust accordingly when changing the amount of cached elements.
                       \ Tidyup code is hardwired for TOS in register and all others on stack = unknown.
\ ---------------------------
   tos-register , 0 , \ TOS
  state-unknown , 0 , \ NOS
  state-unknown , 0 , \ 3OS
  state-unknown , 0 , \ 4OS
  state-unknown , 0 , \ 5OS
  state-unknown , 0 , \ 6OS
  state-unknown , 0 , \ 7OS
  state-unknown , 0 , \ 8OS
\ ---------------------------
  state-unknown , 0 , \ TOR
  state-unknown , 0 , \ NOR
  state-unknown , 0 , \ 3OR
  state-unknown , 0 , \ 4OR
  state-unknown , 0 , \ 5OR
\ ---------------------------

create register-list  \ Provide as many registers as you have cached stack elements. Take care of interrupt entry sequences when changing this !
\ ---------------------------
   tos-register , \ For performance reasons, the first register should be the canonical TOS register. Results default to this one.
             14 , \ Registers 14 and 15 are temporary registers in the core code of Mecrisp-Quintus.
             16 ,
             17 ,
             18 ,
             19 ,
             20 ,
             21 ,
             22 ,
             23 ,
             24 ,
             25 ,
  link-register , \ The usage of the link register for something else than the link is uncommon, but helps saving one push/pop pair on interrupt entry.
\ ---------------------------

15 constant temporary-register-for-acrobatics \ Specify which register to use for temporary things like lui lw/xori pairs.

false variable temporary-bekannt
    0 variable temporary-inhalt

cached-d-elements cached-r-elements + constant cached-elements
cached-elements 2* cells              constant ra-size

ra-size buffer: ra-state

: init-register-allocator ( -- )
  canonical-state ra-state ra-size move
  false temporary-bekannt !
;

\ -----------------------------------------------------------------------------
\   A few handy shortcuts for accessing the state of certain elements
\ -----------------------------------------------------------------------------

: ->tos ( addr -- addr* ) 0 2* cells + 1-foldable ;
: ->nos ( addr -- addr* ) 1 2* cells + 1-foldable ;
\ : ->3os ( addr -- addr* ) 2 2* cells + 1-foldable ;

: ->d-last ( addr -- addr* ) cached-d-elements 1- 2* cells + 1-foldable ;

: ->tor ( addr -- addr* ) cached-d-elements 0 + 2* cells + 1-foldable ;
\ : ->nor ( addr -- addr* ) cached-d-elements 1 + 2* cells + 1-foldable ;
\ : ->3or ( addr -- addr* ) cached-d-elements 2 + 2* cells + 1-foldable ;

: ->r-last ( addr -- addr* ) cached-d-elements cached-r-elements 1- + 2* cells + 1-foldable ;

cached-d-elements     0                     2constant d-elements-increasing
0                     cached-d-elements 1-  2constant d-elements-decreasing

cached-d-elements     1                     2constant d-elements-increasing-without-tos
1                     cached-d-elements 1-  2constant d-elements-decreasing-without-tos

cached-elements       cached-d-elements     2constant r-elements-increasing
cached-d-elements     cached-elements 1-    2constant r-elements-decreasing

cached-elements       cached-d-elements 1+  2constant r-elements-increasing-without-tor
cached-d-elements 1+  cached-elements 1-    2constant r-elements-decreasing-without-tor

cached-elements       0                     2constant all-elements-increasing
0                     cached-elements 1-    2constant all-elements-decreasing

: element ( addr n -- addr* ) 2* cells + 2-foldable ;

\ -----------------------------------------------------------------------------
\   Insight for debugging
\ -----------------------------------------------------------------------------

  [ifdef] debug

  : cura ( -- ) \ See you RA
    cr

    d-elements-increasing do
      i u. ." : " ra-state i element 2@ hex. hex. cr
    loop

    cr

    r-elements-increasing do
      i cached-d-elements - u. ." : " ra-state i element 2@ hex. hex. cr
    loop
  ;

  : cu ( -- ) cura 0-foldable ;

  \ : ,  ( x -- ) cr here disasm-$ ! , disasm-step ;
  \ : registerliteral, ( x reg -- ) cr ." Regliteral, " h.s registerliteral, h.s ;

  [then]

\ -----------------------------------------------------------------------------
\   Tools to get multiple elements to the stack in an efficient way
\ -----------------------------------------------------------------------------

false variable opcode-adjust-stack
false variable opcode-store-stack

: select-opcodes-for-d-tidyup ( -- )
  [ifdef] mips
    $24000000 psp-register >destination-i psp-register >source1 opcode-adjust-stack ! \ addiu $9, $9, 0 Opcode
    $AC000000 psp-register >source1                             opcode-store-stack  ! \ sw $zero, 0000($9) Opcode
  [else]
    $00000013 psp-register >destination   psp-register >source1 opcode-adjust-stack ! \ addi x9, x9, 0 Opcode
    $00002023 psp-register >source1                             opcode-store-stack  ! \ sw x0, 0(x9) Opcode
  [then]
;

: select-opcodes-for-r-tidyup ( -- )
  [ifdef] mips
    $24000000 rsp-register >destination-i rsp-register >source1 opcode-adjust-stack ! \ addiu $2, $2, 0 Opcode
    $AC000000 rsp-register >source1                             opcode-store-stack  ! \ sw $zero, 0000($2) Opcode
  [else]
    $00000013 rsp-register >destination   rsp-register >source1 opcode-adjust-stack ! \ addi x2, x2, 0 Opcode
    $00002023 rsp-register >source1                             opcode-store-stack  ! \ sw x0, 0(x2) Opcode
  [then]
;

: tidyup-collect ( Anzahl Zustandsvariable -- ... Anzahl* )
  dup @ state-unknown <> if
    swap 1+ \ Ein Element mehr rauszuschreiben
  else drop then
;

: get-element-into-register ( element -- register )
    dup @ state-literal =
    if
      cell+ @
      dup 0<> \ Literal 0 steht direkt als Register 0 zur Verfügung
      if \ Get literal into register

        dup temporary-inhalt @ = temporary-bekannt @ and
        if
          drop
        else
          dup temporary-inhalt ! true temporary-bekannt !
          temporary-register-for-acrobatics registerliteral,
        then

        temporary-register-for-acrobatics

      then
    else
      @  \ Get the register which contains what goes to the stack.
    then
;

: tidyup-flush ( ... Anzahl -- )

  \ Write addi opcode to adjust stack pointer
  dup if
    dup cells negate opcode-adjust-stack @ swap >imm-i ,
  then

  \ Write opcodes for all the elements which shall go to that stack.

  0 ?do \ Schleife über die Elemente
    get-element-into-register
    opcode-store-stack @ swap
    [ifdef] mips
      >destination-i
    [else]
      >source2
    [then]
    i cells >imm-store \ Offset into stack
    ,
  loop
;

\ -----------------------------------------------------------------------------
\   Tidyup. Fall back to canonical stack state from any state the stack model could be in.
\   The design of this section is very critical for the overall performance of the resulting code.
\ -----------------------------------------------------------------------------

: move-opcode ( source-register destination-register -- )
  2dup <>
  if
    [ifdef] mips
    $00000025 swap >destination \ or $0, $0, $0
    [else]
    $00006033 swap >destination \ or x0, x0, x0
    [then]
              swap >source1 ,
  else
    2drop
  then
;

: tidyup-ra ( -- )

  \ Collect all writes to data stack in order to use a single opcode for stack adjustment only.

  select-opcodes-for-d-tidyup
  0 \ Number of elements to be written to stack so far...

  d-elements-decreasing-without-tos do
    ra-state i element tidyup-collect
  -1 +loop

  tidyup-flush \ All data stack elements with exception of TOS are written out to data stack now.

  select-opcodes-for-r-tidyup
  0 \ Number of elements to be written to stack so far...

  r-elements-decreasing do
    ra-state i element tidyup-collect
  -1 +loop

  tidyup-flush \ All elements are written out to return stack now.

  \ Check if TOS is available in register as desired:

    ra-state ->tos @ state-literal =    \ Load constant into TOS register
    if

      ra-state ->tos cell+ @ temporary-inhalt @ = temporary-bekannt @ and
      if \ Ist das gewünschte Literal zufällig gerade in dem temporären Register ?
        temporary-register-for-acrobatics canonical-state ->tos @ move-opcode
      else
        ra-state        ->tos cell+ @
        canonical-state ->tos @ registerliteral,
      then

    else

      ra-state ->tos @ state-unknown =     \ Load register from stack
      if \ Same opcodes as in "drop"
        [ifdef] mips
          $8C000000 tos-register >destination-i psp-register >source1 , \ lw $8, 0000($9)
          $24000004 psp-register >destination-i psp-register >source1 , \ addiu $9, $9, 0004
        [else]
          $00002003 tos-register >destination   psp-register >source1 , \ lw     x8, 0 (x9)
          $00400013 psp-register >destination   psp-register >source1 , \ addi   x9, x9, 4
        [then]
        canonical-state ->tos @ ra-state ->tos !

      else
        ra-state ->tos @ canonical-state ->tos @ move-opcode  \ Move TOS into correct register, if required.
      then

   then

  init-register-allocator \ Set state back to canonical state. It's simpler this way.

  \ Canonical fallback completed.
;


\ -----------------------------------------------------------------------------
\  Various stack model infrastructure tools
\  to get one element at a time from and to the stack of your choice
\ -----------------------------------------------------------------------------

: d-tidyup ( element -- )
  select-opcodes-for-d-tidyup
  0 swap tidyup-collect
  tidyup-flush
;

: r-tidyup ( element -- )
  select-opcodes-for-r-tidyup
  0 swap tidyup-collect
  tidyup-flush
;

\ -----------------------------------------------------------------------------

: befreie-tos ( -- )

  ra-state ->d-last d-tidyup

  d-elements-decreasing-without-tos do
    ra-state i 1- element 2@
    ra-state i    element 2!
  -1 +loop

  state-unknown ra-state ->tos !
;

: eliminiere-tos ( -- )

  d-elements-increasing-without-tos do
    ra-state i    element 2@
    ra-state i 1- element 2!
  loop

  state-unknown ra-state ->d-last !
;

\ -----------------------------------------------------------------------------

: befreie-tor ( -- )

  ra-state ->r-last r-tidyup

  r-elements-decreasing-without-tor do
    ra-state i 1- element 2@
    ra-state i    element 2!
  -1 +loop

  state-unknown ra-state ->tor !
;

: eliminiere-tor ( -- )

  r-elements-increasing-without-tor do
    ra-state i    element 2@
    ra-state i 1- element 2!
  loop

  state-unknown ra-state ->r-last !
;

\ -----------------------------------------------------------------------------
\  Flags für die Kompilation
\ -----------------------------------------------------------------------------

\ Flags, die auch im Kern genauso definiert sind und so bleiben müssen

$0010 constant flag-immediate
$0020 constant flag-inline

$0030 constant flag-compileonly

$0040 constant flag-foldable
$000F constant flag-foldabilitymask

$0080 constant flag-ramallot

\ Flags, die hier neu hinzukommen (und beliebig verändert werden können)

 $10000 constant flag-inlinecache
 $20000 constant flag-allocator \ War mal $0200 in Mecrisp-Stellaris. Im Mecrisp-Quintus habe ich erweiterte Flag-Felder.
 $40000 constant flag-finished  \ Zum eleganten Beenden der Kompilation
 $80000 constant flag-literator  \ Tritt nur im Cache für die RA-Vererbung auf !

$100000 constant flag-acro-only

\ -----------------------------------------------------------------------------
\  Inline-Cache aus Mecrisp-Stellaris RA
\ -----------------------------------------------------------------------------

24 constant maximum-inline-cache-length
maximum-inline-cache-length 8 * buffer: inline-cache

0 variable inline-cache-count

6 variable current-inline-cache-length \ Start mit sinnvoller Standard-Cachegröße

: set-inline-cache ( u -- ) maximum-inline-cache-length umin current-inline-cache-length ! ;

: maximum-inlining ( -- ) maximum-inline-cache-length set-inline-cache ;
: normal-inlining  ( -- )                           6 set-inline-cache ;
: no-inlining      ( -- )                           0 set-inline-cache ;


  [ifdef] debug
    \ Deep insight for debugging

    : cuic ( -- ) cr cr
      inline-cache-count @ .
      inline-cache
      maximum-inline-cache-length 0 do
        dup @ hex. 4 +
        dup @ hex. 4 +
        cr
      loop
      drop cr cr
    ;

    : see-ic ( -- )
      ' skipdefinition

      dup cr ." Zahl der Elemente: " @ dup . cr

      dup maximum-inline-cache-length u> if drop exit then

      0 ?do

        [ifdef] name.
          cell+ dup @ dup >r hex.
          cell+ dup @ hex. r> name. cr
        [else]
          cell+ dup @ hex.
          cell+ dup @ hex. cr
        [then]
      loop
      drop
      cr
    ;
  [then]

: squash-inline-cache ( -- ) \ Definition soll keinen Inline-Cache bekommen.
  -1 inline-cache-count !
;

: write-inline-cache ( -- )

  inline-cache-count @ current-inline-cache-length @ u> if exit then \ Zu lang, nicht komplett erfasst ! Kann leider keine Optimiervererbungssequenz schreiben.
  inline-cache-count @ 0 = if flag-foldable setflags exit then \ Leere Definition. Als 0-faltbar markieren, damit sie komplett wegoptimiert werden kann.

  flag-inlinecache setflags

  \ ." Write Inline Cache" cr cuic cr
  \ ."  *InCa "

  inline-cache
  inline-cache-count @ dup ,
  0 do
    dup @ , 4 +
    dup @ , 4 +
  loop
  drop
;

: add-to-inline-cache ( addr|literal flags -- )
  \ Sollte noch Platz im Inline-Cache sein, füge dieses Paar hinzu. Ansonsten markiere die Definition als zu lang, um sie einfügen zu können.

  inline-cache-count @ current-inline-cache-length @ u<
  if
    \ ." +Ca "
    ( dup hex. ) inline-cache-count @ 8 * 4 + inline-cache + !
    ( dup hex. ) inline-cache-count @ 8 *     inline-cache + !

  else
    \ ." xCA "
    2drop
  then

  inline-cache-count @ -1 <> if 1 inline-cache-count +! then
;

\ -----------------------------------------------------------------------------
\  RA infrastructure
\ -----------------------------------------------------------------------------

: registerfrei? ( reg -- reg ? )

  all-elements-increasing do
    dup ra-state i element @ = if unloop false exit then
  loop

  true
;

: get-free-register ( -- reg )

  all-elements-increasing do
    register-list i cells + @ registerfrei? if unloop exit else drop then
  loop

  ." Keine freien Register vorhanden, Fehler im RA !" quit
;

: expect-one-r-element ( -- )
  ra-state ->tor @ state-unknown =
  if
    get-free-register
    dup ra-state ->tor !
    [ifdef] mips
      $8C000000         swap >destination-i rsp-register >source1 , \ lw $0, 0000($2)
      $24000004 rsp-register >destination-i rsp-register >source1 , \ addiu $2, $2, 0004
    [else]
      $00002003         swap >destination   rsp-register >source1 , \ lw     x0, 0 (x2)
      $00400013 rsp-register >destination   rsp-register >source1 , \ addi   x2, x2, 4
    [then]
  then
;

: expect-one-element ( -- )
  ra-state ->tos @ state-unknown =
  if
    get-free-register
    dup ra-state ->tos !
    [ifdef] mips
      $8C000000         swap >destination-i psp-register >source1 , \ lw $0, 0000($9)
      $24000004 psp-register >destination-i psp-register >source1 , \ addiu $9, $9, 0004
    [else]
      $00002003         swap >destination   psp-register >source1 , \ lw     x0, 0 (x9)
      $00400013 psp-register >destination   psp-register >source1 , \ addi   x9, x9, 4
    [then]
  then
;

: expect-two-elements ( -- )

  ra-state ->tos @ state-unknown =
  if \ TOS und NOS müssen nachgeladen werden.
     \ Der Fall, dass TOS auf dem Stack ist, aber NOS im Register, sollte niemals auftreten.

    get-free-register
    dup ra-state ->tos !
    [ifdef] mips
      $8C000000         swap >destination-i psp-register >source1 , \ lw $0, 0000($9)
    [else]
      $00002003         swap >destination   psp-register >source1 , \ lw   x0, 0 (x9)
    [then]

    get-free-register
    dup ra-state ->nos !
    [ifdef] mips
      $8C000004         swap >destination-i psp-register >source1 , \ lw $0, 0004($9)
      $24000008 psp-register >destination-i psp-register >source1 , \ addiu $9, $9, 0008
    [else]
      $00402003         swap >destination   psp-register >source1 , \ lw     x0, 4 (x9)
      $00800013 psp-register >destination   psp-register >source1 , \ addi   x9, x9, 8
    [then]

  else \ TOS ist belegt, aber NOS muss vielleicht nachgeladen werden.

    ra-state ->nos @ state-unknown =
    if
      get-free-register
      dup ra-state ->nos !
      [ifdef] mips
        $8C000000         swap >destination-i psp-register >source1 , \ lw $0, 0000($9)
        $24000004 psp-register >destination-i psp-register >source1 , \ addiu $9, $9, 0004
      [else]
        $00002003         swap >destination   psp-register >source1 , \ lw     x0, 0 (x9)
        $00400013 psp-register >destination   psp-register >source1 , \ addi   x9, x9, 4
      [then]
    then

  then
;

: constant-to-tos ( -- ) \ Wenn NOS gefüllt ist, muss es TOS auch sein.

  ra-state ->nos @ state-literal =
  if
    ra-state ->nos 2@
       ra-state ->tos 2@
       ra-state ->nos 2!
    ra-state ->tos 2!
  then
;

: expect-element-in-register ( element -- )
  dup @ state-literal = \ If it is a constant, get it into a free register.
  if
    dup cell+ @ 0<>
    if
      get-free-register over !
      dup cell+ @ \ Konstante
      over @ \ Register
      registerliteral,
    else \ Literal 0 steht direkt als Register 0 zur Verfügung
      0 over !
    then
  then
  drop
;

\ -----------------------------------------------------------------------------
\  Baukasten für die "selbstoptimierenden" Definitionen
\ -----------------------------------------------------------------------------

: allocator: ( -- )
  postpone exit

  [ifdef] mips
    $2400FFFC  rsp-register >destination-i rsp-register >source1 , \ addiu $2, $2, FFFC
    $AC000000 link-register >destination-i rsp-register >source1 , \ sw $31, 0000($2)
  [else]
    $FFC00013  rsp-register >destination   rsp-register >source1 , \ addi   x2, x2, -4
    $00002023 link-register >source2       rsp-register >source1 , \ sw     x1, 0 (x2)
  [then]

  flag-allocator setflags

immediate ;

: acro-only ( -- ) flag-acro-only setflags immediate 0-foldable ;

\ -----------------------------------------------------------------------------
\  Helferlein für die kommenden Allokator-Optimierungsfälle
\ -----------------------------------------------------------------------------

[ifdef] mips

  : tossigned16bitliteral? ( -- x true | false )

     ra-state ->tos cell+ @ $FFFF8000 and dup $FFFF8000 = swap 0= or
     ra-state ->tos @ state-literal =
     and
     if
       ra-state ->tos cell+ @
       true
     else
       false
     then
  ;

  : tosunsigned16bitliteral? ( -- x true | false )

     ra-state ->tos cell+ @ $FFFF0000 and 0=
     ra-state ->tos @ state-literal =
     and
     if
       ra-state ->tos cell+ @
       true
     else
       false
     then
  ;


[else]

  : tos12bitliteral? ( -- x true | false )

     ra-state ->tos cell+ @ $FFFFF800 and dup $FFFFF800 = swap 0= or
     ra-state ->tos @ state-literal =
     and
     if
       ra-state ->tos cell+ @
       true
     else
       false
     then
  ;

[then]

\ -----------------------------------------------------------------------------

[ifdef] mips

  : ra-rechenlogik-unsigned ( Immediate-Opcode Register-Opcode -- )

    2>r

    tosunsigned16bitliteral?

    if
      ( Konstante ) $FFFF and
      rdrop r> or

      ra-state ->nos expect-element-in-register

      ra-state ->nos @ >source1

      eliminiere-tos
      eliminiere-tos

      befreie-tos
      get-free-register
      dup ra-state ->tos !

      >destination-i ,

    else

      ra-state ->tos expect-element-in-register
      r> rdrop
      ra-state ->tos @ >source2

      ra-state ->nos expect-element-in-register

      ra-state ->nos @ >source1

      eliminiere-tos
      eliminiere-tos

      befreie-tos
      get-free-register
      dup ra-state ->tos !

      >destination ,
    then
  ;

  : ra-rechenlogik-signed ( Immediate-Opcode Register-Opcode -- )

    2>r

    tossigned16bitliteral?

    if
      ( Konstante ) $FFFF and
      rdrop r> or

      ra-state ->nos expect-element-in-register

      ra-state ->nos @ >source1

      eliminiere-tos
      eliminiere-tos

      befreie-tos
      get-free-register
      dup ra-state ->tos !

      >destination-i ,

    else

      ra-state ->tos expect-element-in-register
      r> rdrop
      ra-state ->tos @ >source2

      ra-state ->nos expect-element-in-register

      ra-state ->nos @ >source1

      eliminiere-tos
      eliminiere-tos

      befreie-tos
      get-free-register
      dup ra-state ->tos !

      >destination ,
    then
  ;

[else]

  : ra-rechenlogik-signed ( Immediate-Opcode Register-Opcode -- )

    2>r

    tos12bitliteral?

    if
      ( Konstante ) 20 lshift
      rdrop r> or
    else
      ra-state ->tos expect-element-in-register
      r> rdrop
      ra-state ->tos @ >source2
    then

    ra-state ->nos expect-element-in-register

    ra-state ->nos @ >source1

    eliminiere-tos
    eliminiere-tos

    befreie-tos
    get-free-register
    dup ra-state ->tos !

    >destination ,
  ;

  : ra-rechenlogik-unsigned ( Immediate-Opcode Register-Opcode -- ) ra-rechenlogik-signed ;

[then]

: ra-rechenlogik-plus ( Immediate-Opcode Register-Opcode -- )
  expect-two-elements
  constant-to-tos \ Kommutativ, also Konstante -> TOS.

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @             0 = and
  if 2drop eliminiere-tos exit then

  ra-rechenlogik-signed
;

: ra-rechenlogik-minus ( Immediate-Opcode Register-Opcode -- )
  expect-two-elements

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @             0 = and
  if 2drop eliminiere-tos exit then

  ra-state ->tos @ state-literal =
  if
    ra-state ->tos cell+ dup   @ negate swap !  \ Konstante für ADDI-Opcode vorbereiten

    \ Auf addi(u) / add(u) Opcodes umschalten, damit die negierte Konstante korrekt bearbeitet wird
    [ifdef] mips
      2drop $24000000 $00000021 \ addiu $0, $0, 0  addu $0, $0, $0
    [else]
      2drop $00000013 $00000033 \  addi x0, x0, 0  add x0, x0, x0
    [then]
  then

  ra-rechenlogik-signed
;

: ra-rechenlogik-xor ( Immediate-Opcode Register-Opcode -- )
  expect-two-elements
  constant-to-tos \ Kommutativ, also Konstante -> TOS.

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @             0 = and
  if 2drop eliminiere-tos exit then

  ra-rechenlogik-unsigned
;

: ra-rechenlogik-or ( Immediate-Opcode Register-Opcode -- )
  expect-two-elements
  constant-to-tos \ Kommutativ, also Konstante -> TOS.

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @             0 = and
  if 2drop eliminiere-tos exit then

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @            -1 = and
  if 2drop  ra-state ->tos 2@ ra-state ->nos 2! eliminiere-tos exit then

  ra-rechenlogik-unsigned
;

: ra-rechenlogik-and ( Immediate-Opcode Register-Opcode -- )
  expect-two-elements
  constant-to-tos \ Kommutativ, also Konstante -> TOS.

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @            -1 = and
  if 2drop eliminiere-tos exit then

  ra-state ->tos       @ state-literal =
  ra-state ->tos cell+ @             0 = and
  if 2drop  ra-state ->tos 2@ ra-state ->nos 2! eliminiere-tos exit then

  ra-rechenlogik-unsigned
;

: ra-rechenlogik-slt(u) ( Immediate-Opcode Register-Opcode -- )
  expect-two-elements
  ra-rechenlogik-signed
;

[ifdef] mips

  : ra-rechenlogik-schieben ( Immediate-Opcode Register-Opcode -- )
    expect-two-elements

    ra-state ->tos @ state-literal =
    if
      $1F not ra-state ->tos cell+ bic!  \ Maximale Schubweite von 31 maskieren.
    then

    ra-state ->tos       @ state-literal =
    ra-state ->tos cell+ @             0 = and
    if 2drop eliminiere-tos exit then

    2>r

    ra-state ->tos @ state-literal =

    if
      rdrop r> ( Opcode )
      ra-state ->tos cell+ @ >imm-shift

      ra-state ->nos expect-element-in-register
      ra-state ->nos @ >source2

    else

      ra-state ->tos expect-element-in-register
      r> rdrop ( Opcode )
      ra-state ->tos @ >source2

      ra-state ->nos expect-element-in-register
      ra-state ->nos @ >source1
    then

    eliminiere-tos
    eliminiere-tos

    befreie-tos
    get-free-register
    dup ra-state ->tos !

    >destination ,
  ;

[else]

  : ra-rechenlogik-schieben ( Immediate-Opcode Register-Opcode -- )
    expect-two-elements

    ra-state ->tos @ state-literal =
    if
      $1F not ra-state ->tos cell+ bic!  \ Maximale Schubweite von 31 maskieren.
    then

    ra-state ->tos       @ state-literal =
    ra-state ->tos cell+ @             0 = and
    if 2drop eliminiere-tos exit then

    ra-rechenlogik-signed
  ;

[then]

\ -----------------------------------------------------------------------------

: ra-rechenlogik-muldiv ( Opcode -- )

  expect-two-elements
  ra-state ->tos expect-element-in-register
  ra-state ->nos expect-element-in-register

  ra-state ->nos @ >source1
  ra-state ->tos @ >source2

  eliminiere-tos eliminiere-tos
  befreie-tos

  get-free-register dup ra-state ->tos !

  >destination ,
;

\ -----------------------------------------------------------------------------

: lui-temporary ( literal -- )

  [ifdef] mips $FFFF0000 and [else] $FFFFF000 and [then]

  dup temporary-inhalt @ = temporary-bekannt @ and
  if
    drop
  else
    dup temporary-inhalt ! true temporary-bekannt !
    [ifdef] mips
      16 rshift $3C000000 or \ lui $0, 0
    [else]
      $00000037 or \ lui x0, 0
    [then]
    temporary-register-for-acrobatics >destination-i
    ,
  then
;

: ra-speicherlesen ( Opcode )
  expect-one-element

  ra-state ->tos @ state-literal =
  if \ Literals können mit Speicherlese-Opcodes bequem gehandhabt werden.

    [ifdef] mips tossigned16bitliteral? [else] tos12bitliteral? [then]
    if \ Kurzes Literal, passt direkt in einen Lade-Opcode mit Zero-Register.
      >imm-i
    else \ Langes Literal, passt nicht in den Opcode hinein. Kann aber jede Adresse mit zwei Opcodes laden.

      ra-state ->tos cell+ @
      [ifdef] mips
        dup $8000 and if $10000 + then \ Korrektur fürs negative Vorzeichen bei der Addition
      [else]
        dup  $800 and if  $1000 + then \ Korrektur fürs negative Vorzeichen bei der Addition
      [then]
      ( Opcode Literal* )

      dup lui-temporary \ Lui-Opcode generieren

      >imm-i \ Konstante für den Lade-Opcode einpflegen
      temporary-register-for-acrobatics >source1 \ und den im LUI-Opcode verwendeten Register einfügen.

    then
  else
    ra-state ->tos @ >source1
  then

  \ Zielregister in den Opcode einfügen

  eliminiere-tos
  befreie-tos

  get-free-register
  dup ra-state ->tos !

  >destination-i
  ,

  [ifdef] mips
    $00000000 , \ Insert NOP opcode for load delay slot.
  [then]
;

\ -----------------------------------------------------------------------------

: ra-speicherschreiben ( Opcode )
  expect-two-elements
  ra-state ->nos expect-element-in-register

  ra-state ->tos @ state-literal =
  if \ Literals können mit Speicherschreibe-Opcodes bequem gehandhabt werden.

    [ifdef] mips tossigned16bitliteral? [else] tos12bitliteral? [then]
    if \ Kurzes Literal, passt direkt in einen Schreib-Opcode mit Zero-Register.
      >imm-store
    else \ Langes Literal, passt nicht in den Opcode hinein. Kann aber jede Adresse mit zwei Opcodes beschreiben.

      ra-state ->tos cell+ @
      [ifdef] mips
        dup $8000 and if $10000 + then \ Korrektur fürs negative Vorzeichen bei der Addition
      [else]
        dup  $800 and if  $1000 + then \ Korrektur fürs negative Vorzeichen bei der Addition
      [then]
      ( Opcode Literal* )

      dup lui-temporary \ Lui-Opcode generieren

      >imm-store \ Konstante für den Schreib-Opcode einpflegen
      temporary-register-for-acrobatics >source1 \ und den im LUI-Opcode verwendeten Register einfügen.

    then
  else
    ra-state ->tos @ >source1
  then

  ra-state ->nos @ [ifdef] mips >destination-i [else] >source2 [then]
  ,

  eliminiere-tos eliminiere-tos
;

\ -----------------------------------------------------------------------------
\  Die ganzen vom Prozessor bereitgestellten und für Forth nützlichen Opcodes
\ -----------------------------------------------------------------------------

[ifdef] mips

  : +        ( x1 x2 -- x )        +  inline 2-foldable  allocator: $24000000 $00000021 ra-rechenlogik-plus         ; \ addiu $0, $0, 0  addu $0, $0, $0
  : -        ( x1 x1 -- x )        -  inline 2-foldable  allocator: $24000000 $00000023 ra-rechenlogik-minus        ; \ addiu $0, $0, 0  subu $0, $0, $0
  : xor      ( x1 x2 -- x )      xor  inline 2-foldable  allocator: $38000000 $00000026 ra-rechenlogik-xor          ; \ xori  $0, $0, 0  xor  $0, $0, $0
  : or       ( x1 x2 -- x )       or  inline 2-foldable  allocator: $34000000 $00000025 ra-rechenlogik-or           ; \ ori   $0, $0, 0  or   $0, $0, $0
  : and      ( x1 x2 -- x )      and  inline 2-foldable  allocator: $30000000 $00000024 ra-rechenlogik-and          ; \ andi  $0, $0, 0  and  $0, $0, $0

  : lshift   ( x1 x2 -- x )   lshift  inline 2-foldable  allocator: $00000000 $00000004 ra-rechenlogik-schieben     ; \ sll   $0, $0, 0  sllv $0, $0, $0
  : rshift   ( x1 x2 -- x )   rshift  inline 2-foldable  allocator: $00000002 $00000006 ra-rechenlogik-schieben     ; \ srl   $0, $0, 0  srlv $0, $0, $0
  : arshift  ( x1 x2 -- x )  arshift  inline 2-foldable  allocator: $00000003 $00000007 ra-rechenlogik-schieben     ; \ sra   $0, $0, 0  srav $0, $0, $0

  : slt      ( x1 x2 -- x )     slt          2-foldable  allocator: $28000000 $0000002A ra-rechenlogik-slt(u)       ; \ slti  $0, $0, 0  slt  $0, $0, $0
  : sltu     ( x1 x2 -- x )     sltu         2-foldable  allocator: $2C000000 $0000002B ra-rechenlogik-slt(u)       ; \ sltiu $0, $0, 0  sltu $0, $0, $0

  : c@signed ( addr  -- x )  c@signed inline             allocator: $80000000           ra-speicherlesen            ; \ lb $0, 0($0)
  : h@signed ( addr  -- x )  h@signed inline             allocator: $84000000           ra-speicherlesen            ; \ lh $0, 0($0)
  :  @       ( addr  -- x )   @       inline             allocator: $8C000000           ra-speicherlesen            ; \ lw $0, 0($0)
  : c@       ( addr  -- x )  c@       inline             allocator: $90000000           ra-speicherlesen            ; \ lbu $0, 0($0)
  : h@       ( addr  -- x )  h@       inline             allocator: $94000000           ra-speicherlesen            ; \ lhu $0, 0($0)

  : c!       ( x addr --  )  c!       inline             allocator: $A0000000           ra-speicherschreiben        ; \ sb $0, 0($0)
  : h!       ( x addr --  )  h!       inline             allocator: $A4000000           ra-speicherschreiben        ; \ sh $0, 0($0)
  :  !       ( x addr --  )   !       inline             allocator: $AC000000           ra-speicherschreiben        ; \ sw $0, 0($0)

  : *        ( x1 x2 -- x )   *        inline 2-foldable allocator: $70000002           ra-rechenlogik-muldiv       ; \ mul   $0, $0, $0

[else]

  : +        ( x1 x2 -- x )        +  inline 2-foldable  allocator: $00000013 $00000033 ra-rechenlogik-plus         ; \ addi x0, x0, 0  add x0, x0, x0
  : -        ( x1 x1 -- x )        -  inline 2-foldable  allocator: $00000013 $40000033 ra-rechenlogik-minus        ; \ addi x0, x0, 0  sub x0, x0, x0
  : xor      ( x1 x2 -- x )      xor  inline 2-foldable  allocator: $00004013 $00004033 ra-rechenlogik-xor          ; \ xori x0, x0, 0  xor x0, x0, x0
  : or       ( x1 x2 -- x )       or  inline 2-foldable  allocator: $00006013 $00006033 ra-rechenlogik-or           ; \ ori  x0, x0, 0  or  x0, x0, x0
  : and      ( x1 x2 -- x )      and  inline 2-foldable  allocator: $00007013 $00007033 ra-rechenlogik-and          ; \ andi x0, x0, 0  and x0, x0, x0

  : lshift   ( x1 x2 -- x )   lshift  inline 2-foldable  allocator: $00001013 $00001033 ra-rechenlogik-schieben     ; \ slli x0, x0, 0  sll x0, x0, x0
  : rshift   ( x1 x2 -- x )   rshift  inline 2-foldable  allocator: $00005013 $00005033 ra-rechenlogik-schieben     ; \ srli x0, x0, 0  srl x0, x0, x0
  : arshift  ( x1 x2 -- x )  arshift  inline 2-foldable  allocator: $40005013 $40005033 ra-rechenlogik-schieben     ; \ srai x0, x0, 0  sra x0, x0, x0

  : slt      ( x1 x2 -- x )     slt          2-foldable  allocator: $00002013 $00002033 ra-rechenlogik-slt(u)       ; \ slti  x0, x0, 0 slt  x0, x0, x0
  : sltu     ( x1 x2 -- x )     sltu         2-foldable  allocator: $00003013 $00003033 ra-rechenlogik-slt(u)       ; \ sltiu x0, x0, 0 sltu x0, x0, x0

  : c@signed ( addr  -- x )  c@signed inline             allocator: $00000003           ra-speicherlesen            ; \ lb x0, 0(x0)
  : h@signed ( addr  -- x )  h@signed inline             allocator: $00001003           ra-speicherlesen            ; \ lh x0, 0(x0)
  :  @       ( addr  -- x )   @       inline             allocator: $00002003           ra-speicherlesen            ; \ lw x0, 0(x0)
  : c@       ( addr  -- x )  c@       inline             allocator: $00004003           ra-speicherlesen            ; \ lbu x0, 0(x0)
  : h@       ( addr  -- x )  h@       inline             allocator: $00005003           ra-speicherlesen            ; \ lhu x0, 0(x0)

  : c!       ( x addr --  )  c!       inline             allocator: $00000023           ra-speicherschreiben        ; \ sb x0, 0(x0)
  : h!       ( x addr --  )  h!       inline             allocator: $00001023           ra-speicherschreiben        ; \ sh x0, 0(x0)
  :  !       ( x addr --  )   !       inline             allocator: $00002023           ra-speicherschreiben        ; \ sw x0, 0(x0)

  : *        ( x1 x2 -- x )   *        inline 2-foldable allocator: $02000033           ra-rechenlogik-muldiv       ; \ mul    x0, x0, x0
  : mulh     ( x1 x2 -- x )  m* nip    inline 2-foldable allocator: $02001033           ra-rechenlogik-muldiv       ; \ mulh   x0, x0, x0
  : mulhu    ( x1 x2 -- x ) um* nip    inline 2-foldable allocator: $02003033           ra-rechenlogik-muldiv       ; \ mulhu  x0, x0, x0
  : /        ( x1 x2 -- x )  /         inline 2-foldable allocator: $02004033           ra-rechenlogik-muldiv       ; \ div    x0, x0, x0
  : divu     ( x1 x2 -- x ) u/mod nip  inline 2-foldable allocator: $02005033           ra-rechenlogik-muldiv       ; \ divu   x0, x0, x0
  : mod      ( x1 x2 -- x )   mod      inline 2-foldable allocator: $02006033           ra-rechenlogik-muldiv       ; \ rem    x0, x0, x0
  : remu     ( x1 x2 -- x ) u/mod drop inline 2-foldable allocator: $02007033           ra-rechenlogik-muldiv       ; \ remu   x0, x0, x0

[then]

\ -----------------------------------------------------------------------------
\  RA Stackjongleure
\ -----------------------------------------------------------------------------

: dup ( x -- x x ) dup inline 1-foldable

allocator:
 expect-one-element
 befreie-tos
 ra-state ->nos 2@ ra-state ->tos 2!
;

: swap ( x1 x2 -- x2 x1 ) swap inline 2-foldable

allocator:
 expect-two-elements
 ra-state ->nos 2@
    ra-state ->tos 2@
    ra-state ->nos 2!
 ra-state ->tos 2!
;

: drop ( x -- ) drop inline 1-foldable

allocator:
  ra-state ->tos @ state-unknown =
  if
    [ifdef] mips
      $24000004 psp-register >destination-i psp-register >source1 , \ addiu $9, $9, 0004
    [else]
      $00400013 psp-register >destination   psp-register >source1 , \ addi x9, x9, 4
    [then]
  else
    eliminiere-tos
  then
;

: rdrop ( -- ) ( R: x -- ) rdrop inline

allocator:
  ra-state ->tor @ state-unknown =
  if
    [ifdef] mips
      $24000004 rsp-register >destination-i rsp-register >source1 , \ addiu $2, $2, 0004
    [else]
      $00400013 rsp-register >destination   rsp-register >source1 , \ addi x2, x2, 4
    [then]
  else
    eliminiere-tor
  then
;

: >r ( x -- ) ( R: -- x ) >r inline

allocator:
  expect-one-element
  befreie-tor
  ra-state ->tos 2@ ra-state ->tor 2!
  eliminiere-tos
;

: r@ ( -- x ) ( R: x -- x ) r@ inline

allocator:
  expect-one-r-element
  befreie-tos
  ra-state ->tor 2@ ra-state ->tos 2!
;

: r> ( -- x ) ( R: x -- ) r> inline

allocator:
  expect-one-r-element
  befreie-tos
  ra-state ->tor 2@ ra-state ->tos 2!
  eliminiere-tor
;

: i ( -- i ) i inline

allocator:
  befreie-tos
  loop-index-register ra-state ->tos ! \ Der Schleifen-Index-Register
;

\ -----------------------------------------------------------------------------
\   Tick the flags of a definition
\ -----------------------------------------------------------------------------

:  'f  ( -- flags ) token find nip ;
: ['f] ( -- flags )  'f 0-foldable ;

\ -----------------------------------------------------------------------------
\  Compiler aus Mecrisp-Ice mit Konstantenfaltung
\ -----------------------------------------------------------------------------

: on  ( addr -- ) true swap ! ;
: off ( addr -- ) false swap ! ;

true variable constantfoldingpointer

\ -----------------------------------------------------------------------------

: one-constant->stackmodel ( x -- )
    befreie-tos
    state-literal ra-state ->tos !
                  ra-state ->tos cell+ !
;

: flushconstants ( n*x count -- {n-1}*x count-1 ) \ Recursive to write them out in reverse order
  dup if \ Do nothing if count is zero
    dup    1 u> if 1- swap >r recurse r> swap then
    swap   dup flag-literator add-to-inline-cache   one-constant->stackmodel
  then
;

: constants->stackmodel ( n -- )  flushconstants drop ;

\ -----------------------------------------------------------------------------

: flushback ( element-on-d-stack -- element-on-d-stack )
  dup cached-d-elements = if exit then

  ra-state over element @ state-literal =
  if
    ra-state over element cell+ @
    >r
      1+ recurse 1-
    r> swap

    ['] drop ['f] drop add-to-inline-cache \ Flushed back constants need to be dropped at replay of the inline cache, too.
    eliminiere-tos \ Element von oben vernichten.
  then
;

: stackmodel->constants ( -- ) 0 flushback drop ; \ Flush back constants from the stack model to the data stack.

\ -----------------------------------------------------------------------------

: kompilator ( addr flags -- )

  dup flag-inlinecache and
  if \ Wenn die Optimiersequenz geschrieben worden ist, ist auch mindestens ein Element darin vorhanden.
    drop ( addr ) skipdefinition

          dup @ ( Cache-Start Zahl-der-Elemente )
          swap 4 + swap
          0 do
            >r
            r@     @   \ Addr
            r@ 4 + @   \ Flags
            recurse
            r> 8 +
          loop
          drop

  exit then

  constantfoldingpointer @ true =  \ If it is not set, initialise constant folding pointer
  if depth    2 - constantfoldingpointer ! then \ Do not include the values of parse-name

  dup flag-literator and if drop exit then \ Literator-Konstanten einfach für die Faltung auf dem Stack liegen lassen.

          2>r \ Move addr and flags out of the way

          \ Calculate how many constants are available
          depth                       \ Calculate how many
          constantfoldingpointer @ -  \ constants are available now
          ( #constants R: xt imm-flag ) \ Number of constants available now on stack


          dup r@ flag-foldabilitymask and u>= \ Check if there are enough constants left
              r@ flag-foldable and 0<> and    \ Check if the current definition is foldable

          r@ flag-ramallot and 0<> or \ Ramallot is foldable, too, but the lower bits have a different meaning.

          if \ Fold it !
            drop
            2r> drop execute
          else \ Not foldable or not enough constants available

            r@ flag-allocator and
            if
            \ Does the definition carry code which allows optimisations based on the stack model ?

              constants->stackmodel          \ Move remaining constants into the stack model

              2r@ nip flag-finished and
              if
                2r> drop skipdefinition execute \ Definition will be finalised in ;
              else
                2r@ add-to-inline-cache        \ Add definition to inline cache
                2r> drop skipdefinition execute \ Allocator entry is at the end of the definition
                depth constantfoldingpointer !   \ Update constant folding pointer to current location on stack
                stackmodel->constants             \ and flush back constants that were temporarily stored in the stack model.
              then

            else

              \ Write the constants and flush all pending register operations in order to reach canonical stack state
              constants->stackmodel
              tidyup-ra

              \ Add definition to inline cache:
              \ 2r@ add-to-inline-cache
              \ No inline cache for definitions complied the classic way. It won't give any optimisation benefits, but waste space.
              squash-inline-cache

              \ No folding allowed over classic compilation
              constantfoldingpointer on

              2r>

              \ Do classic compilation
              dup flag-immediate and
              if   drop execute
              else flag-inline and if inline, else call, then
              then

            then
          then
;

false variable rock'n'roll?

: interpret

  rock'n'roll? @ not if interpret exit then

    begin
        token
        dup
    while
      constantfoldingpointer @ true =  \ If it is not set, initialise constant folding pointer
      if depth    2 - constantfoldingpointer ! then \ Do not include the values of parse-name

      2dup 2>r ( addr len R: addr len )
      find \ Try to find the definition in dictionary
      over 0<>
      if ( addr flags ) \ Found.

        state @
        if    \ Compile mode
         2rdrop
         kompilator
        else  \ Execute mode
          flag-compileonly and flag-compileonly = if 2r> type ."  is compile only." cr quit else 2rdrop then
          constantfoldingpointer on
          execute
        then

      else ( addr flags R: addr len ) \ Not found ? Perhaps it is a number.
        2drop
        2r@ number 0= if space 2r> type ."  not found." cr quit else 2rdrop then \ Leave the literal(s) on the stack
      then

    repeat
    2drop
;

: evaluate ( addr len -- )

  source 2>r
  >in @ >r
  0 >in !

  setsource interpret

  r> >in !
  2r> setsource

;

\ -----------------------------------------------------------------------------
\  Die Quit-Schleife für den Akrobatikcompiler
\ -----------------------------------------------------------------------------

hook-quit @ constant vanilla-quit

: acro-quit ( -- )

  \ Das wird schon von dem internen Quit-Teil erledigt:
  \ begin depth while drop repeat \ Datenstack aufräumen
  \ begin rdepth while rdrop repeat \ Returnstack aufräumen
  \ false state !

  \ Hier nur erledigen, was nicht schon von dem Quit-Vorspann im Kern erledigt wird.

  \ KANNWEG: Mache ich in : wo es sinnvoller ist.
  \ init-register-allocator
  \ constantfoldingpointer on

  begin
    query
    interpret
    ."  ok." cr
  again
;

'f words 0< 0= constant flag-invisible

: classic-find ( address length -- Code-Adresse Flags )
  \ This is a special find to make the acro-only flagged definitions invisible while using the classic compiler.

  2>r

  0 0 \ Not found.

  dictionarystart
  begin
    ( Code-Addr Flags Dictionary-Chain R: addr len )

    dup 4 + @ flag-invisible <>
    if
    dup 4 + @ flag-allocator flag-acro-only or and 0=
    if

      dup 8 + count 2r@ compare
      if
        -rot 2drop
        dup 8 + skipstring
        over 4 + @ \ Flags
        rot

        dup addrinram? if drop 2rdrop exit then
      then

    then
    then

    dictionarynext
  until
  drop

  2rdrop
;

: acro-on  ( ... -- ) rock'n'roll? @ not if rock'n'roll? on  [']        (find) hook-find ! ['] acro-quit hook-quit ! cr quit then ;
: acro-off ( ... -- ) rock'n'roll? @     if rock'n'roll? off ['] classic-find  hook-find !  vanilla-quit hook-quit ! cr quit then ;

\ -----------------------------------------------------------------------------
\   Definitionen definieren
\ -----------------------------------------------------------------------------

\ Den Inline-Cache in den Definitionen-Compiler einhängen

0 variable datenstacksicherung

: ; ( -- )

  postpone ; immediate inline \ immediate + inline = compile-only

allocator:

  sp@ datenstacksicherung @ <> if ." Stack not balanced." cr quit then

  ra-state ->tor @ link-register = \ TOR still in link register ? Enjoy direkt return !
  if
    eliminiere-tor \ Den Linkregister aus dem Allokator abmelden
    tidyup-ra       \ Alles andere aufräumen
    [ifdef] mips
      $03E00008 ,     \ jr $zero, $31, $zero
      $00000000 ,      \ nop for branch delay slot
    [else]
      $00008067 ,        \ jalr   zero, 0 (x1)
    [then]
  else
    \ Canonical fallback with classic pop lr ret sequence.
    tidyup-ra
    postpone exit
  then

  write-inline-cache

  smudge
  false state !

  [ flag-finished setflags ]
;

\  Creatures of this one are incompatible with the classic compiler:
\  : postpone ( -- )
\
\    token
\
\    2dup find over 0= if 2drop type ."  not found." cr quit then 2nip
\
\    swap literal, literal,
\    ['] kompilator call,
\
\  immediate inline acro-only ;

: : ( -- )

  \ Neue Definition: Auf jeden Fall den Inline-Cache frisch leeren !
  0 inline-cache-count !

  init-register-allocator
  link-register ra-state ->tor ! \ Link register im Allokator anmelden, damit ich nicht unbedingt eine push lr Sequenz schreiben muss.

  \ Die üblichen Aufgaben von : abarbeiten, dabei aber eben keine push lr Sequenz schreiben.

  sp@ datenstacksicherung !

  (create)

  true state !

  constantfoldingpointer on

acro-only ;

\ -----------------------------------------------------------------------------
\   Los geht's !
\ -----------------------------------------------------------------------------

.s
acro-on
.s

\ -----------------------------------------------------------------------------
\   Jetzt werden viele kleine Kerndefinitionen noch einmal aus den Allokator-
\   Opcode-Einzelteilen zusammengefügt, damit sie über den Inline-Cache vererbt
\   weiter optimiert werden können.
\ -----------------------------------------------------------------------------

maximum-inlining \ Volldampf voraus für die kommenden grundlegenden Definitionen.

\ -----------------------------------------------------------------------------

: u>=    ( x1 x2 -- ? )       sltu -1 +        inline 2-foldable acro-only ;
: u<     ( x1 x2 -- ? )       sltu -1 + -1 xor inline 2-foldable acro-only ;
: u>     ( x1 x2 -- ? ) swap  sltu -1 + -1 xor inline 2-foldable acro-only ;
: u<=    ( x1 x2 -- ? ) swap  sltu -1 +        inline 2-foldable acro-only ;

:  >=    ( x1 x2 -- ? )       slt  -1 +        inline 2-foldable acro-only ;
:  <     ( x1 x2 -- ? )       slt  -1 + -1 xor inline 2-foldable acro-only ;
:  >     ( x1 x2 -- ? ) swap  slt  -1 + -1 xor inline 2-foldable acro-only ;
:  <=    ( x1 x2 -- ? ) swap  slt  -1 +        inline 2-foldable acro-only ;

: <>     ( x1 x2 -- ? ) xor 1 sltu -1 +        inline 2-foldable acro-only ;
: =      ( x1 x2 -- ? ) xor 1 sltu -1 + -1 xor inline 2-foldable acro-only ;

: 0=     ( x -- ? )         1 sltu -1 + -1 xor inline 1-foldable acro-only ;
: 0<>    ( x -- ? )         1 sltu -1 +        inline 1-foldable acro-only ;
: 0<     ( x -- ? )         31 arshift         inline 1-foldable acro-only ;

: over  ( x1 x2 -- x1 x2 x1 )    >r dup r> swap  inline 2-foldable acro-only ;
: tuck  ( x1 x2 -- x2 x1 x2 )    swap over       inline 2-foldable acro-only ;
: nip   ( x1 x2 -- x2 )          swap drop       inline 2-foldable acro-only ;
: rot   ( x1 x2 x3 -- x2 x3 x1 ) >r swap r> swap        3-foldable acro-only ;
: -rot  ( x1 x2 x3 -- x3 x1 x2 ) swap >r swap r>        3-foldable acro-only ;

: s>d    ( n -- d )   dup 0<      inline 1-foldable acro-only ;
: even   ( x1 -- x2 ) dup 1 and + inline 1-foldable acro-only ;
: 1+     ( x -- x+1 )  1 +        inline 1-foldable acro-only ;
: 1-     ( x -- x-1 )  1 -        inline 1-foldable acro-only ;
: 2+     ( x -- x+2 )  1 +        inline 1-foldable acro-only ;
: 2-     ( x -- x-2 )  1 -        inline 1-foldable acro-only ;
: cell+  ( x -- x+4 )  4 +        inline 1-foldable acro-only ;
: negate ( x -- -x )  -1 xor 1 +  inline 1-foldable acro-only ;
: not    ( x -- ~x )  -1 xor      inline 1-foldable acro-only ;
: invert ( x -- ~x )  -1 xor      inline 1-foldable acro-only ;

: shr    ( x1 -- x2 )  1  rshift  inline 1-foldable acro-only ;
: shl    ( x1 -- x2 )  1  lshift  inline 1-foldable acro-only ;
: 2*     ( x1 -- x2 )  1  lshift  inline 1-foldable acro-only ;
: 2/     ( x1 -- x2 )  1 arshift  inline 1-foldable acro-only ;
: cells  ( x1 -- x2 )  2  lshift  inline 1-foldable acro-only ;

: ror    ( x1 -- x2 ) dup 31 lshift swap 1 rshift or  inline 1-foldable acro-only ;
: rol    ( x1 -- x2 ) dup 31 rshift swap 1 lshift or  inline 1-foldable acro-only ;

: abs   ( n -- u ) dup 31 arshift dup >r + r> xor  inline 1-foldable acro-only ;
: bic   ( x1 x2 -- x3 ) not and                    inline 2-foldable acro-only ;

[ifndef] mips

\ In dieser Reihenfolge mit einem Swap am Ende ist es kürzer, weil das High-Ergebnis direkt in x6 geladen werden kann.

: um*   ( u1 u2 -- ud )    over over * >r mulhu r> swap    inline 2-foldable acro-only ;
:  m*   ( n1 n2 -- d )     over over * >r mulh  r> swap    inline 2-foldable acro-only ;

: u/mod ( u1 u2 -- u3 u4 ) over over remu >r divu r> swap  inline 2-foldable acro-only ;
:  /mod ( n1 n2 -- n3 n4 ) over over mod  >r /    r> swap  inline 2-foldable acro-only ;

[then]

\ -----------------------------------------------------------------------------

: +!    ( mask addr -- ) dup >r  @ +   r>  ! acro-only ;
: h+!   ( mask addr -- ) dup >r h@ +   r> h! acro-only ;
: c+!   ( mask addr -- ) dup >r c@ +   r> c! acro-only ;

: bis!  ( mask addr -- ) dup >r  @      or  r>  ! acro-only ;
: bic!  ( mask addr -- ) dup >r  @ swap bic r>  ! acro-only ;
: xor!  ( mask addr -- ) dup >r  @      xor r>  ! acro-only ;

: hbis! ( mask addr -- ) dup >r h@      or  r> h! acro-only ;
: hbic! ( mask addr -- ) dup >r h@ swap bic r> h! acro-only ;
: hxor! ( mask addr -- ) dup >r h@      xor r> h! acro-only ;

: cbis! ( mask addr -- ) dup >r c@      or  r> c! acro-only ;
: cbic! ( mask addr -- ) dup >r c@ swap bic r> c! acro-only ;
: cxor! ( mask addr -- ) dup >r c@      xor r> c! acro-only ;

: bit@  ( mask addr -- ? )  @ and 0<> acro-only ;
: hbit@ ( mask addr -- ? ) h@ and 0<> acro-only ;
: cbit@ ( mask addr -- ? ) c@ and 0<> acro-only ;

\ -----------------------------------------------------------------------------

: 2dup  ( x1 x2 -- x1 x2 x1 x2 )             over over               2-foldable acro-only ;
: 2drop ( x1 x2 -- )                         drop drop               2-foldable inline acro-only ;
: 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 )       rot >r rot r>           4-foldable acro-only ;
: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) >r >r 2dup r> r> 2swap  4-foldable acro-only ;
: 2nip  ( x1 x2 x3 x4 -- x3 x4 )             >r >r 2drop r> r>       4-foldable acro-only ;

: 2>r    ( x1 x2 -- ) ( R: -- x1 x2 )       SWAP >R >R             inline acro-only ;
: 2r@    ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) R> R> 2DUP >R >R SWAP  inline acro-only ;
: 2r>    ( -- x1 x2 ) ( R: x1 x2 -- )       R> R> SWAP             inline acro-only ;
: 2rdrop ( -- )       ( R: x1 x2 -- )       rdrop rdrop            inline acro-only ;

: 2@  ( a-addr -- ud|d ) DUP CELL+ @ SWAP @   inline acro-only ;
: 2!  ( ud|d a-addr -- ) SWAP OVER ! CELL+ !  inline acro-only ;

: d0<   ( d -- ? ) nip 0< inline 2-foldable acro-only ;
: d0=   ( d -- ? ) or  0= inline 2-foldable acro-only ;

: d=    ( d1 d2 -- ? ) ( x1 x2 x3 x4 -- ? ) rot xor ( x1 x3 x ) >r xor r> or 0=  4-foldable acro-only ;
: d<>   ( d1 d2 -- ? ) ( x1 x2 x3 x4 -- ? ) rot xor ( x1 x3 x ) >r xor r> or 0<> 4-foldable acro-only ;

: dshl  ( x1 x2 -- x1' x2' ) swap dup 31 rshift >r 1  lshift swap 1 lshift r> or       2-foldable acro-only ;
: d2*   ( x1 x2 -- x1' x2' ) swap dup 31 rshift >r 1  lshift swap 1 lshift r> or       2-foldable acro-only ;
: d2/   ( x1 x2 -- x1' x2' )      dup 31 lshift >r 1 arshift swap 1 rshift r> or swap  2-foldable acro-only ;
: dshr  ( x1 x2 -- x1' x2' )      dup 31 lshift >r 1  rshift swap 1 rshift r> or swap  2-foldable acro-only ;

\ -----------------------------------------------------------------------------
\  Ganz schön komplizierte Kopfverrenkung !

: dnegate ( d -- -d )

  not swap not ( ~high ~low )

  dup >r  ( ~high ~low   R: ~low )
  1 +     ( ~high ~low+1 R: ~low )
  dup r>  ( ~high ~low+1 ~low+1 ~low )
  sltu    ( ~high ~low+1 c )
  >r swap r>
  +

2-foldable acro-only ;


: d+ ( x0 x1 y0 y1 -- z0 z1 )

swap >r   ( x0 x1 y1 R: y0 )
+         ( x0 x1+y1 R: y0 )
swap r@   ( x1+y1 x0 y0 R: y0 )
+         ( x1+y1 x0+y0 R: y0 )
swap over ( x0+y0 x1+y1 x0+y0 R: y0 )
r>        ( x0+y0 x1+y1 x0+y0 y0 )
sltu      ( x0+y0 x1+y1 c )
+         ( x0+y0 x1+y1+c )

4-foldable acro-only ;


: d- ( x0 x1 y0 y1 -- z0 z1 )

swap >r   ( x0 x1 y1 R: y0 )
-         ( x0 x1-y1 R: y0 )
swap      ( x1-y1 x0 R: y0 )
dup r@    ( x1-y1 x0 x0 y0 R: y0 )
sltu      ( x1-y1 x0 c R: y0 )
swap      ( x1-y1 c x0 R: y0 )
r> -      ( x1-y1 c x0-y0 )
>r -      ( x1-y1-c R: x0-y0 )
r> swap   ( x0-y0 x1-y1-c )

4-foldable acro-only ;

\ -----------------------------------------------------------------------------
\  Common string tools which are easily optimised:

: count ( addr -- addr+1 len ) dup 1 + swap c@ inline acro-only ;
: skipstring ( cstr-addr -- a-addr ) count +   dup 1 and +   dup 2 and + acro-only ;

\ -----------------------------------------------------------------------------

normal-inlining

: welcome-to-acrobatics ( -- )
  ." Acrobatics - A register allocator for Mecrisp-Quintus"
;

[ifdef] init
  : init ( -- ) init welcome-to-acrobatics acro-on ;
[else]
  : init ( -- )      welcome-to-acrobatics acro-on ;
[then]

\ -----------------------------------------------------------------------------
