#
#    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/>.
#

# Sprünge, Helferlein und Kontrollstrukturen
# Jumps, Utilities and Control Structures


# #------------------------------------------------------------------------------
#   Definition Flag_visible, "cjump," # Fügt einen bedingten Sprung ein. Write a conditional jump into dictionary
# cjumpgenerator: # ( Adresse-der-Opcodelücke Sprungziel Bitmaske -- )
#                 # ( Address-of-hole-for-jump Target Bitmask -- )
# #------------------------------------------------------------------------------
#   popda r2 # Bitmaske    Bitmask for jump condition
#   popda r1 # Sprungziel  Target
#   # popda r0 # Adresse-der-Opcodelücke - bleibt auf dem Stack  Hole to fill in opcode - keep that on stack
# 
#   # Calculate jump offset.
#   subs r3, r1, tos # Differenz aus Lücken-Adresse und Sprungziel bilden  Calculate relative jump offset
#   subs r3, #4      # Da der aktuelle Befehl noch läuft und es komischerweise andere Offsets beim ARM gibt.  Current instruction still running...
# 
#   # 8 Bits für die Sprungweite mit Vorzeichen -
#   # also habe ich 7 freie Bits, das oberste muss mit dem restlichen Vorzeichen übereinstimmen.
# 
#   # Short conditional B.. opcodes support 8 Bits jump range - one of that for sign.
#   # Check if opcodable range is enough to reach target:
# 
# 
# 
#   # Generate proper jump opcode:
#   asrs r3, #1 # Schieben, da die Sprünge immer auf geraden Adressen beginnen und enden.  Shift one bit out as jumps always have an even offset
#   movs r1, #0xFF # Genau 8 Bits Sprungmaske.  Exactly 8 Bits available -
#   ands r3, r1    # Ausschnitt anwenden          mask them to clip sign bits
# 
#   orrs r3, r2    # Sprungbedingung und den Rest des Opcodes hinzufügen  Or together with jump condition
#   movs r0, tos  # Adresse-der-Opcodelücke in r0 holen                    Exchange registers
#   movs tos, r3  # Sprungopcode stattdessen hineinlegen
# 
# sprungbefehl_einfuegen: # strh r3, [r0] over h, to handle Flash writes
#   push {lr}
#     # Opcode auf dem Stack, Adresse in r0
#     # Dictionary-Pointer verbiegen:
#       # Dictionarypointer sichern
#       ldr r2, =Dictionarypointer
#       ldr r3, [r2] # Alten Dictionarypointer auf jeden Fall bewahren
# 
#       str r0, [r2] # Dictionarypointer umbiegen
#       bl hkomma    # Opcode einfügen
#       str r3, [r2] # Dictionarypointer wieder zurücksetzen.
#   pop {pc}
# 
# #------------------------------------------------------------------------------
#   Definition Flag_visible, "jump," # Fügt einen unbedingten Sprung ein.  Write an unconditional jump into dictionary
# jumpgenerator: # ( Adresse-der-Opcodelücke Sprungziel -- )
#                # ( Address-of-hole-for-jump Target -- )
# #------------------------------------------------------------------------------
#   popda r1 # Sprungziel  Target
#   popda r0 # Adresse-der-Opcodelücke  Hole to fill in opcode
# 
#   subs r3, r1, r0 # Differenz aus Lücken-Adresse und Sprungziel bilden  Calculate relative jump offset
#   subs r3, #4     # Da der aktuelle Befehl noch läuft und es komischerweise andere Offsets beim ARM gibt.   Current instruction still running...
# 
#   # 11 Bits für die Sprungweiter mit Vorzeichen -
#   # also habe ich 10 freie Bits, das oberste muss mit dem restlichen Vorzeichen übereinstimmen.
# 
#   # Short unconditional B opcodes support 11 Bits jump range - one of that for sign.
#   # Check if opcodable range is enough to reach target:
# 
#   ldr r1, =0xFFFFF801  # 10 Bits frei
#   ands r1, r3
#   cmp r1, #0  # Wenn dies Null ergibt, positive Distanz ok.
#   beq 1f
# 
#   ldr r2, =0xFFFFF800
#   cmp r1, r2
#   bne.n jump_too_far # Wenn es gleich ist: Negative Distanz ok.
# 
# 1:
# 
#   asrs r3, #1 # Schieben, da die Sprünge immer auf geraden Adressen beginnen und enden. Shift one bit out as jumps always have an even offset
#   ldr r2, =0x7FF # Genau 11 Bits Sprungmaske.  Exactly 11 Bits available -
#   ands r3, r2     # Ausschnitt anwenden          mask them to clip sign bits
# 
#   .ifdef m0core
#     ldr r2, =0xE000
#     orrs r3, r2
#   .else
#     orrs r3, 0xE000  # Rest des Opcodes hinzufügen  Or together with B opcode
#   .endif
#   pushda r3
#   b.n sprungbefehl_einfuegen #  Befehl einfügen. strh r3, [r0] over h, to handle Flash writes
# 
# # -----------------------------------------------------------------------------
#   Definition Flag_visible, "here" # ( -- addr ) Gives Dictionarypointer
# here: # Gibt den Dictionarypointer zurück
# # -----------------------------------------------------------------------------
#   pushdatos    # Platz auf dem Datenstack schaffen
#   ldr tos, =Dictionarypointer
#   ldr tos, [tos] # Hole den Dictionarypointer
#   bx lr
# 
# # -----------------------------------------------------------------------------
#   Definition Flag_visible, "flashvar-here" # ( -- a-addr ) Gives RAM management pointer
# # -----------------------------------------------------------------------------
#   pushdatos
#   ldr tos, =VariablenPointer
#   ldr tos, [tos]
#   bx lr
# 
# #------------------------------------------------------------------------------
# # Verschiedene Sprünge, die von den Kontrollstrukturen gebracht werden.
# # Some jump primitives that are useful for building control structures
# #------------------------------------------------------------------------------
# 
# nullprobekomma: # Write code for comparing TOS to zero.
#   push {lr}
#   pushdaconstw 0x2e00 # cmp tos, #0
#   bl hkomma
#   pushdaconstw 0xcf40 # drop
#   bl hkomma
#   pop {pc}
# 
# branch_r:     # ( -- Sprungziel )  Einleitung bedingter und unbedingter Rückwärtssprung
#     b.n here  # ( -- Target )      Intro of conditional and unconditional backwards jump
# 
# r_branch_jne: # ( Sprungziel -- )  Abschluss besonderer bedingter Rückwärtssprung für loop
#   push {lr}   # ( Target -- )      Finalisation of special conditional backwards jump for loop
#   bl branch_v # ( pushda Dictionaryinter und 2 allot )
#   swap
#   pushdaconstw 0xD100 # Opcode für den bedingten Sprung bne  Opcode for conditional jump BNE
#   bl cjumpgenerator
#   pop {pc}
# 
# r_branch_jvc: # ( Sprungziel -- )  Abschluss besonderer bedingter Rückwärtssprung bei Überlauf für +loop
#   push {lr}   # ( Target -- )      Finalisation of conditional backwards jump on overflow for +loop
#   bl branch_v # ( pushda Dictionaryinter und 2 allot )
#   swap
#   pushdaconstw 0xD700 # Opcode für den bedingten Sprung bvc  Opcode for conditional jump BVC, used for +loop
#   bl cjumpgenerator
#   pop {pc}
# 
# r_nullbranch: # ( Sprungziel -- )  Abschluss bedingter Rückwärtssprung
#   push {lr}   # ( Target -- )      Finalisation of conditional backwards jump
#   bl nullprobekomma
#   bl branch_v # ( pushda Dictionaryinter und 2 allot )
#   swap
#   pushdaconstw 0xD000 # Opcode für den bedingten Sprung beq  Opcode for conditional jump BEQ
#   bl cjumpgenerator
#   pop {pc}
# 
# r_branch:     # ( Sprungziel -- )  Abschluss unbedingter Rückwärtssprung
#   push {lr}   # ( Target -- )      Finalisation of unconditional backwards jump
#   bl branch_v # ( pushda Dictionaryinter und 2 allot )
#   swap
#   bl jumpgenerator
#   pop {pc}
# 
# 
# nullbranch_v: # ( -- Adresse-für-Sprungbefehl )  Einleitung bedingter Vorwärtssprung
#   push {lr}   # ( -- Address-for-Opcode )        Intro of conditional forward jump
#   bl nullprobekomma
#   bl here
#   pushdaconst 2 # Platz für die Opcodelücke schaffen  Allot space for filling in Opcode later
#   bl allot
#   pop {pc}
# 
# branch_v:     # ( -- Adresse-für-Sprungbefehl )  Einleitung unbedingter Vorwärtssprung
#   push {lr}   # ( -- Address-for-Opcode )        Intro of unconditional forward jump
#   bl here
#   pushdaconst 2 # Platz für die Opcodelücke schaffen  Allot space for filling in Opcode later
#   bl allot
#   pop {pc}
# 
# 
# v_branch:      # ( Adresse-für-Sprungbefehl -- ) Abschluss unbedingter Vorwärtssprung
#   push {lr}    # ( Address-for-Opcode -- )       Finalisation of unconditional forward jump
#   bl here # Sprungziel auf den Stack legen  Put target for jump on datastack
#   bl jumpgenerator
#   pop {pc}
# 
# v_nullbranch:  # ( Adresse-für-Sprungbefehl -- ) Abschluss bedingter Vorwärtssprung
#   push {lr}    # ( Address-for-Opcode -- )       Finalisation of conditional forward jump
#   bl here # Sprungziel auf den Stack legen  Put target for jump on datastack
#   pushdaconstw 0xD000 # Opcode für den bedingten Sprung beq  Opcode for conditional jump BEQ
#   bl cjumpgenerator
#   pop {pc}
# 
# v_casebranch:  # ( Adresse-für-Sprungbefehl -- ) Abschluss besonderer bedingter Vorwärtssprung für case
#   push {lr}    # ( Address-for-Opcode -- )       Finalisation of special conditional forward jump for case
#   bl here # Sprungziel auf den Stack legen  Put target for jump on datastack
#   pushdaconstw 0xD100 # Opcode für den bedingten Sprung bne  Opcode for conditional jump BNE
#   bl cjumpgenerator
#   pop {pc}
# 

