\
\    Mecrisp-Across - A Forth cross compiler for small MSP430 microcontrollers
\    Copyright (C) 2016  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/>.
\


\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
\  4. Teil: Aufräumroutine zurück in den Grundzustand
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\


create kanonischer-zustand-tos-im-register

     reg6 , \ TOS
  unknown , \ NOS
  unknown , \ 3OS
  unknown , \ 4OS
  unknown , \ 5OS
  unknown , \ 6OS

r-unknown , \ TOR
r-unknown , \ NOR
r-unknown , \ 3OR
r-unknown , \ 4OR

create kanonischer-zustand-tos-auf-stack

  unknown , \ TOS
  unknown , \ NOS
  unknown , \ 3OS
  unknown , \ 4OS
  unknown , \ 5OS
  unknown , \ 6OS

r-unknown , \ TOR
r-unknown , \ NOR
r-unknown , \ 3OR
r-unknown , \ 4OR

\ Standardmäßig sei Tos in r6. Erstmal zur Probe der verschiedenen Möglichkeiten :-)

0 cells constant kanon-tos
1 cells constant kanon-nos
2 cells constant kanon-3os
3 cells constant kanon-4os
4 cells constant kanon-5os
5 cells constant kanon-6os

6 cells constant kanon-tor
7 cells constant kanon-nor
8 cells constant kanon-3or
9 cells constant kanon-4or



kanonischer-zustand-tos-im-register variable kanonischer-zustand
\ kanonischer-zustand-tos-auf-stack variable kanonischer-zustand


: r-tidyup ( Zustandsvariable -- )

  dup @ r-unknown <> if
 
    dup @ bytebit and if dup expect-element-in-register then \ Bytesperre
    
    dup @ $1200 or ( Zustandsvariable Opcode )   \ Push-Opcode zusammenbauen
    over @ indexed? if over cell+ @ swap konstantengenerator-push else image, then \ Adresse oder Literal anfügen
    
    r-unknown swap !
    
  else drop then
;

: d-tidyup ( Zustandsvariable -- )

  dup @ unknown <> if
 
    dup @ bytebit and if dup expect-element-in-register then \ Bytesperre
 
    $8324 image, \ decd r4 
    
    dup @ operand-for-double $4084 or ( Zustandsvariable Opcode )   \ mov ..., x(r4)
    over @ indexed? if over cell+ @ swap konstantengenerator else image, then \ Adresse oder Literal anfügen
    $0000 image,
    
    unknown swap !
    
  else drop then
;




: d-tidyup-ohne-decd ( Zustandsvariable -- )
 
    dup @ bytebit and if dup expect-element-in-register then \ Bytesperre
     
    dup @ operand-for-double $4084 or ( Zustandsvariable Opcode )   \ mov ..., 0(r4)
    over @ indexed? if over cell+ @ swap konstantengenerator else image, then \ Adresse oder Literal anfügen
    
    unknown swap !   
;



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

: d-tidyup-flush ( ... Anzahl -- )
  \ Habe jetzt die Zahl der Elemente, die auf den Stack geschrieben werden sollen.
  \ Zunächst einen passenden sub-Opcode schreiben:
  dup if
    dup 2* $8034 konstantengenerator \ sub #Anzahl, r4
  then
  
  \ Jetzt die Elemente abarbeiten.
  
  0 ?do \ Schleife über die Elemente  
    d-tidyup-ohne-decd
    i 2* image,
  loop
;




: init-ra ( -- ) \ Setzt alles wieder auf den Ausgangszustand zurück.

  kanonischer-zustand @ kanon-tos + @ state-tos !
  kanonischer-zustand @ kanon-nos + @ state-nos !
  kanonischer-zustand @ kanon-3os + @ state-3os !
  kanonischer-zustand @ kanon-4os + @ state-4os !
  kanonischer-zustand @ kanon-5os + @ state-5os !
  kanonischer-zustand @ kanon-6os + @ state-6os !

  kanonischer-zustand @ kanon-tor + @ state-tor !
  kanonischer-zustand @ kanon-nor + @ state-nor !
  kanonischer-zustand @ kanon-3or + @ state-3or !
  kanonischer-zustand @ kanon-4or + @ state-4or !  
  
  0 flagtrampolin !
  0 sprungtrampolin !
