{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NumericUnderscores #-}

module Decode(decode, DecodeResult(..)) where

import DecodeTypes(
  RTypeFields(..), ITypeFields(..), STypeFields(..),
  BTypeFields(..), UTypeFields(..), JTypeFields(..),
  Opcode(..)
  )
import Clash.Prelude
import Fetch(FetchResult (Instruction, InstructionException))
import Exceptions(Exception(..))
import Types(Insn)
import RegFiles(RegVal(..))
import Util((|>))

data DecodeResult = Opcode Opcode
                  | DecodeException Exception
                  | InstructionException Exception
                  deriving (Generic, Show, Eq, NFDataX)

decode :: FetchResult -> DecodeResult
decode (Instruction insn) =
  case insnToOpcode insn of
    Just opcode -> Opcode opcode
    Nothing     -> DecodeException |> IllegalInstruction insn
decode (Fetch.InstructionException exception) =
  Decode.InstructionException exception

insnToOpcode :: Insn -> Maybe Opcode
insnToOpcode insn =
      decodeRType insn `chainAndTry`
      decodeIType insn `chainAndTry`
      decodeSType insn `chainAndTry`
      decodeBType insn `chainAndTry`
      decodeUType insn `chainAndTry`
      decodeJType insn
  where
    chainAndTry :: Maybe Opcode -> Maybe Opcode -> Maybe Opcode
    chainAndTry (Just left)    _ = Just left
    chainAndTry Nothing (Just right) = Just right
    chainAndTry _ _ = Nothing

decodeRType :: Insn -> Maybe Opcode
decodeRType insn =
  case opcode of
    0b0110011 ->
      case funct3 of
        0x00 -> case funct7 of
                  0x00 -> Just |> ADD (RTypeFields rd funct3 rs1 rs2 funct7)
                  0x20 -> Just |> SUB (RTypeFields rd funct3 rs1 rs2 funct7)
                  _    -> Nothing
        0x04 -> Just |> XOR (RTypeFields rd funct3 rs1 rs2 funct7)
        0x06 -> Just |> OR  (RTypeFields rd funct3 rs1 rs2 funct7)
        0x07 -> Just |> AND (RTypeFields rd funct3 rs1 rs2 funct7)
        0x01 -> Just |> SLL (RTypeFields rd funct3 rs1 rs2 funct7)
        0x05 -> case funct7 of
                  0x00 -> Just |> SRL (RTypeFields rd funct3 rs1 rs2 funct7)
                  0x20 -> Just |> SRA (RTypeFields rd funct3 rs1 rs2 funct7)
                  _    -> Nothing
        0x02 -> Just |> SLT  (RTypeFields rd funct3 rs1 rs2 funct7)
        0x03 -> Just |> SLTU (RTypeFields rd funct3 rs1 rs2 funct7)
        _    -> Nothing
    _ -> Nothing
  where
    opcode = getOpcode insn
    rd     = getRd     insn
    funct3 = getFunct3 insn
    rs1    = getRs1    insn
    rs2    = getRs2    insn
    funct7 = getFunct7 insn

decodeIType :: Insn -> Maybe Opcode
decodeIType insn = case opcode of
    0b0010011 -> case funct3 of
        0x0 -> Just |> ADDI  (ITypeFields rd funct3 rs1 imm)
        0x4 -> Just |> XORI  (ITypeFields rd funct3 rs1 imm)
        0x6 -> Just |> ORI   (ITypeFields rd funct3 rs1 imm)
        0x7 -> Just |> ANDI  (ITypeFields rd funct3 rs1 imm)
        0x1 -> if slice d31 d25 (pack insn) == 0
                then Just |> SLLI  (ITypeFields rd funct3 rs1 imm)
                else Nothing
        0x5 -> case slice d31 d25 (pack insn) of            -- Distinguish SRLI and SRAI
                  0x00 -> Just |> SRLI (ITypeFields rd funct3 rs1 imm)
                  0x20 -> Just |> SRAI (ITypeFields rd funct3 rs1 imm)
                  _    -> Nothing
        0x2 -> Just |> SLTI  (ITypeFields rd funct3 rs1 imm)
        0x3 -> Just |> SLTIU (ITypeFields rd funct3 rs1 imm)
        _   -> Nothing

    0b0000011 -> case funct3 of
        0x0 -> Just |> LB   (ITypeFields rd funct3 rs1 imm)
        0x1 -> Just |> LH   (ITypeFields rd funct3 rs1 imm)
        0x2 -> Just |> LW   (ITypeFields rd funct3 rs1 imm)
        0x4 -> Just |> LBU  (ITypeFields rd funct3 rs1 imm)
        0x5 -> Just |> LHU  (ITypeFields rd funct3 rs1 imm)
        _   -> Nothing

    0b1100111 -> case funct3 of
        0x0 -> Just |> JALR (ITypeFields rd funct3 rs1 imm)
        _   -> Nothing

    0b1110011 -> case imm of
        0x000 -> Just |> ECALL  (ITypeFields rd funct3 rs1 imm)
        0x001 -> Just |> EBREAK (ITypeFields rd funct3 rs1 imm)
        _     -> Nothing

    _ -> Nothing
  where
    opcode = getOpcode insn
    rd     = getRd     insn
    funct3 = getFunct3 insn
    rs1    = getRs1    insn
    imm    = getImm12  insn

decodeSType :: Insn -> Maybe Opcode
decodeSType insn =
  case opcode of
    0b0100011 -> case funct3 of
        0x0 -> Just |> SB (STypeFields funct3 rs1 rs2 imm12)  -- Store Byte
        0x1 -> Just |> SH (STypeFields funct3 rs1 rs2 imm12)  -- Store Halfword
        0x2 -> Just |> SW (STypeFields funct3 rs1 rs2 imm12)  -- Store Word
        _   -> Nothing
    _ -> Nothing
  where
    opcode = getOpcode insn
    funct3 = getFunct3 insn
    rs1    = getRs1    insn
    rs2    = getRs2    insn
    imm12  = getImm12SType insn

decodeBType :: Insn -> Maybe Opcode
decodeBType insn =
  case opcode of
    0b1100011 -> case funct3 of
        0x0 -> Just |> BEQ  (BTypeFields funct3 rs1 rs2 imm13)  -- Branch if equal
        0x1 -> Just |> BNE  (BTypeFields funct3 rs1 rs2 imm13)  -- Branch if not equal
        0x4 -> Just |> BLT  (BTypeFields funct3 rs1 rs2 imm13)  -- Branch if less than
        0x5 -> Just |> BGE  (BTypeFields funct3 rs1 rs2 imm13)  -- Branch if greater or equal
        0x6 -> Just |> BLTU (BTypeFields funct3 rs1 rs2 imm13)  -- Branch if less than (unsigned)
        0x7 -> Just |> BGEU (BTypeFields funct3 rs1 rs2 imm13)  -- Branch if greater or equal (unsigned)
        _   -> Nothing
    _ -> Nothing
  where
    opcode = getOpcode insn
    funct3 = getFunct3 insn
    rs1    = getRs1    insn
    rs2    = getRs2    insn
    imm13  = getImm13BType insn

decodeUType :: Insn -> Maybe Opcode
decodeUType insn = case opcode of
    0b0110111 -> Just |> LUI   (UTypeFields rd imm20)    -- LUI
    0b0010111 -> Just |> AUIPC (UTypeFields rd imm20)    -- AUIPC
    _         -> Nothing
  where
    opcode = getOpcode insn
    rd     = getRd     insn
    imm20  = getImm20UType insn

decodeJType :: Insn -> Maybe Opcode
decodeJType insn =
  case opcode of
    0b1101111 -> Just |> JAL (JTypeFields rd imm21)   -- JAL
    _         -> Nothing
  where
    opcode = getOpcode insn
    rd     = getRd insn
    imm21  = getImm21JType insn

getImm21JType :: Insn -> Unsigned 21
getImm21JType instr = bitCoerce |> imm20 ++# imm10_1 ++# imm11 ++# imm19_12 ++# zero
  where
    imm20    = slice d31 d31 (pack instr)      -- imm[20]
    imm10_1  = slice d30 d21 (pack instr)      -- imm[10:1]
    imm11    = slice d20 d20 (pack instr)      -- imm[11]
    imm19_12 = slice d19 d12 (pack instr)      -- imm[19:12]
    zero     = 0 :: BitVector 1                -- LSB always zero for J-type

getOpcode :: Insn -> Unsigned 7
getOpcode instr = bitCoerce |> slice d6 d0 (pack instr)

getImm12 :: Insn -> Unsigned 12
getImm12 instr = bitCoerce |> slice d31 d20 (pack instr)

getImm12SType :: Insn -> Unsigned 12
getImm12SType instr = bitCoerce |> immediateUpper ++# immediateLower
  where
    immediateUpper = (slice d31 d25 (pack instr))
    immediateLower = (slice d11 d7 (pack instr))

getImm20UType :: Insn -> Unsigned 20
getImm20UType instr = bitCoerce |> slice d31 d12 (pack instr)

getImm13BType :: Insn -> Unsigned 13
getImm13BType instr = bitCoerce |> imm12 ++# imm10_5 ++# imm4_1 ++# imm11 ++# zero
  where
    imm12   = slice d31 d31 (pack instr)      -- imm[12]
    imm10_5 = slice d30 d25 (pack instr)      -- imm[10:5]
    imm4_1  = slice d11 d8  (pack instr)      -- imm[4:1]
    imm11   = slice d7  d7  (pack instr)      -- imm[11]
    zero    = 0 :: BitVector 1                -- LSB always zero for B-type

getFunct3 :: Insn -> Unsigned 3
getFunct3 instr = bitCoerce |> slice d14 d12 (pack instr)

getFunct7 :: Insn -> Unsigned 7
getFunct7 instr = bitCoerce |> slice d31 d25 (pack instr)

getRd :: Insn -> Unsigned 5
getRd instr = bitCoerce |> slice d11 d7 (pack instr)

getRs2 :: Insn -> RegVal
getRs2 instr = Unpopulated |> bitCoerce |> slice d24 d20 (pack instr)

getRs1 :: Insn -> RegVal
getRs1 instr = Unpopulated |> bitCoerce |> slice d19 d15 (pack instr)