\
\    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: Der Cross-Kompilierende Registerallokator
\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

false variable noch-ein-pass?
false variable schon-ein-snapshot-festgelegt?

\ -----------------------------------------------------------------------------
\   Die Schnittstelle zum Rest der Welt
\ -----------------------------------------------------------------------------

: insertprimitive ( token -- )

  dup hostonly> t@ if t-name. ."  is available on host only." cr quit then

  dup primitive-ra> t@ ?dup if ( ." RA-Primitive" cr ) execute drop exit else ( ." Primitive räumt auf" cr ) tidyup-ra then

  ." No pure machine language primitives possible anymore. This should not happen, please report bug." cr quit

\    \ Als Maschinensprache definierte Primitiven inline einfügen.
\
\    dup registerusage> t@ registerusage bis! \ Zur bisherigen Registerverwendung hinzuverodern
\
\      ."  inp " dup hex. cr
\    code>
\    begin
\      dup t@ retopcode <>     \ ... bis zum Ret einfügen.
\    while
\      dup t@ image,           \ Opcodes der Primitive ...
\      4 +
\    repeat
\    drop
;

: compileliteral ( n -- )

  \ Das übernimmt nun fortan der Registerallokator.

  befreie-tos           \ Das oberste Element freischieben
  state-tos cell+ !      \ Vermerke die Konstante im RA
  literal@pc+ state-tos ! \ Vermerke den neuen Status

\  $8324  image, \ sub.w #2h, r4
\  $40B4  image, \ mov.w #2Ah, 0h(r4)
\         image,
\  $0000  image,
;

: ergebnismerken ( x -- ) compileliteral ;

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



\ Dies hier wird schon nicht mehr durch den RA geschickt:

: compilecalltotoken ( token -- )
  $12B0 image, \ Call-Opcode
  addrintarget> t@ image, \ Zieladresse
;

\ -----------------------------------------------------------------------------
\  Helferlein für den RA über Sprünge hinweg
\ -----------------------------------------------------------------------------


: savesnapshot ( t-addr -- )

  state-tos @ over kanon-tos + t!
  state-nos @ over kanon-nos + t!
  state-3os @ over kanon-3os + t!
  state-4os @ over kanon-4os + t!
  state-5os @ over kanon-5os + t!
  state-6os @ over kanon-6os + t!

  state-tor @ over kanon-tor + t!
  state-nor @ over kanon-nor + t!
  state-3or @ over kanon-3or + t!
  state-4or @ over kanon-4or + t!

  drop
;

: loadsnapshot ( t-addr -- )

  dup kanon-tos + t@  state-tos !
  dup kanon-nos + t@  state-nos !
  dup kanon-3os + t@  state-3os !
  dup kanon-4os + t@  state-4os !
  dup kanon-5os + t@  state-5os !
  dup kanon-6os + t@  state-6os !

  dup kanon-tor + t@  state-tor !
  dup kanon-nor + t@  state-nor !
  dup kanon-3or + t@  state-3or !
  dup kanon-4or + t@  state-4or !

  drop
;

: curasnapshotgesetzt? ( t-addr -- ? )
  12 + t@ 0<> \ Die Null kommt im RA nie vor, kann also dagegen prüfen.
;

\ -----------------------------------------------------------------------------
\  Kurze Sprünge einfügen
\ -----------------------------------------------------------------------------

0 variable zuletzteinenunbedingtensprung

64 constant maxjumps  \ Maximale Zahl von gepufferten Vorwärtssprüngen
maxjumps 8 * buffer: jumpcollection
jumpcollection maxjumps 8 * 0 fill

: showjumps ( -- )
  maxjumps 0 do
    i 8 * jumpcollection + @
    if
      ." Destination: " i 8 * jumpcollection + @ hex.
      ." Opcode location: " i 8 * jumpcollection + 4 + @ hex. cr
    then
  loop
;

: patch-jump-opcode ( Zieladresse-im-Target Opcodeadresse -- )
      dup >r
      - 2 - shr $3FF and     \ Offset berechnen
      r@ image@ or r> image!  \ Zum vorgefertigten Opcode dazuverodern


;