#------------------------------------------------------------------------------
generate_uj_encoding:
#------------------------------------------------------------------------------
  push x1
  call uj_encoding_q
  popda x5
  beq x5, zero, jump_too_far
  pop x1
  ret

jump_too_far:
  writeln "Jump too far"
  j quit

#------------------------------------------------------------------------------
  Definition Flag_foldable_1, "uj-encoding?" # ( x -- x false | bitmask true )
uj_encoding_q:
#------------------------------------------------------------------------------

  li x5, 0xFFF80000 # Range BIT19 to BIT1, but lowest bit is ignored.
  and x6, x3, x5
  beq x6, x5, 1f
  bne x6, zero, 2f

1:# Constant fits in available bits !
  push x1
  call uj_encoding
  pushdaconst -1
  pop x1
  ret

2:pushdaconst 0
  ret

#------------------------------------------------------------------------------
uj_encoding: # ( addr -- x ) For unconditional jumps
#------------------------------------------------------------------------------

  # push x1
  # dup
  # write "UJ-Enc: "
  # call hexdot
  # writeln ""
  # pop x1

  push x10

    li x5, BIT19|BIT18|BIT17|BIT16|BIT15|BIT14|BIT13|BIT12
    and x10, x3, x5

    li x5, BIT11
    and x6, x3, x5
    srli x6, x6, 11
    slli x6, x6, 20
    or x10, x10, x6

    li x5, BIT10|BIT9|BIT8|BIT7|BIT6|BIT5|BIT4|BIT3|BIT2|BIT1
    and x6, x3, x5
    srli x6, x6, 1
    slli x6, x6, 21
    or x10, x10, x6

    li x5, BIT20
    and x6, x3, x5
    srli x6, x6, 20
    slli x6, x6, 31
    or x3, x10, x6
    
  pop x10
  ret