;


: free-6os-element ( -- )
  state-6os d-tidyup
;

: befreie-tos ( -- )
  free-6os-element              \ Unterstes Element befreien
  
  state-5os 2@  state-6os 2!    \ Die anderen Elemente nachrutschen lassen
  state-4os 2@  state-5os 2!
  state-3os 2@  state-4os 2!
  state-nos 2@  state-3os 2!
  state-tos 2@  state-nos 2!
  
  unknown state-tos !           \ TOS ist jetzt in einem unbekanntem Zustand
;


: tos-elementkopie ( -- ) \ Den Inhalt des TOS-Registers in einen neuen, freien Register kopieren.
  $4000
  state-tos @ 8 lshift or
  eliminiere-tos
  befreie-tos
  get-free-register dup state-tos ! or
  image,  
;

: make-tos-changeable ( -- ) \ Das Ziel ist immer ein Register. Muss also nur Vergleichen, ob dieser schoneinmal woanders auftaucht.
   
  state-tos @ $F and state-nos @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-3os @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-4os @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-5os @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-6os @ $F and = if tos-elementkopie exit then
  
  state-tos @ $F and state-tor @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-nor @ $F and = if tos-elementkopie exit then
  state-tos @ $F and state-3or @ $F and = if tos-elementkopie exit then  
  state-tos @ $F and state-4or @ $F and = if tos-elementkopie exit then    
;


: registereinmaligkeit ( Zustandsvariable -- )

  \ Zuerst auf den Stack liegende Elemente aussortieren.  
  dup @   unknown = if drop exit then
  dup @ r-unknown = if drop exit then
  
  \ Anschließend Literals & Fetch-Absolute aussortieren.
  \ Das ist hier aber nicht nötig, weil alles, was nicht auf dem Stack lag beim Einsprung hier bereits in Register geladen worden ist.
    
  \ Im Prinzip brauche ich nur zu checken, ob der Register woanders nochmal auftaucht. Falls ja, muss ich einen neuen freien Register anfordern und einen Registerwechsel durchführen.
  >r  \ Achte darauf: Nicht mit sich selbst vergleichen !

    false \ Erstmal kein Wechsel nötig
   
    r@ state-4or <> if   r@ @  state-4or @ = or    then
    r@ state-3or <> if   r@ @  state-3or @ = or    then
    r@ state-nor <> if   r@ @  state-nor @ = or    then
    r@ state-tor <> if   r@ @  state-tor @ = or    then
   
    r@ state-6os <> if   r@ @  state-6os @ = or    then
    r@ state-5os <> if   r@ @  state-5os @ = or    then    
    r@ state-4os <> if   r@ @  state-4os @ = or    then
    r@ state-3os <> if   r@ @  state-3os @ = or    then    
    r@ state-nos <> if   r@ @  state-nos @ = or    then
    r@ state-tos <> if   r@ @  state-tos @ = or    then

    if \ Ein Registerwechsel für dieses Element ist nötig.
      \ ." Registerwechsel wegen Doppelbelegung" cr
      
      $4000                        \ Mov-Opcode
      r@ @ 8 lshift or              \ Alten Register holen
      get-free-register dup r@ ! or  \ Neuen Register anfordern, registrieren und in den Opcode einfügen
      image,
    
    then

  rdrop
;