: resolvejumps ( host-style-addr -- )

  maxjumps 0 do
    i 8 * jumpcollection + @ over =
    if
      \ Sprungopcode liegt schon im Speicher, muss nur noch den Offset berechnen und dazuverodern.

      dup 8 + t@  ( Zieladresse-im-Target )

        \ dup ." Zieladresse im Target" hex. cr

      i 8 * jumpcollection + 4 + @ ( Zieladresse-im-Target Opcodeadresse )
      patch-jump-opcode

      \ Aus der Liste löschen:
      0   i 8 * jumpcollection +       !
      0   i 8 * jumpcollection +  4 +  !

    then
  loop
  drop
;

: collectjump ( opcode-location unresolved-host-style-destination )

  \ Prüfe erstmal, ob die host-style-destination vielleicht schon bekannt ist.

  dup 8 + t@ ?dup \ Absolute Adresse im Target oder Null für unbekanntes Ziel

  if \ Adresse bereits zugeordnet

    ( opcode-location host-style-addr target-destination-addr )
    nip
    ( opcode-location target-destination-addr )
    swap patch-jump-opcode

  else \ Target-Zieladresse noch nicht bekannt

    \ Suche die erste freie Stelle in der Liste noch zu bearbeitender Sprünge

    jumpcollection
    begin
      dup @ 0<>
    while
      8 +
    repeat
    >r

    ( opcode-location unresolved-host-style-destination R: addr-der-ersten-freien-stelle )
    r@     ! \ unresolved-host-style-destination
    r> 4 + ! \ opcode-location

     \ showjumps

 then \ Target-Adresse schon bekannt ?
;

: otherdestinationsbefore? ( host-style-destination -- ? )

  maxjumps 0 do
    i 8 * jumpcollection + @
    ?dup if   \ 0 bedeutet: Leere Stelle,
      over u<= \ Gibt es einen unbehandelten Vorwärtssprung, der vor unserem Ziel einspringt ?
      if unloop drop true exit then
    then
  loop
  drop false
;




: eliminiere-sprungziel ( addr -- ) signaltyp signal-branchtarget = if  signal-nop      swap t!  true noch-ein-pass? !  else drop then ; \ Nur dann ein weiterer Pass, wenn tatsächlich etwas deaktiviert wurde.
: eliminiere-token      ( addr -- ) signaltyp signal-token        = if  signal-noptoken swap t!  true noch-ein-pass? !  else drop then ;

: vorsprung-unterwegs ( ziel start -- ziel ) \ Der Start ist immer ein Sprung. Das Ziel ist auf jeden Fall eine Sprungstelle.

  \  Untersuche nun alle Sprünge in dem Bereich und eliminiere ihre Ziel-Aufräumstellen, damit diese die weitere Optimierung nicht stören.
  \  Entferne auch alle Token-Einsprünge, damit diese bei der nächsten Verwendungsprobe nicht berücksichtigt werden müssen.

  \ Das hier sind bereits Code-Adressen. Kann sie direkt verwenden.
  begin
    signaltyp
    case

       signal-branch of parameter eliminiere-sprungziel endof
      signal-0branch of parameter eliminiere-sprungziel endof
        signal-token of dup       eliminiere-token      endof

    endcase
    2dup u>
  while
    skip-element drop
  repeat
  drop
;


: in-diesen-zustand-aufräumen ( Cura-Quelladresse Aufräumer-xt -- )
  kanonischer-zustand @ >r                       \ Merken ! Wir müssen ihn später wieder herstellen können.
  swap 12 + t-dictionary + kanonischer-zustand !  \ Setze den Zustand "als den Kanonischen"...
  execute                                          \ Räume mit dem gewünschten Aufräumer in den gewünschten Zustand auf
  r>  kanonischer-zustand !                         \ Schließlich wieder der kanonische kanonische Zustand.
;


\ Zähle die Elemente, die jeweils in Registern sind oder sein sollten, um zu bestimmen, wie viele Register an den Vereinigungsstellen verwendet werden sollen.

: anzahl-elemente-d-aktuell ( -- u )
  0
  state-tos @ unknown <> if 1+ then
  state-nos @ unknown <> if 1+ then
  state-3os @ unknown <> if 1+ then
  state-4os @ unknown <> if 1+ then
  state-5os @ unknown <> if 1+ then
  state-6os @ unknown <> if 1+ then
