#
#    Mecrisp-Quintus - A native code Forth implementation for RISC-V
#    Copyright (C) 2018  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/>.
#

# Interpreter und Optimierungen
# Interpreter and optimisations

# -----------------------------------------------------------------------------
  Definition Flag_visible, "evaluate" # ( -- )
# -----------------------------------------------------------------------------
  push x1
  call source             # Save current source
  
  # 2>r
  popdadouble x5, x6
  #popda x5
  #popda x6
  pushdouble x6, x5
  #push x6
  #push x5

  li x6, Pufferstand  # Save >in and set to zero
  lw x5, 0(x6)
  push x5
  li x5, 0
  sw x5, 0(x6)

  call setsource          # Set new source
  call interpret          # Interpret

  li x6, Pufferstand  # Restore >in
  pop x5
  sw x5, 0(x6)

  # 2r>
  popdouble x5, x6
  #pop x5
  #pop x6
  pushdadouble x6, x5
  #pushda x6
  #pushda x5

  call setsource          # Restore old source

  pop x1
  ret

# -----------------------------------------------------------------------------
  Definition Flag_visible, "interpret" # ( -- )
interpret:
# -----------------------------------------------------------------------------
  push x1

1:# Bleibe solange in der Schleife, wie token noch etwas zurückliefert.
  # Stay in loop as long token can fetch something from input buffer.

  # Probe des Datenstackpointers.
  # Check pointer for datastack.

  li x10, datenstackanfang   # Stacks fangen oben an und wachsen nach unten.
  bgeu x10, x4, 2f           # Wenn die Adresse kleiner oder gleich der Anfangsadresse ist, ist alles okay.
    writeln "Stack underflow"
    j quit

2:li x10, datenstackende     # Solange der Stackzeiger oberhalb des Endes liegt, ist alles okay.
  bltu x10, x4, 3f
    writeln "Stack overflow"
    j quit

3: # Alles ok.  Stacks are fine.

# -----------------------------------------------------------------------------

  # Konstantenfaltungszeiger setzen, falls er das noch nicht ist.
  # Set Constant-Folding-Pointer
  li x14, konstantenfaltungszeiger
  lw x15, 0(x14)
  bne x15, zero, 3f
    # Konstantenfaltungszeiger setzen.
    # If not set yet, set it now.
    mv x15, x4
    sw x15, 0(x14)
3:

# -----------------------------------------------------------------------------
  call token
  # ( Address Length )

  # Prüfe, ob der String leer ist  Check if token is empty - that designates an empty input buffer.
  bne x3, zero, 2f
    ddrop
    pop x1
    ret
2:

# -----------------------------------------------------------------------------
  # String aus Token angekommen.  We have a string to interpret.
  # ( Address Length )

  # Registerkarte:
  #  r4: Adresse des Konstantenfaltungszeigers  Address of constant folding pointer
  #  r5: Konstantenfaltungszeiger               Constant folding pointer

  ddup
  call find # Probe, ob es sich um ein Wort aus dem Dictionary handelt:  Attemp to find token in dictionary.
  # ( Token-Addr Token-Length Addr Flags )

  popdadouble x11, x12
  #popda x11 # Flags
  #popda x12 # Einsprungadresse

  # ( Token-Addr Token-Length )

  # Registerkarte:
  #  x11: Flags                                  Flags
  #  x12: Einsprungadresse                       Code entry point
  #  x14: Adresse des Konstantenfaltungszeigers  Address of constant folding pointer
  #  x15: Konstantenfaltungszeiger               Constant folding pointer

  bne x12, zero, 4f
    # Nicht gefunden. Ein Fall für Number.
    # Entry-Address is zero if not found ! Note that Flags have very special meanings in Mecrisp !

    lw x10, 0(x4)
    mv x11, x3

    call number

  # Number gives back ( 0 ) or ( x 1 ).
  # Zero means: Not recognized.
  # Note that literals actually are not written/compiled here.
  # They are simply placed on stack and constant folding takes care of them later.

    popda x12   # Flag von Number holen
    bne x12, zero, 1b # Did number recognize the string ?
    # Zahl gefunden, alles gut. Interpretschleife fortsetzen.  Finished.

    # Number mochte das Token auch nicht.
    pushdadouble x10, x11
    #pushda x10
    #pushda x11
    call type
    writeln " not found."
    j quit

