\
\    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: Verwaltung der verfügbaren Register
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

\ Register verfügbar:

\   Hardwired:
\     r0    pc
\     r1    sp
\     r2    sr
\     r3    cg
\   Gewählt:
\     r4    dsp
\     r5    nicht benutzt
\   Für den RA verfügbar:
\     r6
\     r7
\     r8
\     r9
\     r10
\     r11
\     r12
\     r13
\     r14
\     r15
\

\ -----------------------------------------------------------------------------
\   Die Zustandsvariablen des Registerallokators
\ -----------------------------------------------------------------------------

\ Aufbau der Opcodes:
\
\                    5432 1098 7654 3210
\   Single Operand:  oooo oooo obss rrrr
\   Double Operand:  oooo ssss dbss dddd
\   Jumps:           oooc cc-- ---- ----
\
\   Adressierungsmodi:
\     00  0  Register
\     01  1  Indexed/Absolute
\     10  -  Indirect
\     11  -  Indirect Autoincrement

\ Die möglichen Zustände der einzelnen Elemente, gleich fertig für Single-Operand-Opcodes


$31 constant  r-unknown  \ @r1+
$34 constant    unknown  \ @r4+

  6 constant  reg6
  7 constant  reg7
  8 constant  reg8
  9 constant  reg9

 10 constant  reg10
 11 constant  reg11
 12 constant  reg12
 13 constant  reg13
 14 constant  reg14
 15 constant  reg15

$20 constant  fetchbit
$30 constant  literal@pc+

$40 constant  bytebit

$0012 constant fetchabsolute

: literal? ( stackzustand -- ? )
  literal@pc+ =
;

: indexed? ( stackzustand -- ? )  \ Wird noch ein weiteres Element am Opcode benötigt ?
  dup  $30 and $10 =
  swap literal? or
;

: fetchworddestination? ( stackzustand -- ? ) \ Soll ein Element geholt werden, und zwar mit Wordbreite, welches so auch als Zieloperand verwendet werden könnte ?
  dup
    \ $3F and fetchabsolute =
    $30 and $10 = \ Indexed, Absolute
  swap
    $30 and $20 = \ Indirect, also @r...
  or
;

\ Register@
\ Literal@


\ Damit kann ich 4 R-Stack-Elemente und 6 D-Stack-Elemente in den RA aufnehmen

0 r-unknown  2variable  state-tor
0 r-unknown  2variable  state-nor
0 r-unknown  2variable  state-3or
0 r-unknown  2variable  state-4or

0 unknown  2variable  state-tos
0 unknown  2variable  state-nos
0 unknown  2variable  state-3os
0 unknown  2variable  state-4os
0 unknown  2variable  state-5os
0 unknown  2variable  state-6os




: cura ( -- ) \ See you RA
  cr

  ." 4OR: " state-4or 2@ hex. hex. cr
  ." 3OR: " state-3or 2@ hex. hex. cr
  ." NOR: " state-nor 2@ hex. hex. cr
  ." TOR: " state-tor 2@ hex. hex. cr

  ." 6OS: " state-6os 2@ hex. hex. cr
  ." 5OS: " state-5os 2@ hex. hex. cr
  ." 4OS: " state-4os 2@ hex. hex. cr
  ." 3OS: " state-3os 2@ hex. hex. cr
  ." NOS: " state-nos 2@ hex. hex. cr
  ." TOS: " state-tos 2@ hex. hex. cr

;

' cura     t-prim: cura    t-hostonly



\ Um zu vermerken, welche Register im Laufe der Routine verwendet werden, damit ich Interrupteinsprünge passend präparieren kann.

0 variable registerusage

\ Damit lassen sich Vergleiche und Sprünge optimal vereinen.

0 variable flagtrampolin
0 variable sprungtrampolin

\ Damit lassen sich Zwei-Operanden-Befehle auf ihre Eignung für den Konstantengenerator hin untersuchen.

: konstantengenerator ( konstante/index opcode -- )
  \ Prüfe zunächst, ob es sich um eine Konstante oder um einen Index handelt.

  dup $0F30 and $0030 =
  if
    over
    case
      $FFFF of nip           $0330 or image, exit endof
          0 of nip $0030 bic $0300 or image, exit endof
          1 of nip $0030 bic $0310 or image, exit endof
          2 of nip $0030 bic $0320 or image, exit endof
          4 of nip $0030 bic $0220 or image, exit endof
          8 of nip           $0230 or image, exit endof
    endcase
  then

  \ Falls es ein Index war oder die Konstante nicht generiert werden konnte, einfach so schreiben.
  image, image,
;

: konstantengenerator-push ( konstante/index opcode -- )
  \ Prüfe zunächst, ob es sich um eine Konstante oder um einen Index handelt.

  dup $003F and $0030 =
  if
    over
    case
      $FFFF of nip           $0033 or image, exit endof
          0 of nip $0030 bic $0003 or image, exit endof
          1 of nip $0030 bic $0013 or image, exit endof
          2 of nip $0030 bic $0023 or image, exit endof
    endcase
  then

  \ Falls es ein Index war oder die Konstante nicht generiert werden konnte, einfach so schreiben.
  image, image,
;