;

: anzahl-elemente-r-aktuell ( -- u )
  0
  state-tor @ r-unknown <> if 1+ then
  state-nor @ r-unknown <> if 1+ then
  state-3or @ r-unknown <> if 1+ then
  state-4or @ r-unknown <> if 1+ then
;

: anzahl-elemente-d-snapshot ( Cura-Quelladresse -- u )
  12 + >r 0
  r@ kanon-tos + t@ unknown <> if 1+ then
  r@ kanon-nos + t@ unknown <> if 1+ then
  r@ kanon-3os + t@ unknown <> if 1+ then
  r@ kanon-4os + t@ unknown <> if 1+ then
  r@ kanon-5os + t@ unknown <> if 1+ then
  r> kanon-6os + t@ unknown <> if 1+ then
;

: anzahl-elemente-r-snapshot ( Cura-Quelladresse -- u )
  12 + >r 0
  r@ kanon-tor + t@ r-unknown <> if 1+ then
  r@ kanon-nor + t@ r-unknown <> if 1+ then
  r@ kanon-3or + t@ r-unknown <> if 1+ then
  r> kanon-4or + t@ r-unknown <> if 1+ then
;


btarget-len buffer: tmp-snapshot
0 variable gewünschte-anzahl-d-elemente
0 variable gewünschte-anzahl-r-elemente

: begrenze-zahl-der-elemente ( -- ) \ tmp-snapshot auf die gewünschten Elementanzahlen zurückstutzen.

  gewünschte-anzahl-d-elemente @ 1 u< if   unknown tmp-snapshot kanon-tos + ! then
  gewünschte-anzahl-d-elemente @ 2 u< if   unknown tmp-snapshot kanon-nos + ! then
  gewünschte-anzahl-d-elemente @ 3 u< if   unknown tmp-snapshot kanon-3os + ! then
  gewünschte-anzahl-d-elemente @ 4 u< if   unknown tmp-snapshot kanon-4os + ! then
  gewünschte-anzahl-d-elemente @ 5 u< if   unknown tmp-snapshot kanon-5os + ! then
  gewünschte-anzahl-d-elemente @ 6 u< if   unknown tmp-snapshot kanon-6os + ! then

  gewünschte-anzahl-r-elemente @ 1 u< if r-unknown tmp-snapshot kanon-tor + ! then
  gewünschte-anzahl-r-elemente @ 2 u< if r-unknown tmp-snapshot kanon-nor + ! then
  gewünschte-anzahl-r-elemente @ 3 u< if r-unknown tmp-snapshot kanon-3or + ! then
  gewünschte-anzahl-r-elemente @ 4 u< if r-unknown tmp-snapshot kanon-4or + ! then

  \ Nur einen Snapshot pro Pass festlegen ! Die anderen Register könnten nämlich dadurch verrutschen.
  schon-ein-snapshot-festgelegt? @ 0=
  if
  \  ." Tatsächlich festlegen" cr
    true tmp-snapshot 10 cells + !
    true noch-ein-pass? !
    true schon-ein-snapshot-festgelegt? !
  then
;


0 variable welcher-aufräumer
0 variable wie-viele-elemente-weniger


: universal-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

  dup  anzahl-elemente-d-snapshot anzahl-elemente-d-aktuell wie-viele-elemente-weniger @ - 0 max u>
  over anzahl-elemente-r-snapshot anzahl-elemente-r-aktuell u> or
      \ drop false \ Umschalten in den alten Modus ohne Sprungzielfestlegungen
  if
    \ ." Muss eine Vereinigungsstelle festlegen." cr
    \ Den Zustand, in den aufgeräumt werden soll sichern, und die Zahl der Elemente, um den Snapshot für den nächsten Pass vorbereiten zu können
    dup t-dictionary + 12 + tmp-snapshot btarget-len move
    anzahl-elemente-d-aktuell wie-viele-elemente-weniger @ - 0 max gewünschte-anzahl-d-elemente !
    anzahl-elemente-r-aktuell gewünschte-anzahl-r-elemente !

    \ Mache das Aufräumen erstmal so weiter, wie es mit dem in diesem Pass schon festliegenden Snapsnot erforderlich ist
    dup    welcher-aufräumer @ in-diesen-zustand-aufräumen

    \ Begrenze die Zahl der Elemente in dem gesicherten Snapshot
    begrenze-zahl-der-elemente

    \ Und bereit den Snapshot für den nächsten Pass vor, der dann liegen bleibt:
    tmp-snapshot swap t-dictionary + 12 + btarget-len move
  else
     welcher-aufräumer @ in-diesen-zustand-aufräumen
  then
