{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, InstanceSigs, AllowAmbiguousTypes, FlexibleContexts #-}
module Platform.CleanTest where
import Spec.Machine
import Spec.Decode
import Utility.Utility
import Spec.CSRFileIO
import qualified Spec.CSRField as Field
import Data.Bits
import Data.Int
import Data.Word
import Data.Char
import Data.Maybe
import Data.IORef
import Data.Array.IO
import System.Posix.Types
import System.IO.Error
import qualified Data.Map.Strict as S
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Debug.Trace as T
import Platform.Pty
import Platform.Plic
import Platform.Clint
import Control.Concurrent.MVar

data VerifMinimal64 = VerifMinimal64 { registers :: IOUArray Register Int64 ,
                                       fpregisters :: IOUArray Register Int32,
                                       csrs :: CSRFile,
                                       privMode :: IORef PrivMode,
                                       pc :: IORef Int64,
                                       nextPC :: IORef Int64,
                                       mem :: IOUArray Int Word8,
                                       plic :: Plic,
                                       clint :: (IORef Int64, MVar Int64),
                                       console :: (MVar [Word8], Fd),
                                       reservation :: IORef (Maybe Int),
                                                     -- Verification Packet
                                       exception :: IORef Bool,
                                       interrupt :: IORef Bool,
                                       valid_dst :: IORef Bool,
                                       valid_addr :: IORef Bool,
                                       instruction :: IORef Int32,
                                       cause :: IORef Int32,
                                       d :: IORef Word64,
                                       dst :: IORef Int64,
                                       addrPacket :: IORef Word64,
                                       pcPacket :: IORef Int64,
                                       valid_timer :: IORef Bool,
                                       timer :: IORef Int64,
                                       mipPacket:: IORef Int64

                                     }


type IOState = StateT VerifMinimal64 IO

type LoadFunc = IOState Int32
type StoreFunc = Int32 -> IOState ()

rvGetChar :: IOState Int32
rvGetChar = do
  refs <- get
  mWord <- liftIO $ readPty (fst (console refs))
  lift $ putStrLn "Get Char happened"
  case mWord of
    Nothing -> return $ -1
    Just a -> return $ fromIntegral a

rvPutChar :: Int32 -> IOState ()
rvPutChar val = do
  refs <- get
  liftIO $ writePty (snd (console refs)) (fromIntegral val)

rvZero = return 0
rvNull val = return ()

getMTime :: LoadFunc
getMTime = undefined

-- Ignore writes to mtime.
setMTime :: StoreFunc
setMTime _ = return ()


readPlicWrap addr = do
  refs <- get
  (val, interrupt) <- lift $ readPlic (plic refs) addr
  when (interrupt == Set) (do
                  lift $ putStrLn "Set external interrupt from read"
                  setCSRField Field.MEIP 1)
  when (interrupt == Reset) (do
                  lift $ putStrLn "Reset external initerrupt"
                  setCSRField Field.MEIP 0)
  return val
writePlicWrap addr val = do
  refs <- get
  interrupt <- lift $ writePlic (plic refs) addr val
  when (interrupt == Set) (do
                  lift $ putStrLn "Set external interrupt from write"
                  setCSRField Field.MEIP 1)
  when (interrupt == Reset) (do
                  lift $ putStrLn "Reset external interrupt from write"
                  setCSRField Field.MEIP 0)
  return ()

readClintWrap addr = do
  refs <- get
  let (mtimecmp,rtc) = clint refs
  mint <- lift $ readClint mtimecmp rtc addr
  lift $ writeIORef (valid_timer refs) True
  when (addr == 0xbff8) . lift . writeIORef (timer refs) . fromIntegral . fromJust $ mint
--  lift . putStrLn $ "readClint " ++ show mint ++ " at addr " ++ show addr
  case mint of
    Just a -> return a
    Nothing -> return 0 --Impossible
writeClintWrap addr val = do
  refs <- get
  let (mtimecmp,rtc) = clint refs
  lift . putStrLn $ "writeClint " ++ show val ++ " at addr " ++ show addr
  lift $ writeClint mtimecmp addr val
  setCSRField Field.MTIP 0

-- Addresses for mtime/mtimecmp chosen for Spike compatibility, and getchar putchar.
memMapTable :: S.Map MachineInt (LoadFunc, StoreFunc)
memMapTable = S.fromList
              [
              -- Pty
               (0xfff0, (rvZero, rvPutChar)),
               (0xfff4, (rvGetChar, rvNull)),
               -- Plic
               (0x4000000, (readPlicWrap 0x200000,  writePlicWrap 0x200000)),
               (0x4000004, (readPlicWrap 0x200004, writePlicWrap 0x200004)),
               -- Clint
               (0x2000000, (fmap fromIntegral $ getCSRField Field.MSIP, setCSRField Field.SSIP)),
               (0x200bff8, (readClintWrap 0xbff8, writeClintWrap 0xbff8)),
               (0x200bffc, (readClintWrap 0xbffc, writeClintWrap 0xbffc)),
               (0x2004000, (readClintWrap 0x4000, writeClintWrap 0x4000)),
               (0x2004004, (readClintWrap 0x4004, writeClintWrap 0x4004))

              ]

mtimecmp_addr = 0x4000 :: Int64

instance RiscvMachine IOState Int64 where
  getRegister reg = do
      if reg == 0
      then return 0
      else do
        refs <- get
        lift $! readArray (registers refs) reg
  setRegister reg val = do
      refs <- get
      if reg == 0
      then do
      --  lift $ writeIORef (valid_dst refs) True
      --  lift $ writeIORef (dst refs) reg
      --  lift $ writeIORef (d refs) $ fromIntegral val
        return ()
      else do
        lift $ writeIORef (valid_dst refs) True
        lift $ writeIORef (dst refs) reg
        lift $ writeIORef (d refs) $ fromIntegral val
        lift $! writeArray (registers refs) reg val
  getFPRegister reg = do
       refs <- get
       lift $! readArray (fpregisters refs) reg
  setFPRegister reg val = do
       refs <- get
       lift $! writeArray (fpregisters refs) reg val
  getPC = do
       refs <- get
       lift $! readIORef (pc refs)
  setPC npc = do
       refs <- get
       lift $! writeIORef (nextPC refs) npc
  getPrivMode = do
       refs <- get
       lift $! readIORef (privMode refs)
  setPrivMode val = do
       refs <- get
       lift $! writeIORef (privMode refs) val
  commit = do
       refs <- get
       npc <- lift $ readIORef (nextPC refs)
       lift $! writeIORef (pc refs) npc
--  -- Wrap Memory instance:
  loadByte s addr =
       case S.lookup (fromIntegral addr) memMapTable of
       Just _ -> error "loadByte on MMIO unsupported"
       Nothing -> do
         refs <- get
         fmap fromIntegral . lift $ readArray (mem refs) (fromIntegral addr)
  loadHalf s addr =
       case S.lookup (fromIntegral addr) memMapTable of
       Just _ -> error "loadHalf on MMIO unsupported"
       Nothing -> do
          refs <- get
          b0 <- lift . readArray (mem refs) $ fromIntegral addr
          b1 <- lift . readArray (mem refs) $ fromIntegral (addr + 1)
          return (combineBytes [b0,b1])
  loadWord :: forall s. (Integral s) => SourceType -> s -> IOState Int32
  loadWord s ad = do
    val <- (case S.lookup ((fromIntegral:: s -> MachineInt) ad) memMapTable of
      Just (getFunc, _) -> getFunc
      Nothing -> do
       refs <- get
       b0 <- lift . readArray (mem refs) $! fromIntegral ad
       b1 <- lift . readArray (mem refs) $! fromIntegral (ad + 1)
       b2 <- lift . readArray (mem refs) $! fromIntegral (ad + 2)
       b3 <- lift . readArray (mem refs) $! fromIntegral (ad + 3)
       return (combineBytes [b0,b1,b2,b3]))
    return val
  loadDouble s addr = do
       res_bot <- loadWord s addr
       res_top <- loadWord s (addr+4)
       let bytes_bot = splitWord res_bot
       let bytes_top = splitWord res_top
       return (combineBytes $ bytes_bot ++ bytes_top)
  storeByte s addr val =
       case S.lookup (fromIntegral addr) memMapTable of
       Just _ -> error "storeByte on MMIO unsupported"
       Nothing -> do
          refs <- get
          lift $ writeArray (mem refs) (fromIntegral addr) (fromIntegral val) -- Convert from Int8 to Word8
  storeHalf s addr val =
       case S.lookup (fromIntegral addr) memMapTable of
       Just _ -> error "storeHald on MMIO unsupported"
       Nothing -> do
         let bytes = splitHalf val
         refs <- get
         forM_ (zip bytes [addr + i| i<- [0..]])  $ (\(x,addr)-> lift $ writeArray (mem refs) (fromIntegral addr) (fromIntegral x))
  storeWord :: forall s. (Integral s, Bits s) => SourceType -> s -> Int32 -> IOState ()
  storeWord s addr val = do
    refs <- get
    lift $ writeIORef (valid_addr refs) True
    lift $ writeIORef (addrPacket refs) $ fromIntegral addr
    lift $ writeIORef (d refs) . fromIntegral $ (fromIntegral val :: Word32)
   -- when (addr >= 0x2000000 && addr < 0x20c0000) .lift $ putStrLn ("write to the clint:  " ++ show ( fromIntegral addr))
    case S.lookup ((fromIntegral:: s -> MachineInt) addr) memMapTable of
      Just (_, setFunc) -> setFunc val
      Nothing -> do
       let bytes = splitWord val
      -- refs <- get
       forM_ (zip bytes [addr + i| i<- [0..]])  $ (\(x,addr)-> lift $ writeArray (mem refs) (fromIntegral addr) (fromIntegral x))
  storeDouble s addr val =
    case (S.lookup (fromIntegral addr) memMapTable,S.lookup (fromIntegral (addr+4)) memMapTable) of
    (Just (_, setFunc1 ),Just (_, setFunc2 ))  -> do
           setFunc1 $ fromIntegral (val .&. 0xFFFFFFFF)
           setFunc2 $ fromIntegral (shiftR val 32)
    (Nothing, Nothing) -> do
       let bytes = splitDouble val
       refs <- get
       forM_ (zip bytes [addr + i| i<- [0..]])  $ (\(x,addr)-> lift $ writeArray (mem refs) (fromIntegral addr) (fromIntegral x))
    _ -> error "storeDouble half within MMIO, half without that's SOOOO wrong"
  makeReservation addr = do
       refs <- get
       lift $ writeIORef (reservation refs) (Just $ fromIntegral addr)
  checkReservation addr = do
       refs <- get
       res <- lift $ readIORef (reservation refs)
       return (Just (fromIntegral addr) == res)
  clearReservation addr = do
       refs <- get
       lift $ writeIORef (reservation refs) Nothing
  fence a b = return ()
--  -- CSRs:
  getCSRField field = do
     refs <- get
     lift $! readArray (csrs refs) field
  unsafeSetCSRField :: forall s. (Integral s) => Field.CSRField -> s -> IOState ()
  unsafeSetCSRField field val = do -- CSRS are not refs in there, because I am lazy.
     refs <- get
     lift $! writeArray (csrs refs) field ((fromIntegral:: s -> MachineInt) val)
  flushTLB = return ()
  getPlatform = return (Platform { dirtyHardware = return False, writePlatformCSRField = \field value -> return value })