# -----------------------------------------------------------------------------
4:# Token im Dictionary gefunden. Found token in dictionary. Decide what to do.

  # ( Token-Addr Token-Length )

  # Registerkarte:
  #  x11: Flags                                  Flags
  #  x12: Einsprungadresse                       Code entry point
  #  x14: Adresse des Konstantenfaltungszeigers  Address of constant folding pointer
  #  x15: Konstantenfaltungszeiger               Constant folding pointer

  li x13, state
  lw x13, 0(x13)
  bne x13, zero, 5f
    # Im Ausführzustand.  Execute.
    li x15, 0   # Konstantenfaltungszeiger löschen  Clear constant folding pointer
    sw x15, 0(x14)  # Do not collect literals for folding in execute mode. They simply stay on stack.

    li x5, Flag_immediate_compileonly & ~Flag_visible
    and x13, x11, x5
    bne x13, x5, ausfuehren
      call type
      writeln " is compile-only."
      j quit

ausfuehren:
    ddrop
    pushda x12    # Adresse zum Ausführen   Code entry point
    call execute  #                         Execute it
    j 1b          # Interpretschleife fortsetzen.  Finished.

  # Registerkarte:
  #  x10: Stringadresse des Tokens, wird ab hier nicht mehr benötigt.  
  #       Wird danach für die Zahl der benötigten Konstanten für die Faltung genutzt.
  #       From now on, this is number of constants that would be needed for folding this definition
  #  x11: Flags
  #  x13: Temporärer Register, ab hier: Konstantenfüllstand  Constant fill gauge of Datastack
  #  x12: Einsprungadresse                        Code entry point
  #  x14: Adresse des Konstantenfaltungszeigers.  Address of constant folding pointer
  #  x15: Konstantenfaltungszeiger                Constant folding pointer

# -----------------------------------------------------------------------------
5:# Im Kompilierzustand.  In compile state.
    ddrop

    # Prüfe das Ramallot-Flag, das automatisch 0-faltbar bedeutet:
    # Ramallot-Words always are 0-foldable !
    # Check this first, as Ramallot is set together with foldability,
    # but the meaning of the lower 4 bits is different.

    andi x10, x11, Flag_ramallot & ~Flag_visible # Flagfeld auf Faltbarkeit hin prüfen
    bne x10, zero, interpret_faltoptimierung

    # Bestimme die Anzahl der zur Faltung bereitliegenden Konstanten:
    # Calculate number of folding constants available.

    sub x13, x15, x4 # Konstantenfüllstandszeiger - Aktuellen Stackpointer
    srli x13, x13, 2      # Durch 4 teilen  Divide by 4 to get number of stack elements.
    # Number of folding constants now available in x13.

    # Prüfe die Faltbarkeit des aktuellen Tokens:
    # Check for foldability.

    andi x10, x11, Flag_foldable & ~Flag_visible # Flagfeld auf Faltbarkeit hin prüfen
    beq x10, zero, konstantenschleife
    
#       # Check for opcodability.
#       movs r0, #Flag_opcodable & ~Flag_visible
#       ands r0, r1
#       beq.n .interpret_genugkonstanten # Flag is set
#       cmp r3, #0 # And at least one constant is available for folding.
#       beq.n .interpret_genugkonstanten
#         b.n .interpret_opcodierbar
      
interpret_genugkonstanten: # Not opcodable. Maybe foldable.
      # Prüfe, ob genug Konstanten da sind:
      # How many constants are necessary to fold this word ?
      andi x10, x11, 0x0F # Zahl der benötigten Konstanten maskieren
      bltu x13, x10, konstantenschleife

