
\ -----------------------------------------------------------------------------
\
\    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 for RISC-V 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.
\                    Please note this is worse than the plain
\                    Forth core as because of redefinitions, the classic
\                    compiler won't find its optimisation cases anymore.
\
\    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
\
\    Acrobatics prints a message "*InCa" if a definition is accepted for Inline-Cache.
\
\    You can mix freely, with individual options for each definition separately.
\
\ -----------------------------------------------------------------------------

compiletoflash

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

: >source1     ( opcode register -- opcode* ) 15 lshift or 2-foldable ;
: >source2     ( opcode register -- opcode* ) 20 lshift or 2-foldable ;
: >destination ( opcode register -- opcode* )  7 lshift or 2-foldable ;

\ -----------------------------------------------------------------------------
\  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.
\ ---------------------------
              3 , 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
\ ---------------------------
   3 ,                \ For performance reasons, the first register should be the canonical TOS register. Results default to this one.
  16 ,
  17 ,
  18 ,
  19 ,
  20 ,
  21 ,
  22 ,
  23 ,
  24 ,
  25 ,
  26 ,
  27 ,
\ ---------------------------

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

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

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
\ -----------------------------------------------------------------------------

  \ : 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 ;
  \
  \ : om $FE00707F and hex. ; \ Alle drei Registerfelder vom Opcode abtrennen
  \
  \ : ,  cr here disasm-$ ! , disasm-step ;
  \ : registerliteral,   cr ." Regliteral, " h.s registerliteral, h.s ;

\ -----------------------------------------------------------------------------
\   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 ( -- )
  $00020213 opcode-adjust-stack ! \ addi x4, x4, 0 Opcode
  $00022023 opcode-store-stack  ! \ sw x0, 0(x4) Opcode
;

: select-opcodes-for-r-tidyup ( -- )
  $00010113 opcode-adjust-stack ! \ addi x2, x2, 0 Opcode
  $00012023 opcode-store-stack  ! \ sw x0, 0(x2) Opcode
;

\ Wandelt eine 12-Bit-Konstante in eine passende Bitmaske für den Store-Opcode um

: >imm-s ( x -- x* ) \ Wandelt eine 12-Bit-Konstante in die passenden Bitfelder für einen Store-Opcode um.
  dup    $1F and  7 lshift
  swap  $FE0 and 20 lshift
  or
1-foldable ;

: 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 >source2 ,
  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 >source2
    i cells >imm-s or \ 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
    $00006033 swap >destination \ or x0, x0, x0
              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"
        $00022183 , \ lw     x3, 0 (x4)
        $00420213 , \ addi   x4, x4, 4
        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 !

\ -----------------------------------------------------------------------------
\  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 ;


  \  \ 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
  \      cell+ dup @ dup >r hex.
  \      cell+ dup @ hex. r> name. cr
  \    loop
  \    drop
  \    cr
  \  ;

: 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 !
    $00012003 swap >destination , \ lw     x0, 0 (x2)
    $00410113                   , \ addi   x2, x2, 4
  then
;

: expect-one-element ( -- )
  ra-state ->tos @ state-unknown =
  if
    get-free-register
    dup ra-state ->tos !
    $00022003 swap >destination , \ lw     x0, 0 (x4)
    $00420213                   , \ addi   x4, x4, 4
  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 !
    $00022003 swap >destination , \ lw     x0, 0 (x4)

    get-free-register
    dup ra-state ->nos !
    $00422003 swap >destination , \ lw     x0, 4 (x4)

    $00820213                   , \ addi   x4, x4, 8

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

    ra-state ->nos @ state-unknown =
    if
      get-free-register
      dup ra-state ->nos !
      $00022003 swap >destination , \ lw     x0, 0 (x4)
      $00420213                   , \ addi   x4, x4, 4
    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

  $FFC10113 , \ addi   x2, x2, -4
  $00112023 , \ sw     x1, 0 (x2)

  flag-allocator setflags

immediate ;

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

: 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
;

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

: ra-rechenlogik-gemeinsam ( 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-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-gemeinsam
;

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

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

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

: 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-gemeinsam
;

: 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-gemeinsam
;

: 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-gemeinsam
;

: 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-gemeinsam
;

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

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

: 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 -- )

  $FFFFF000 and

  dup temporary-inhalt @ = temporary-bekannt @ and
  if
    drop
  else
    dup temporary-inhalt ! true temporary-bekannt !
    $00000037 or \ lui x0, 0
    temporary-register-for-acrobatics >destination
    ,
  then
;

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

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

    tos12bitliteral?
    if \ Kurzes Literal, passt direkt in einen Lade-Opcode mit Zero-Register.
      >source2
    else \ Langes Literal, passt nicht in den Opcode hinein. Kann aber jede Adresse mit zwei Opcodes laden.

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

      dup lui-temporary \ Lui-Opcode generieren

      >source2 \ 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
  ,
;

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

: 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.

    tos12bitliteral?
    if \ Kurzes Literal, passt direkt in einen Schreib-Opcode mit Zero-Register.
      >imm-s or
    else \ Langes Literal, passt nicht in den Opcode hinein. Kann aber jede Adresse mit zwei Opcodes beschreiben.

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

      dup lui-temporary \ Lui-Opcode generieren

      >imm-s or \ 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 @ >source2
  ,

  eliminiere-tos eliminiere-tos
;

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

: +        ( 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 )  < not 1+        2-foldable  allocator: $00002013 $00002033 ra-rechenlogik-slt(u)       ; \ slti  x0, x0, 0 slt  x0, x0, x0
: sltu     ( x1 x2 -- x ) u< not 1+        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

\ -----------------------------------------------------------------------------
\  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
    $00420213 , \ Opcode addi x4, x4, 4
  else
    eliminiere-tos
  then
;

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

allocator:
  ra-state ->tor @ state-unknown =
  if
    $00410113 , \ Opcode addi x2, x2, 4
  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
  8 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
;

: ice-interpret
    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
;

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

hook-quit @ constant vanilla-quit

: ice-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
    ice-interpret
    ." ok." cr
  again
;

false variable rock'n'roll?

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

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

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

0 variable datenstacksicherung

: : ( -- )

  rock'n'roll? @
  if

    \ 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

  else
    :
  then
;

: ; ( -- )

  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
    $00008067 ,      \ jalr   zero, 0 (x1)
  else
    \ Canonical fallback with classic pop lr ret sequence.
    tidyup-ra
    postpone exit
  then

  write-inline-cache

  smudge
  false state !

  [ flag-finished setflags ]
;

\ -----------------------------------------------------------------------------
\   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 ;
: u<     ( x1 x2 -- ? )       sltu -1 + -1 xor inline 2-foldable ;
: u>     ( x1 x2 -- ? ) swap  sltu -1 + -1 xor inline 2-foldable ;
: u<=    ( x1 x2 -- ? ) swap  sltu -1 +        inline 2-foldable ;

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

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

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

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

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

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

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

: abs   ( n -- u ) dup 31 arshift dup >r + r> xor  inline 1-foldable ;
: bic   ( x1 x2 -- x3 ) not and                    inline 2-foldable ;
: count ( addr -- addr+1 len ) dup 1 + swap c@     inline ;

\ 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 ;
:  m*   ( n1 n2 -- d )     over over * >r mulh  r> swap    inline 2-foldable ;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

\ -----------------------------------------------------------------------------
\  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 ;


: 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 ;


: 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 ;

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

normal-inlining

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

: init ( -- ) init welcome-to-acrobatics acro-on ;

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