: alle-vorhandenen-elemente-in-register-laden ( -- )

  state-tos @   unknown <> if state-tos expect-element-in-register then
  state-nos @   unknown <> if state-nos expect-element-in-register then
  state-3os @   unknown <> if state-3os expect-element-in-register then
  state-4os @   unknown <> if state-4os expect-element-in-register then
  state-5os @   unknown <> if state-5os expect-element-in-register then
  state-6os @   unknown <> if state-6os expect-element-in-register then

  state-tor @ r-unknown <> if state-tor expect-element-in-register then
  state-nor @ r-unknown <> if state-nor expect-element-in-register then
  state-3or @ r-unknown <> if state-3or expect-element-in-register then
  state-4or @ r-unknown <> if state-4or expect-element-in-register then
  
  \ An dieser Stelle kann ein Register mehrere Elemente zugleich repräsentieren.
  \ Das ist natürlich ein unmöglicher Aufräumzustand, muss also darauf achten, dass jeder Register nur einmal verwendet wird.
  \ Notfalls sind nun Elementkopien anzulegen.
  
  state-4or registereinmaligkeit
  state-3or registereinmaligkeit
  state-nor registereinmaligkeit
  state-tor registereinmaligkeit    
  
  state-6os registereinmaligkeit
  state-5os registereinmaligkeit
  state-4os registereinmaligkeit
  state-3os registereinmaligkeit
  state-nos registereinmaligkeit
  state-tos registereinmaligkeit

;

: nullprobe-schreiben-und-alle-vorhandenen-elemente-in-register-laden ( -- )

  expect-one-element
  expect-tos-in-register  \ Dies ist der Wert, der geprüft werden soll...
  $B000 state-tos @ or state-tos @ 8 lshift or image, \ Schreibe die Nullprobe mit einem passenden Register
  eliminiere-tos        

  alle-vorhandenen-elemente-in-register-laden
;


: vergleich-schreiben-und-alle-vorhandenen-elemente-in-register-laden ( -- )

  sprungtrampolin @ execute
  
    0 flagtrampolin !
  0 sprungtrampolin !

  alle-vorhandenen-elemente-in-register-laden
;


\ -----------------------------------------------------------------------------
\   Eine Routine, die einen Registersatz umsortieren kann, notfalls mit Umweg über r5.
\ -----------------------------------------------------------------------------

10 2* cells buffer: tauschpaare
        0 variable #tauschpaare

: registertausch-cache ( Quellregister Zielregister -- )  
  swap #tauschpaare @ 2 cells * tauschpaare + 2!
  1 #tauschpaare +!  
;

: quellelementaddr ( u -- addr ) 2 cells * tauschpaare +       ; 
:  zielelementaddr ( u -- addr ) 2 cells * tauschpaare + cell+ ;

: registerfrei? ( register -- ? ) \ Taucht der Zielregister noch in der Liste der Quellregister auf ?

  #tauschpaare @ 0 ?do
    dup  
    i quellelementaddr @ \ Die Quellregisterliste durchgucken
    $F and = if unloop drop false exit then
  loop
  drop
  true
;

: registertausch-einblick ( -- )
  cr
  #tauschpaare @ 0 ?do
    i quellelementaddr @ hex.
    i  zielelementaddr @ hex. cr
  loop
;

: tauschzug ( quelle ziel -- )

  swap operand-for-double $4000 or \ Quelloperand einfügen, nach Bedarf mit @Register
  or                               \ Zielregister einfügen.
  
  image,
;

: fertiggetauscht? ( -- true | i false ) \ Prüft, ob nun alle Tauschpaare abgearbeitet sind.
  #tauschpaare @ 0 ?do
    i quellelementaddr @  i zielelementaddr @  <>  if i unloop false exit then
  loop
  true
;

true variable keintauschmehr