interpret_faltoptimierung:
        # Do folding by running the definition. 
        # Note that Constant-Folding-Pointer is already set to keep track of results calculated.
        pushda x12 # Einsprungadresse bereitlegen  Code entry point
        call execute # Durch Ausführung falten      Fold by executing
        j 1b # Interpretschleife weitermachen     Finished.

    # No optimizations possible. Compile the normal way.
    # Write all folding constants left into dictionary.

konstantenschleife:
    call konstantenschreiben

# -----------------------------------------------------------------------------
  # Classic compilation.
  pushda x12 # Adresse zum klassischen Bearbeiten. Put code entry point on datastack.

  andi x12, x11, Flag_immediate & ~Flag_visible
  beq x12, zero, 6f
    # Es ist immediate. Immer ausführen. Always execute immediate definitions.
    call execute # Ausführen.
    j 1b # Zurück in die Interpret-Schleife.  Finished.

6:andi x12, x11, Flag_inline & ~Flag_visible
  beq x12, zero, 7f
    call inlinekomma # Direkt einfügen.        Inline the code
    j 1b # Zurück in die Interpret-Schleife  Finished.

7:call callkomma # Klassisch einkompilieren  Simply compile a call.
  j 1b # Zurück in die Interpret-Schleife  Finished.


# # -----------------------------------------------------------------------------
# .interpret_opcodierbar: # Special case: Opcodable !
# 
#   # Flags of Definition in r1
#   # Entry-Point of Definition in r2
#   # Number of folding constants available in r3, at least one
# 
#   # Decide on the different cases. As I don't return, I can change Flag register freely.  
#   movs r0, #7 # Mask for opcoding cases
#   ands r1, r0
# 
#   # Most opcodable cases have special opcodes at the end of the definition.
#   # Prepare this place to be available in r0
#   movs r0, r2 # Entry point
#   bl suchedefinitionsende # Search for end of Definition
# 
#   cmp r1, #1
#   bne.n .interpret_opcodierbar_rechenlogik
#     #------------------------------------------------------------------------------
#     # Plus and Minus
#     # Available as short Opcode on all Cores
# 
#     cmp r3, #1
#     bne.n .interpret_faltoptimierung # Opcode only with exactly one constant. Do folding with two constants or more in this case !
#     # Exactly one constant.
# 
#     # Is constant small enough to fit in one Byte ?
#     movs r1, #0xFF  # Mask for 8 Bits
#     ands r1, tos
#     cmp r1, tos
#     bne.n 2f
#     # Equal ? Constant fits in 8 Bits.
# 
#       ldrh r0, [r0, #2] # Fetch Opcode, two more for Register-Opcode
#       orrs tos, r0 # Put constant into Opcode
#       bl hkomma
#       b.n 1b # Finished.
#       
# 2:  
# 
#     .ifndef m0core
#       # M3/M4 cores offer additional opcodes with 12-bit encoded constants.
#       bl twelvebitencoding
# 
#       cmp tos, #0
#       drop   # Preserves Flags !
#       beq 3f
#         # Encoding of constant within 12 bits is possible. Generate Opcode !
#         ldr r0, [r0, #4] # Fetch 32-Bit-Opcode, this is possible without alignment here,
#                          # Four more for M3/M4-Opcodes
#         orrs tos, r0
#         bl reversekomma
#         b.n 1b # Finished.
# 3:
#     .endif
# 
# .interpret_opcodieren_ueber_r0:
#     # Large constant without short encoding possibility. Put it in register first.
#     pushdaconst 0
#     bl registerliteralkomma
# 
#     pushdatos
#     ldrh tos, [r0] # Fetch Opcode
#     bl hkomma
#     b.n 1b # Finished.
# 
# 
# .interpret_opcodierbar_rechenlogik:
#   cmp r1, #2
#   bne.n .interpret_opcodierbar_gleichungleich
#     #------------------------------------------------------------------------------
#     # Calculus and Logic (Rechenlogik)
#     # M0 only supports logic with register operands.
# 
#     cmp r3, #1
#     bne.n .interpret_faltoptimierung # Opcode only with exactly one constant. Do folding with two constants or more in this case !
#     # Exactly one constant. M0 needs all constant sizes available in registers.
#     b.n .interpret_opcodieren_ueber_r0 # Simply reuse code as for plus and minus.
# 
# 
# .interpret_opcodierbar_gleichungleich:
#   cmp r1, #3
#   bne.n .interpret_opcodierbar_schieben
#     #------------------------------------------------------------------------------
#     # Equal and Unequal. 
# 
#     cmp r3, #1
#     bne.n .interpret_faltoptimierung # Opcode only with exactly one constant. Do folding with two constants or more in this case !
#     # Exactly one constant.
# 
#     # Is constant small enough to fit in one Byte ?
#     movs r1, #0xFF  # Mask for 8 Bits
#     ands r1, tos
#     cmp r1, tos
#     bne.n 2f
#     # Equal ? Constant fits in 8 Bits.
# 
#       ldr r1, =0x3E00 # Opcode subs r6, #0
#       orrs tos, r1
#       bl hkomma
# 
# 4:    adds r2, #4 # Skip first two instructions of definition
#       pushda r2
#       bl inlinekomma
#       b.n 1b # Finished.
#  
# 2:  
# 
#     .ifndef m0core
#       # M3/M4 cores offer additional opcodes with 12-bit encoded constants.
#       bl twelvebitencoding
# 
#       cmp tos, #0
#       drop   # Preserves Flags !
#       beq 3f
#         # Encoding of constant within 12 bits is possible.
#         ldr r1, =0xF1B60600 # Opcode subs tos, tos, #imm12
#         orrs tos, r1
#         bl reversekomma
#         b.n 4b
# 3:
#     .endif    
# 
#     # Larger constant. Put it in register first.
#     pushdaconst 0
#     bl registerliteralkomma
# 
#     adds r2, #2 # Skip first instruction of definition
#     pushda r2
#     bl inlinekomma
#     b.n 1b # Finished.
# 
# 
# .interpret_opcodierbar_schieben:
#   cmp r1, #4
#   bne.n .interpret_opcodierbar_speicherschreiben
#     #------------------------------------------------------------------------------
#     # Logical Shifts.
# 
#     cmp r3, #1
#     bne.n .interpret_faltoptimierung # Opcode only with exactly one constant. Do folding with two constants or more in this case !
#     # Exactly one constant.
# 
#     popda r3 # Fetch constant
#     cmp r3, #0
#     bne.n 2f
#     b.n 1b # Shift by zero ? No Opcode to generate. Finished !
# 
# 2:  movs r2, #0x1F # 5 Bits
#     ands r2, r3
#     cmp r2, r3 # Does shift fit in 5 Bits ?
#     beq.n 3f
#       # Shift more than 31 Places - Zero out TOS or replace by an asrs tos, #31 opcode:
#       pushdatos
#       ldrh tos, [r0, #2] # Fetch next opcode
#       bl hkomma
#       b.n 1b # Finished.
# 
# 3:  pushdatos
#     ldrh tos, [r0] # Fetch Opcode
#     lsls r3, #6  # Shift places accordingly
#     orrs tos, r3  # Build shift opcode
#     bl hkomma
#     b.n 1b # Finished.
# 
# 
# .interpret_opcodierbar_speicherschreiben:
#   cmp r1, #5
#   bne.n .interpret_opcodierbar_andere
#     #------------------------------------------------------------------------------
#     # Write memory
# 
#     cmp r3, #1
#     bne.n 2f # Exactly one constant
# 
#     pushdaconst 0
#     bl registerliteralkomma
# 
#     pushda r0
#     bl inlinekomma
# 
#     # Compile Drop-Opcode
#     pushdaconstw 0xcf40 # Opcode for ldmia r7!, {r6}
#     bl hkomma
#     b.n 1b # Finished.
# 
# 2:  # Two or more constants.
#     pushdaconst 0
#     bl registerliteralkomma
# 
#     pushdaconst 1
#     bl registerliteralkomma
# 
#     bl suchedefinitionsende
# 
#     pushda r0
#     bl inlinekomma
#     b.n 1b # Finished.
# 
# .interpret_opcodierbar_andere:
# 
#   .ifndef m0core # This is for M3/M4 only
#   #------------------------------------------------------------------------------
#   # Check for architecture-specific special cases:
# 
#   cmp r1, #6
#   bne.n 2f
#     #------------------------------------------------------------------------------
#     # Logic with special opcodings available on M3/M4 only
#     cmp r3, #1
#     bne .interpret_faltoptimierung # Opcode only with exactly one constant. Do folding with two constants or more in this case !
# 
#     # Check if constant available can be encoded as 12-bit-bitmask
#     bl twelvebitencoding
# 
#     cmp tos, #0
#     drop   # Preserves Flags !
#     beq .interpret_opcodieren_ueber_r0 # Simply reuse code as for plus and minus.
# 
#       # 12-bit-encoding is possible. Generate the opcode :-)
# 
#       ldr r0, [r0, #2] # Fetch 32-Bit Thumb-2 Opcode, this can be done on M3/M4 without alignment
#                    # Two more for the advanced M3-Opcode
#       orrs tos, r0
#       bl reversekomma
#       b.n 1b # Finished.
# 2:
#   .endif
# 
#   #------------------------------------------------------------------------------
#   # Special cases that do not have their own handling in interpret.
#   # They have their own handlers at the end of definition that is called here.
# 
#   adds r0, #1 # One more for Thumb
#   blx r0
#   b.n 1b # Finished.  