\ -----------------------------------------------------------------------------
\  Infrastruktur für die Registerbelegung
\ -----------------------------------------------------------------------------

: registerfrei? ( reg -- reg ? )
  state-6os @ $F and over = if false exit then
  state-5os @ $F and over = if false exit then
  state-4os @ $F and over = if false exit then
  state-3os @ $F and over = if false exit then
  state-nos @ $F and over = if false exit then
  state-tos @ $F and over = if false exit then

  state-4or @ $F and over = if false exit then
  state-3or @ $F and over = if false exit then
  state-nor @ $F and over = if false exit then
  state-tor @ $F and over = if false exit then

  true
;

: get-free-register-intern ( -- reg ) \ Wenn alle Register belegt sind, lieber einen R-Register rausschreiben als einen D-Register, braucht weniger Opcodes und Takte.

  reg6  registerfrei? if exit then drop
  reg7  registerfrei? if exit then drop
  reg8  registerfrei? if exit then drop
  reg9  registerfrei? if exit then drop
  reg10 registerfrei? if exit then drop
  reg11 registerfrei? if exit then drop
  reg12 registerfrei? if exit then drop
  reg13 registerfrei? if exit then drop
  reg14 registerfrei? if exit then drop
  reg15 registerfrei? if exit then drop

  ." No free registers available. This should not happen, please report bug." quit
;

: get-free-register ( -- reg ) \ Vermerkt die Wahl auch gleich in "registerusage".
  get-free-register-intern
  1 over lshift registerusage bis! \ Zur bisherigen Registerverwendung hinzuverodern
;

\ -----------------------------------------------------------------------------
\  Infrastruktur für die Register im RA
\ -----------------------------------------------------------------------------

: eliminiere-tos ( -- )
  state-nos 2@  state-tos 2!
  state-3os 2@  state-nos 2!
  state-4os 2@  state-3os 2!
  state-5os 2@  state-4os 2!
  state-6os 2@  state-5os 2!
  unknown state-6os !
;

: eliminiere-nos ( -- )
  state-3os 2@  state-nos 2!
  state-4os 2@  state-3os 2!
  state-5os 2@  state-4os 2!
  state-6os 2@  state-5os 2!
  unknown state-6os !
;

\ Agenda: Ermöglichen, einen Wert als @r4+ in den RA einzufügen.
\         Wenn bereits ein @r4+ im RA vorhanden ist, muss dieser geladen werden und der nächste kann auf @r4+ gesetzt werden.

\ Ähnliches für den R-Stack, aber hier ist es weniger wahrscheinlich, kommt später.

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

: expect-two-elements ( -- )
  expect-one-element
  state-nos @ unknown =
  if
    get-free-register
    dup state-nos !
    $4430 or image, \ Vom Stack nachfüllen
  then
;

: operand-for-double ( x -- x' )
  dup $F and >r \ Register wegmaskieren
  $00F0 and
  r> 8 lshift or
;

: expect-element-in-register ( Zustandsvariable -- )
  dup @ reg15 u<= if drop exit then \ Ist das Element nicht in einem Register ?

    \ Bereite also einen mov-Opcode vor, der das Element in einen Register bugsiert.

    dup @ operand-for-double $4000 or \ mov-Opcode zusammenbauen
    ( Zustandsvariable Opcode )

    over @ indexed?
    if
      over cell+ @ \ Literal oder Adresse holen
      >r           \ Für später aufbewahren

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over get-free-register swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen

      r> swap konstantengenerator

    else

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over get-free-register swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen
      image,


    then
;

: expect-tos-in-register ( -- ) state-tos expect-element-in-register ;
: expect-nos-in-register ( -- ) state-nos expect-element-in-register ;


0 variable welcherregister

: element-in-diesen-register ( zustandsvariable register -- ) \ So ähnlich wie expect-element-in-register

  welcherregister !

    \ Bereite also einen mov-Opcode vor, der das Element in einen Register bugsiert.

    dup @ operand-for-double $4000 or \ mov-Opcode zusammenbauen
    ( Zustandsvariable Opcode )

    over @ indexed?
    if
      over cell+ @ \ Literal oder Adresse holen
      >r           \ Für später aufbewahren

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over welcherregister @ swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen

      r> swap konstantengenerator

    else

      ( Zustandsvariable Opcode )
      over unknown swap !          \ Register abmelden
      over welcherregister @ swap ! \ Neuen Register einfügen, vielleicht auch mit Registerwechsel
      swap @ or                      \ Zielregister einfügen
      image,


    then
;

\ -----------------------------------------------------------------------------
\  Kleine Helferlein, damit die Faltung auch im RA durchgeführt werden kann
\ -----------------------------------------------------------------------------

\ Für die Faltung im RA, denn durch das Inlining können hier Konstanten aufeinandertreffen und müssen optimiert werden.

: einekonstante? ( -- ? )   state-tos @ literal@pc+ = ;
: einekonstante  ( -- tos ) state-tos cell+ @  eliminiere-tos ;

: zweikonstanten? ( -- ? ) state-tos @ literal@pc+ = state-nos @ literal@pc+ = and ;
: zweikonstanten ( -- nos tos ) state-nos cell+ @  state-tos cell+ @  eliminiere-tos eliminiere-tos ;