: registertausch-direkt ( -- ) \ Versucht alle Fälle abzuarbeiten, bei denen ein direktes Laden möglich ist.

  \ Versuchen, alle Register so weit es geht direkt in ihre Zielregister zu laden.
  begin
    true keintauschmehr !    
    #tauschpaare @ 0 ?do
      i quellelementaddr @  i zielelementaddr @  <>
      if \ Stimmt das Paar noch nicht ?
        i zielelementaddr @ registerfrei? \ Ist der Zielregister frei ?
        if          
          i quellelementaddr @ i zielelementaddr @ tauschzug    \ So kann ich das Element direkt in den Zielregister schreiben          
          i zielelementaddr @ i quellelementaddr !              \ Und es als im richtigen Register angekommen vermerken.
          false keintauschmehr ! \ Vielleicht gibt es nun eine neue Gelegenheit.
        then
      then      
    loop  
  keintauschmehr @ until  
;  

: quellregister-durch-r5-ersetzen ( quellregister -- )
  
  1 5 lshift registerusage bis!  \ Verwendung von r5 anmelden

  #tauschpaare @ 0 ?do
    dup i quellelementaddr @ $F and =
    if
      i quellelementaddr @
        $F bic  \ Alten Quellregister wegmaskieren, Adressiermodus dabei jedoch erhalten
        5 or    \ Register 5 einfügen
      i quellelementaddr !
    then
  loop
  drop
;

: registertausch-flush ( -- ) 

\  ." Registertausch-Flush beginnt" cr
\  registertausch-einblick cr

  begin    
    registertausch-direkt    
  fertiggetauscht? not while       \ Einen "Zyklentausch" durchführen ?     
    ( Element ) \ Erstes Element, bei dem es noch nicht passt, auf dem Stack.   
    quellelementaddr @ $F and dup 5 tauschzug \ Wechsele diesen Register in r5    
    ( Ehemaliger-Quellregister-der-jetzt-in-r5-ist )    
    quellregister-durch-r5-ersetzen           
  repeat
  
\  ." Registertausch-Flush endet" cr
;

\ -----------------------------------------------------------------------------
\   Nun wird es Zeit, wirklich zum Aufräumen zu kommen !
\ -----------------------------------------------------------------------------

: mitregister? ( zustandsvariable -- ? ) \ Prüft, ob es sich hierbei um etwas in Registern handelt.
  @ $F and 5 u>= \ Register 0 bis 4 haben besondere Aufgaben...
;  