# -----------------------------------------------------------------------------
konstantenschreiben: # Special internal entry point with register dependencies.
# -----------------------------------------------------------------------------
  push x1
  beq x13, zero, 7f # Null Konstanten liegen bereit ? Zero constants available ?
                    # Dann ist nichts zu tun.         Nothing to write.

konstanteninnenschleife:
    # Schleife über x15 :-)
    # Loop for writing all folding constants left.
    addi x13, x13, -1 # Weil Pick das oberste Element mit Null addressiert.
    pushda x13

    call pick
    call literalkomma
   
    bne x13, zero, konstanteninnenschleife
   
    # Die geschriebenen Konstanten herunterwerfen.
    # Drop constants written.

    addi x4, x15, -4 # TOS wurde beim drauflegen der Konstanten gesichert.
    drop         # Das alte TOS aus seinem Platz auf dem Stack zurückholen.

7:li x15, 0   # Konstantenfaltungszeiger löschen  Clear constant folding pointer.
  sw x15, 0(x14)
  pop x1
  ret


#------------------------------------------------------------------------------
  Definition Flag_visible|Flag_variable, "hook-quit" # ( -- addr )
  CoreVariable hook_quit
#------------------------------------------------------------------------------  
  pushdaconst hook_quit
  ret
  .word quit_innenschleife  # Simple loop for default

# -----------------------------------------------------------------------------
  Definition Flag_visible, "quit" # ( -- )
quit:
# -----------------------------------------------------------------------------
  # Endlosschleife - muss LR nicht sichern.  No need for saving LR as this is an endless loop.
  # Stacks zurücksetzen
  # Clear stacks and tidy up.

  li sp, returnstackanfang
  li x4, datenstackanfang

  .ifdef initflash
  call initflash
  .endif

  li x6, base
  li x5, 10      # Base decimal
  sw x5, 0(x6)

  li x6, state
  li x5, 0       # Execute mode
  sw x5, 0(x6)

  li x6, konstantenfaltungszeiger
  li x5, 0       # Clear constant folding pointer
  sw x5, 0(x6)

  li x6, Pufferstand
  li x5, 0       # Set >IN to 0
  sw x5, 0(x6)

  li x6, current_source
  li x5, 0       # Empty TIB is source
  sw x5, 0(x6)
  li x5, Eingabepuffer
  sw x5, 4(x6)

quit_intern:
  li x5, hook_quit
  lw x5, 0(x5)
  jalr zero, x5, 0

quit_innenschleife:  # Main loop of Forth system.
  call query
  call interpret
  writeln " ok."
  j quit_innenschleife