;

\   cr
\   ." Mit tidyup-ra aufräumen "
\   ."  D aktuell " anzahl-elemente-d-aktuell .
\   ."  D cura " dup anzahl-elemente-d-snapshot .
\   ."  R aktuell " anzahl-elemente-r-aktuell .
\   ."  R cura " dup anzahl-elemente-r-snapshot .
\   cr
\

: mit-tidyup-ra-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

   0  wie-viele-elemente-weniger !
  ['] tidyup-ra welcher-aufräumer !

  universal-in-diesen-zustand-aufräumen
;

: mit-tidyup-nullprobe-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

   1  wie-viele-elemente-weniger !
  ['] tidyup-nullprobe welcher-aufräumer !

  universal-in-diesen-zustand-aufräumen
;

: mit-tidyup-bisaufzwei-sprungtrampolin-in-diesen-zustand-aufräumen ( Cura-Quelladresse -- )

   2  wie-viele-elemente-weniger !
  ['] tidyup-bisaufzwei-sprungtrampolin welcher-aufräumer !

  universal-in-diesen-zustand-aufräumen
;

0 variable hs-destination  \ Temporär, um Stackrobatik zu vermeiden...


: compilebranch ( Fadenadresse host-style-destination -- Fadenadresse* )
  \ Dies hier kann auch einen Block unbedingt weglassen, deshalb Zugriff auf die Fadenadresse erforderlich.

  hs-destination !

  hs-destination @ over u>
  if \ Unbedingter Vorwärtssprung.
    hs-destination @ otherdestinationsbefore? 0=
    if
      hs-destination @ swap vorsprung-unterwegs ( Fadenaddr* ) \ Es ist ein Vorwärtssprung, der samt des Blocks weggelassen wird.
      exit \ Fertig, nach der übersprungenen Stelle weiterkompilieren.
    then
  then


  \ Der Sprung muss ganz normal behandelt werden - kann ihn nicht weglassen.
  true zuletzteinenunbedingtensprung !


  hs-destination @ curasnapshotgesetzt? \ Ist der Cura-Snapshot für das Ziel schon gesetzt ?
  if

    \ Ziel-Registerzustand ist bereits bekannt, räume also in den gewünschten Zustand auf
    hs-destination @ mit-tidyup-ra-in-diesen-zustand-aufräumen

  else

    \ Ziel-Registerzustand ist noch unbekannt. Nimm den aktuellen Zustand.
    alle-vorhandenen-elemente-in-register-laden
    hs-destination @ 12 + savesnapshot \ Vermerke die Registerbelegung für später

  then

  org @ hs-destination @
    $3C00 image,           \ Leeren Sprungbefehl bereitlegen, Ziel wird vielleicht erst später nachgefügt.
  collectjump
;


: compile-0-branch ( host-style-destination -- )
  hs-destination !

  hs-destination @ curasnapshotgesetzt? \ Ist der Cura-Snapshot für das Ziel schon gesetzt ?
  if

    \ Ziel-Registerzustand ist bereits bekannt, räume also in den gewünschten Zustand auf
    hs-destination @ mit-tidyup-nullprobe-in-diesen-zustand-aufräumen

  else

    \ Ziel-Registerzustand ist noch unbekannt. Nimm den aktuellen Zustand.
    nullprobe-schreiben-und-alle-vorhandenen-elemente-in-register-laden
    hs-destination @ 12 + savesnapshot \ Vermerke die Registerbelegung für später

  then

  org @ hs-destination @
    $2400 image,           \ Leeren Sprungbefehl bereitlegen, Ziel wird vielleicht erst später nachgefügt.
  collectjump
;

: flagschreiber ( -- )
  flagtrampolin @ ?dup if execute 0 flagtrampolin ! 0 sprungtrampolin ! then
;

: compile-0-branch-trampolin ( host-style-destination -- )
  hs-destination !

  hs-destination @ curasnapshotgesetzt? \ Ist der Cura-Snapshot für das Ziel schon gesetzt ?
  if

    \ Ziel-Registerzustand ist bereits bekannt, räume also in den gewünschten Zustand auf
    hs-destination @ mit-tidyup-bisaufzwei-sprungtrampolin-in-diesen-zustand-aufräumen

  else

    vergleich-schreiben-und-alle-vorhandenen-elemente-in-register-laden
    hs-destination @ 12 + savesnapshot \ Vermerke die Registerbelegung für später

  then

  org @ hs-destination @
    trampolin-sprungopcode @ image,           \ Leeren Sprungbefehl bereitlegen, Ziel wird vielleicht erst später nachgefügt.
  collectjump
;

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

\ true variable inlining

: inline? ( token -- ? ) \ Alles, was genau einmal benutzt wird, soll inline eingefügt werden.
  dup inline> t@          \ Ist es als "stets inline" markiert ?
  swap usage> t@ 1 =       \ Oder wird es nur einmal verwendet ?
  ( inlining @ and )
  or                         \ Um das große Einfügen auch mal probeweise abstellen zu können.
;

: tos-konstant-false? ( -- ? )
  \ Ist TOS konstant false, wird aus 0-branch ein branch.

  state-tos @ literal?
  state-tos cell+ @ 0=
  and
;

: tos-konstant-true? ( -- ? )
  \ Ist TOS konstant true, kann ein 0-branch weggelassen werden

  state-tos @ literal?
  state-tos cell+ @ 0<>
  and
;

: t-inlinedata ( addr len -- )
  begin
    dup
  while
    2 -
    swap
    dup th@ image,
    2 +
    swap
  repeat
  2drop
;

: crosscompiledefinition ( token -- )
  \ ."  ccd " dup hex. cr
  \ Entlanghangeln und als Objektcode einfügen.

  code>

  begin


    org @  over 8 + t!    \ Aktuelle Target-Adresse dieses Bausteins vermerken

    signaltyp
    case

      \ Diese beiden haben eigene Case-Fälle, weil beim Durchfallen weiter nach hinten immer weniger Optimierungen möglich werden.

      signal-ret of drop exit endof \ Definition zu Ende ? Fertig !
      signal-nop of           endof \ Eliminierte Sprungziel-Aufräumstellen gar nicht behandeln.
 signal-noptoken of           endof \ Eliminierte Token                     gar nicht behandeln.


      dup signal-branchtarget <> if false zuletzteinenunbedingtensprung ! then \ Um später auf unbedingte Sprünge treffende Branchtargets zu erkennen.


      signal-0branch of
                       parameter over +  ( Fadenadresse Sprungziel )

                       flagtrampolin @
                       if
                         compile-0-branch-trampolin \ Ein Sprung, der aus einem Flag gespeist wird, kann nie wegoptimiert werden.
                       else
                         \ Sollte TOS konstant false sein, muss der Sprung unbedingt stattfinden.
                         tos-konstant-false?
                         if
                           eliminiere-tos compilebranch \ Umgewandelt in einen unbedingten Sprung.
                         else
                           \ Sollte TOS konstant true sein, wird der Sprung nie ausgeführt. Lasse ihn weg, entferne die Aufräumstelle.
                           tos-konstant-true? if eliminiere-tos eliminiere-sprungziel else compile-0-branch then
                         then
                       then
                     endof

      flagschreiber \ Alle anderen Sachen können mit einem Flag nichts anfangen, muss also den Vergleich tatsächlich kompilieren.


      signal-branch  of         \ Unbedingte Sprünge. Beim "Vorspringen" alle Sprünge unterwegs prüfen und ihre Aufräumstellen eliminieren.
                       parameter over +  ( Fadenadresse Sprungziel )
                       compilebranch
                     endof

      signal-token   of
                       parameter dup ramallot> t@
                       if
                         \ Dieses Token ist ein Puffer oder eine Variable. Muss nun die Target-Adresse als Literal einfügen !
                         addrintarget> t@ compileliteral
                       else
                         dup inline?
                         if dup primitive> t@ if insertprimitive else dup adresszuordnungputzen recurse then
                         else tidyup-ra compilecalltotoken then
                       then
                     endof

      signal-literal of parameter compileliteral endof \ Literal holen und liegenlassen


      signal-data-addr of \ Adress-Datenblöcke benötigen kein Aufräumen zuvor. Muss nur die Adresse auf den Datenstack legen, die kann anschließend weiterbenutzt werden.
                         befreie-tos                     \ Adresse des Datenblocks auf den Stack legen
                         literal@pc+ state-tos !          \ Dafür den Zustand von TOS auf Konstante setzen
                         org @ 2 + state-tos 4 + !         \ und die richtige Adresse dort hinterlegen. Plus 2 für den Sprung-Opcode, der direkt folgt.
                         parameter ( Länge ) 2/ $3C00 or image, \ Sprung über den Datenblock generieren, hier direkt.
                         parameter ( Länge ) over 12 + ( Adresse ) swap t-inlinedata \ Datenblock inline einfügen
                       endof

      signal-data      of
                         tidyup-ra
                         parameter ( Länge ) over 12 + ( Adresse ) swap t-inlinedata \ Datenblock inline einfügen
                       endof


   signal-branchtarget of

                            dup curasnapshotgesetzt?
                            if \ Für diese Stelle existiert bereits ein Snapshot, für den nun Kontrollfluss-Vereinigungs-Vorbereitung nötig ist.

                              \ War das letzte Signal ein unbedingter Sprung ? Wenn ja, laufe ich hier nie vorbei und muss nicht aufräumen.
                              \ Es gibt natürlich noch den unsinnigen Fall, dass der Sprung direkt hierher kommt...
                              \ Aber dann ist dies der Ziel von dem Sprung selbst und es muss auch nichts aufgreäumt oder angepasst werden.

                                       zuletzteinenunbedingtensprung @ if
                                         dup 12 + loadsnapshot \ Gesicherten Cura-Snapshot laden
                                       else
                                         dup mit-tidyup-ra-in-diesen-zustand-aufräumen
                                       then

                            else \ Noch kein Snapshot angelegt. Alles in Register laden und den aktuellen Zustand vermerken.

                              alle-vorhandenen-elemente-in-register-laden  \ Alles, was nun im RA ist, soll in Registern sein
                              dup 12 + savesnapshot                         \ Vermerke die Registerbelegung für später

                            then


                            org @   over 8 + t! \ Dann muss allerdings auch die ORG-Stelle angepasst werden.
                            dup resolvejumps    \ Gibt es noch unaufgelöste Vorwärtssprünge zu dieser Stelle ? Falls ja, werden sie nun eingefügt.

                            false zuletzteinenunbedingtensprung !
                          endof

    endcase
    skip-element
  if exit then again \ until  -- Jump too far :-)

;

: t-crosstoken-irq ( token -- )

  org @ over addrintarget> t! \ Die Adresse im Target in der Primitive vermerken, damit sie angesprungen werden kann

  0 registerusage ! \ Noch wurden keine Register verwendet.

\  dup t-seetoken

  dup

    dup primitive> t@
    if insertprimitive
    else
      \ ." Unprimitive Definition" drop
      crosscompiledefinition
    then

    tidyup-ra

  registerusage> registerusage @ swap t! \ Die verwendeten Register vermerken.
;

: t-crosstoken ( token -- )
  \ org @ hex. dup t-name. cr  \ Wohin wird es kompiliert ?

  t-crosstoken-irq
  retopcode image,
;



: variableninit ( -- )
  \ Geht das Dictionary einmal komplett durch schreibt die Initialisierungswerte in die Variablen.

  t-dictionaryend
  begin

    dup raminit> t@ 0<
    if
      dup usage> t@ 0 >
      if
        \ ." Variable : "
        \ dup addrintarget> t@ hex. \ Die Adresse der Variablen im Ziel
        \ ." Anfangswert: "
        \ dup raminit> t@ $FFFF and hex. \ Der Initialisierungswert, der später geschrieben werden muss


        \ An dieser Stelle nun mov #..., &... Opcodes konstruieren, natürlich mit Konstantengenerator.

        dup raminit> t@ $FFFF and  \ Der Initialisierungswert, der später geschrieben werden muss
        $40B2 konstantengenerator   \ Natürlich kurze Konstanten optimieren
        dup addrintarget> t@ image,  \ Die Adresse der Variablen im Ziel

      then
    then

    t-dictionarybefore
  until
  drop
;

: reset-vorspann ( definition -- definition )
  \ Disable Watchdog, strictly necessary for real chips

  $40B2 image,  \ mov.w #5A80h, &120h
  $5A80 image,
  $0120 image,

  \ Prepare stack pointers

  $4031 image,  \ mov.w #const, r1
  initialreturnstack image,

  $4034 image,  \ mov.w #const, r4
  initialdatastack      image,

  \ Initialise variables
  variableninit
;

: reset-nachspann ( definition -- definition )
  $3FFF image, \ - jmp -   Endlosschleife als Falle
;


: unkanonisch? ( register -- ? ) \ Kommt dieser Register im kanonischen Grundzustand vor ? Wenn ja, braucht er nicht gesichert zu werden :-)

  dup kanonischer-zustand @ kanon-tos + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-nos + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-3os + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-4os + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-5os + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-6os + @ = if drop false exit then

  dup kanonischer-zustand @ kanon-tor + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-nor + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-3or + @ = if drop false exit then
  dup kanonischer-zustand @ kanon-4or + @ = if drop false exit then

  drop
  true
;



0 variable registersicherung
0 variable stellensicherung

\ Wenn Elemente auf Grund des kanonischen Rückfalls grundsätzlich im Register liegen, müssen diese Register nicht mehr separat gesichert zu werden.

: irq-push ( -- ) \ ." Push " registersicherung @ hex. cr \ exit

  registersicherung @

    5 unkanonisch? if   dup 1  5 lshift and if $1205 image, then   then
    6 unkanonisch? if   dup 1  6 lshift and if $1206 image, then   then
    7 unkanonisch? if   dup 1  7 lshift and if $1207 image, then   then
    8 unkanonisch? if   dup 1  8 lshift and if $1208 image, then   then
    9 unkanonisch? if   dup 1  9 lshift and if $1209 image, then   then
   10 unkanonisch? if   dup 1 10 lshift and if $120A image, then   then
   11 unkanonisch? if   dup 1 11 lshift and if $120B image, then   then
   12 unkanonisch? if   dup 1 12 lshift and if $120C image, then   then
   13 unkanonisch? if   dup 1 13 lshift and if $120D image, then   then
   14 unkanonisch? if   dup 1 14 lshift and if $120E image, then   then
   15 unkanonisch? if   dup 1 15 lshift and if $120F image, then   then

  drop
;

1 16 lshift constant wakeup-register \ Einfach eine Bitmaske, für die kein physikalischer Register existiert.

: irq-pop ( -- ) \ ." Pop " registersicherung @ hex. cr \ exit

  registersicherung @

   15 unkanonisch? if   dup 1 15 lshift and if $413F image, then   then
   14 unkanonisch? if   dup 1 14 lshift and if $413E image, then   then
   13 unkanonisch? if   dup 1 13 lshift and if $413D image, then   then
   12 unkanonisch? if   dup 1 12 lshift and if $413C image, then   then
   11 unkanonisch? if   dup 1 11 lshift and if $413B image, then   then
   10 unkanonisch? if   dup 1 10 lshift and if $413A image, then   then
    9 unkanonisch? if   dup 1  9 lshift and if $4139 image, then   then
    8 unkanonisch? if   dup 1  8 lshift and if $4138 image, then   then
    7 unkanonisch? if   dup 1  7 lshift and if $4137 image, then   then
    6 unkanonisch? if   dup 1  6 lshift and if $4136 image, then   then
    5 unkanonisch? if   dup 1  5 lshift and if $4135 image, then   then

  \ Falls dieser spezielle Aufwach-Register auftaucht, das Ende des Interruptvektors vor dem RETI noch mit einem bic.w #F0h, 2h(r1) Opcode ausstatten:
  wakeup-register and if $C0B1 image, $00F0 image, $0002 image, then
;

: irq-vorspann  ( definition -- definition )  dup vector> t@ $FFFE = if reset-vorspann  else irq-push               then ;
: irq-nachspann ( definition -- definition )  dup vector> t@ $FFFE = if reset-nachspann else irq-pop   $1300 image, then ;

: targetimage-vector ( definition -- definition )
  \ Eintrag in der Vektor-Tabelle anlegen
  org @ over vector> t@ image!  \ Vector table entry

  org @ stellensicherung ! \ Vermerken, wohin org nach Ende der Probekompilation zurückgesetzt werden muss

    dup t-crosstoken-irq \ Einmal zur Probe kompilieren, um zu sehen, welche Register dabei verwendet werden.
    dup registerusage> t@ registersicherung ! \ Die verwendeten Register merken

  \ Jetzt kennen wir den Registerbedarf und müssen die Kompilation zurücknehmen, damit der Interrupt-Rahmen geschrieben werden kann.

  dup adresszuordnungputzen
  stellensicherung @ org !

  \ Interrupt-Vorspann schreiben
  \ Hier kommt für den Reset-Vektor etwas anderes hin als für andere Vektoren, später.
  irq-vorspann

  \ Den Inhalt des Vektors schreiben - das kann, muss aber nicht Inline sein, falls die Definition in mehreren Vektoren verwendet wird.
  \ org @ hex. dup t-name. cr  \ Wohin wird es kompiliert ?
  dup t-crosstoken-irq

  \ Interrupt-Nachspann schreiben
  irq-nachspann
;

: variablenprobe ( -- )
  variablenpointer @ stackarea u>= if ." Ram full." cr quit then
;

: speicherbedarf ( -- )
    cr org @ flashstart -       ." Memory usage in Flash without vector table " u. ." bytes." cr
 variablenpointer @ ramstart -  ." Memory usage in RAM   without stacks       " u. ." bytes." cr
;

: crosscompile-pass ( -- )

  clearmemory        \ Speicher putzen
  flashstart org !    \ Anfangsadresse passend setzen
  ramstart variablenpointer ! \ Die RAM-Benutzung zurücksetzen
  init-ra              \ Den Registerallokator in den Urzustand zurückversetzen
  \ cr cr

  t-dictionaryend
  begin

    dup vector> t@ 0<>
    if

      targetimage-vector

    else \ Nein, es ist kein Interrupt-Vektor.
        dup usage> t@ 0<>
        if \ Diese Definition wird mindestens einmal verwendet.
           \ Soll sie kompiliert werden, oder muss an dieser Stelle Speicher angefordert werden ?

          dup ramallot> t@ 0<>
          if \ Speicher anfordern und Adresse im Target vermerken

            \ ." Speicher anfordern !"
            variablenpointer @ over addrintarget> t! \ Vermerke die RAM-Adresse in dem Feld der "Target-Adresse" der Primitive.
            dup ramallot> t@ variablenpointer +! variablenprobe \ RAM-Adresse im Target weiterrücken

          else \ Normal kompilieren
            dup inline? not
            if dup ( .s ) t-crosstoken then
          then
        then
    then
    t-dictionarybefore
  until
  drop

;

0 variable pass#

: crosscompile ( -- )

  0 pass# !

  make-clean         \ Alle Reste vorhergegangener Kompilationen putzen
  verwendungsproben   \ Prüfen, welche Definitionen verwendet werden

  begin
    false noch-ein-pass? !
    false schon-ein-snapshot-festgelegt? !
    1 pass# +!

    \ cr
    \ ." ----------------------------------------------------------------" cr
    \ ."   Pass " pass# @ . cr
    \ ." ----------------------------------------------------------------" cr
    crosscompile-pass
    \ speicherbedarf

    noch-ein-pass? @
  while
    verwendungsputzen
    verwendungsproben
  repeat


  speicherbedarf
  ." Required passes: " pass# @ . cr
;