: tidyup-common ( -- ) \ Dies muss bei der Erfüllung der Aufgabe allerdings die Flags intakt lassen !

  kanonischer-zustand @ kanon-4or + @ r-unknown = if state-4or r-tidyup then
  kanonischer-zustand @ kanon-3or + @ r-unknown = if state-3or r-tidyup then  
  kanonischer-zustand @ kanon-nor + @ r-unknown = if state-nor r-tidyup then
  kanonischer-zustand @ kanon-tor + @ r-unknown = if state-tor r-tidyup then  

  \ Alles, was gemäß des kanonischen Zustandes auf den Stack soll, ist nun rausgeschrieben.
  
  \ Alles, was unknown sein soll, ist bereits rausgeschrieben. Was jetzt noch übrig ist, kommt im Laufe der Routine in den vorgegebenen Register.
  
  \ Nun alles, was in Registern ist oder @Register ist, in die passenden Register laden.

  0 #tauschpaare ! \ Zahl der zu wechselnden Register initialisieren
  
  state-tos mitregister? if   state-tos @   kanonischer-zustand @ kanon-tos + @     dup state-tos !     registertausch-cache   then
  state-nos mitregister? if   state-nos @   kanonischer-zustand @ kanon-nos + @     dup state-nos !     registertausch-cache   then
  state-3os mitregister? if   state-3os @   kanonischer-zustand @ kanon-3os + @     dup state-3os !     registertausch-cache   then
  state-4os mitregister? if   state-4os @   kanonischer-zustand @ kanon-4os + @     dup state-4os !     registertausch-cache   then
  state-5os mitregister? if   state-5os @   kanonischer-zustand @ kanon-5os + @     dup state-5os !     registertausch-cache   then
  state-6os mitregister? if   state-6os @   kanonischer-zustand @ kanon-6os + @     dup state-6os !     registertausch-cache   then
                                                                                                        
  state-tor mitregister? if   state-tor @   kanonischer-zustand @ kanon-tor + @     dup state-tor !     registertausch-cache   then
  state-nor mitregister? if   state-nor @   kanonischer-zustand @ kanon-nor + @     dup state-nor !     registertausch-cache   then
  state-3or mitregister? if   state-3or @   kanonischer-zustand @ kanon-3or + @     dup state-3or !     registertausch-cache   then
  state-4or mitregister? if   state-4or @   kanonischer-zustand @ kanon-4or + @     dup state-4or !     registertausch-cache   then
                                                                                                       
  registertausch-flush \ Finde eine gute Lösung für die Registerwechsel und schreibe sie alle kollisionsfrei dahin, wo sie hingehören.
  

  \ Rausgeschrieben ok. Was schon in Registern war, ist nun im richtigen Register.  
  \ Jetzt noch: Nachladen und Nicht-Register-Elemente in den jeweiligen Zielregister laden.
  \ Das ist das letzte, was übrig geblieben ist... Hier wird also alles nachgeladen. Reihenfolge wichtig !

  state-tos @ kanonischer-zustand @ kanon-tos + @  <>  if  state-tos  kanonischer-zustand @ kanon-tos + @   element-in-diesen-register  then
  state-nos @ kanonischer-zustand @ kanon-nos + @  <>  if  state-nos  kanonischer-zustand @ kanon-nos + @   element-in-diesen-register  then
  state-3os @ kanonischer-zustand @ kanon-3os + @  <>  if  state-3os  kanonischer-zustand @ kanon-3os + @   element-in-diesen-register  then
  state-4os @ kanonischer-zustand @ kanon-4os + @  <>  if  state-4os  kanonischer-zustand @ kanon-4os + @   element-in-diesen-register  then
  state-5os @ kanonischer-zustand @ kanon-5os + @  <>  if  state-5os  kanonischer-zustand @ kanon-5os + @   element-in-diesen-register  then
  state-6os @ kanonischer-zustand @ kanon-6os + @  <>  if  state-6os  kanonischer-zustand @ kanon-6os + @   element-in-diesen-register  then
                                                                                                              
  state-tor @ kanonischer-zustand @ kanon-tor + @  <>  if  state-tor  kanonischer-zustand @ kanon-tor + @   element-in-diesen-register  then
  state-nor @ kanonischer-zustand @ kanon-nor + @  <>  if  state-nor  kanonischer-zustand @ kanon-nor + @   element-in-diesen-register  then
  state-3or @ kanonischer-zustand @ kanon-3or + @  <>  if  state-3or  kanonischer-zustand @ kanon-3or + @   element-in-diesen-register  then
  state-4or @ kanonischer-zustand @ kanon-4or + @  <>  if  state-4or  kanonischer-zustand @ kanon-4or + @   element-in-diesen-register  then

  \ Jetzt ist der gewünschte Zustand erreicht ! Fein !
;

: tidyup-ra ( -- )

  \ Die Datenstackaufräumer zusammenfassen, um nur ein sub #..., r4 Befehl schreiben zu müssen.
  
  0 \ Zahl der bisher gesammelten Aufräumfälle
  
  kanonischer-zustand @ kanon-6os + @   unknown = if state-6os d-tidyup-cache then
  kanonischer-zustand @ kanon-5os + @   unknown = if state-5os d-tidyup-cache then  
  kanonischer-zustand @ kanon-4os + @   unknown = if state-4os d-tidyup-cache then
  kanonischer-zustand @ kanon-3os + @   unknown = if state-3os d-tidyup-cache then  
  kanonischer-zustand @ kanon-nos + @   unknown = if state-nos d-tidyup-cache then
  kanonischer-zustand @ kanon-tos + @   unknown = if state-tos d-tidyup-cache then
  
  d-tidyup-flush \ Alle Elemente, die auf den Datenstack kommen, sind nun rausgeschrieben.
          
  tidyup-common