#------------------------------------------------------------------------------
generate_sb_encoding:
#------------------------------------------------------------------------------
  push x1
  call sb_encoding_q
  popda x5
  beq x5, zero, jump_too_far
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_foldable_1, "sb-encoding?" # ( x -- x false | bitmask true )
sb_encoding_q:
#------------------------------------------------------------------------------

  li x5, 0xFFFFF000 # Range BIT12 to BIT1, but lowest bit is ignored.
  and x6, x3, x5
  beq x6, x5, 1f
  bne x6, zero, 2f

1:# Constant fits in available bits !
  push x1
  call sb_encoding
  pushdaconst -1
  pop x1
  ret

2:pushdaconst 0
  ret

#------------------------------------------------------------------------------
sb_encoding: # ( addr -- x ) For conditional jump
#------------------------------------------------------------------------------

  # push x1
  # dup
  # write "SB-Enc: "
  # call hexdot
  # writeln ""
  # pop x1

  push x10

    li x5, BIT11
    and x6, x3, x5
    srli x6, x6, 11
    slli x10, x6, 7

    li x5, BIT4|BIT3|BIT2|BIT1
    and x6, x3, x5
    srli x6, x6, 1
    slli x6, x6, 8
    or x10, x10, x6

    li x5, BIT10|BIT9|BIT8|BIT7|BIT6|BIT5
    and x6, x3, x5
    srli x6, x6, 5
    slli x6, x6, 25
    or x10, x10, x6

    li x5, BIT12
    and x6, x3, x5
    srli x6, x6, 12
    slli x6, x6, 31
    or x3, x10, x6
    
  pop x10
  ret