;

: tidyup-nullprobe ( -- ) \ Als Einleitung eines 0-branch

  0 \ Zahl der bisher gesammelten Aufräumfälle
  
  kanonischer-zustand @ kanon-5os + @   unknown = if state-6os d-tidyup-cache then  
  kanonischer-zustand @ kanon-4os + @   unknown = if state-5os d-tidyup-cache then
  kanonischer-zustand @ kanon-3os + @   unknown = if state-4os d-tidyup-cache then  
  kanonischer-zustand @ kanon-nos + @   unknown = if state-3os d-tidyup-cache then
  kanonischer-zustand @ kanon-tos + @   unknown = if state-nos d-tidyup-cache then
  
  d-tidyup-flush \ Alle Elemente, die auf den Datenstack kommen, sind nun rausgeschrieben.
      
  expect-one-element
  expect-tos-in-register  \ Dies ist der Wert, der geprüft werden soll...
  $B000 state-tos @ or state-tos @ 8 lshift or image, \ Schreibe die Nullprobe mit einem passenden Register
  eliminiere-tos        
                
  tidyup-common
;

: tidyup-bisaufzwei-sprungtrampolin ( -- Sprungopcode ) \ Als Einleitung eines Doppeltvergleiches

  0 \ Zahl der bisher gesammelten Aufräumfälle
 
  kanonischer-zustand @ kanon-4os + @   unknown = if state-6os d-tidyup-cache then
  kanonischer-zustand @ kanon-3os + @   unknown = if state-5os d-tidyup-cache then  
  kanonischer-zustand @ kanon-nos + @   unknown = if state-4os d-tidyup-cache then
  kanonischer-zustand @ kanon-tos + @   unknown = if state-3os d-tidyup-cache then
  
  d-tidyup-flush \ Alle Elemente, die auf den Datenstack kommen, sind nun rausgeschrieben.
      
  sprungtrampolin @ execute
  
    0 flagtrampolin !
  0 sprungtrampolin !
      
  tidyup-common

;

: tos-bytesperre ( -- ) \ Byte-Fetches können im RA mitschwimmen, dürfen aber nur selten weiterverwendet werden.

  state-tos @ bytebit and
  if
    state-tos expect-element-in-register  
  then
;


\ -----------------------------------------------------------------------------
\  Infrastruktur R-Stack
\ -----------------------------------------------------------------------------

: befreie-tor ( -- )
  state-4or r-tidyup

  state-3or 2@  state-4or 2!
  state-nor 2@  state-3or 2!
  state-tor 2@  state-nor 2!
  
  r-unknown state-tor !           \ TOR ist jetzt in einem unbekanntem Zustand  
;

: eliminiere-tor ( -- )
  state-nor 2@  state-tor 2!
  state-3or 2@  state-nor 2!
  state-4or 2@  state-3or 2!
  r-unknown state-4or !  
;

: expect-one-r-element ( -- )
  state-tor @ r-unknown =
  if
    get-free-register
    dup state-tor !
    $4130 or image, \ Vom R-Stack nachfüllen
  then
;

: tos-fetchsperre ( -- ) \ Sollte TOS ein Fetch enthalten, führe diesen sofort aus:

  state-tos @ unknown <>
  state-tos @ indexed? and
  state-tos @ literal? not and \ Konstanten dürfen gerne "mitschwimmen".
  if
    state-tos cell+ @                       \ Adresse holen, Literals werden hier nicht behandelt    
    state-tos @ operand-for-double $4000 or  \ Mov-Opcode vorbereiten
    eliminiere-tos                            \ Registerwechsel zum Fetch einleiten
    befreie-tos
    get-free-register dup state-tos !
    or
    image, \ Opcode
    image, \ Adresse        
  then    
;