#------------------------------------------------------------------------------
nullprobekomma: # ( -- ) Get TOS into x5 for a following conditional jump.
#------------------------------------------------------------------------------
  push x1

  # Opcodes for "popda x5"
  pushdaconst 0x00018293
  call komma
  pushdaconst 0x00022183
  call komma
  pushdaconst 0x00420213
  call komma

  pop x1
  ret


#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "then"
  # ( Adresse-für-Sprung 2 | Adresse-für-Sprung 5 -- )
  # ( Address-for-Jump 2   | Address-for-Jump 5 --)
struktur_then:
#------------------------------------------------------------------------------
  push x1

  popda x5
  li x6, 5 # Unbedingten Vorwärtssprung einfügen
  bne x5, x6, 1f
    
    # Abschluss unbedingter Vorwärtssprung  Fill in unconditional forward jummp
    # ( Sprunglücke )
    dup
    call here
    # ( Sprunglücke Sprunglücke Sprungziel )
    swap
    call minus

    call generate_uj_encoding
    ori x3, x3, 0x0000006f # jal zero, 0
    
    # ( Sprunglücke Opcode )
    swap
    call kommairgendwo
    pop x1
    ret


1:li x6, 2 # Bedingten Vorwärtssprung einfügen
  bne x5, x6, strukturen_passen_nicht

    # Abschluss bedingter Vorwärtssprung Fill in conditional forward jump
    # ( Sprunglücke )
    dup
    call here
    # ( Sprunglücke Sprunglücke Sprungziel )
    swap
    call minus

    call generate_sb_encoding
    li x5, 0x00028063 # beq x5, zero, 0
    or x3, x3, x5
    
    # ( Sprunglücke Opcode )
    swap
    call kommairgendwo
    pop x1
    ret

strukturen_passen_nicht:
  writeln "Structures don't match"
  j quit

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "else"
struktur_else:
#------------------------------------------------------------------------------
  push x1
  call struktur_ahead
  call dswap
  call struktur_then
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "if"
struktur_if: # ( -- Adresse-für-Sprung 2 )   ( -- Address-for-Jump 2 )
#------------------------------------------------------------------------------
  push x1

    call nullprobekomma

    call here
    pushdaconst 4
    call allot

  pushdaconst 2           # Strukturerkennung  Structure matching
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "ahead"
struktur_ahead: # ( -- Adresse-für-Sprung 5 )   ( -- Address-for-Jump 5 )
#------------------------------------------------------------------------------
  push x1

    call here
    pushdaconst 4
    call allot

  pushdaconst 5           # Strukturerkennung  Structure matching
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "repeat"
#------------------------------------------------------------------------------
  push x1
  call struktur_again
  call struktur_then
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "while"
#------------------------------------------------------------------------------
  push x1
  call struktur_if
  call dswap
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "until"  # Bedingte Schleife
  # ( Sprungziel 1 -- )                          # Conditional loop
#------------------------------------------------------------------------------
struktur_until:
  push x1
  popda x5
  li x6, 1
  bne x5, x6, strukturen_passen_nicht

    # Write conditional backward jump
    
    call nullprobekomma

    call here
    call minus
    call generate_sb_encoding
    li x5, 0x00028063 # beq x5, zero, 0
    or x3, x3, x5
    call komma

  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "again"  # Endlosschleife
struktur_again:  # ( Sprungziel 1 -- )           # Unconditional loop
#------------------------------------------------------------------------------
  push x1
  popda x5
  li x6, 1
  bne x5, x6, strukturen_passen_nicht

    # Write unconditional backward jump

    call here
    call minus
    call generate_uj_encoding
    ori x3, x3, 0x0000006f # jal zero, 0
    call komma
    
  pop x1
  ret

#------------------------------------------------------------------------------
  Definition Flag_immediate_compileonly, "begin"
  # ( -- Sprungziel 1 )  ( -- Jump-destination 1 )
#------------------------------------------------------------------------------
struktur_begin:
  push x1
  call here
  pushdaconst 1  # Strukturerkennung  Structure matching
  pop x1
  ret
