TDT4258/ex2_haskell/cache_sim.hs

{-# LANGUAGE NamedFieldPuns  #-}

import System.Exit (exitFailure)
import Data.Bits
import System.Console.GetOpt
import Text.Read (readMaybe)
import System.Environment (getArgs)
import Data.List (intersperse)
import Data.Maybe (isNothing)
import Numeric (readHex)
import Control.Exception (throw)
import Data.Array

data CacheMap = DirectMapping | FullAssociative
  deriving (Show, Eq)

data CacheOrg = Unified | Split
  deriving (Show, Eq)

data Config = Config { mapping :: CacheMap
                     , organization :: CacheOrg
                     , size :: Int
                     , file :: String
                     , blockSize :: Int
                     }
  deriving (Show)

data CacheStats = CacheStats { hits :: Int
                             , misses :: Int
                             }
  deriving (Show)

instance Semigroup CacheStats where
  c1 <> c2 = CacheStats { hits = (hits c1) + (hits c2)
                        , misses = (misses c1) + (misses c2)
                        }

instance Monoid CacheStats where
  mempty = CacheStats { hits = 0
                      , misses = 0
                      }

data MemoryAccess = Instruction Int
                  | Data Int
  deriving (Show, Eq)

address :: MemoryAccess -> Int
address (Instruction a) = a
address (Data a) = a

data Flag = FlagMapping (Either String CacheMap)
          | FlagOrganization (Either String CacheOrg )
          | FlagSize (Either String Int)
          | FlagFile String
          | FlagHelp
  deriving (Show, Eq)

-- class Cache a e where
--   contains :: a -> e -> Bool
--   insert :: a -> e -> a

-- newtype DirectMappedCache m = DirectMappedCache m
-- newtype FullAssociativeCache m = FullAssociativeCache m

-- instance Cache (DirectMappedCache Array) Int where
--   contains cache value = undefined
--   insert cache value = undefined

-- instance Cache (FullAssociativeCache Array) Int where
--   contains cache value = undefined
--   insert cache value = undefined

options :: [OptDescr Flag]
options = [ Option ['m'] ["mapping"] m "Type of cache mapping"
       , Option ['o'] ["organization"] o "Type of cache organization"
       , Option ['s'] ["size"] s "Cache size"
       , Option ['f'] ["file"] f "File with memory dump"
       , Option ['h', '?'] ["help"] (NoArg FlagHelp) "Show usage"
       ]
  where
    fm :: String -> Either String CacheMap
    fm "DM" = Right DirectMapping
    fm "FA" = Right FullAssociative
    fm x    = Left $ "No such cache mapping: " ++ x
    m = ReqArg (FlagMapping . fm) "DM|FA"

    fo :: String -> Either String CacheOrg
    fo "UC" = Right Unified
    fo "SC" = Right Split
    fo x    = Left $ "No such cache organization: " ++ x
    o = ReqArg (FlagOrganization . fo) "UC|SC"

    isPowerOf2 n = n .&. (n - 1) == 0
    fs :: String -> Either String Int
    fs x = case readMaybe x of
      Nothing -> Left $ "Cannot parse cache size: " ++ x
      Just i -> if isPowerOf2 i
                  then Right i
                  else Left $ x ++ " is not a power of 2"
    s = ReqArg (FlagSize . fs) "KB (number which is a power of 2)"

    f = ReqArg FlagFile "FILE"

handleArgs :: IO (Either String Config)
handleArgs = do
  argList <- getArgs
  let args = getOpt RequireOrder options argList

  -- TODO: Print Flag Left sides
  return $ case args of
    (_,_,errs@(_:_)) -> Left $ concat errs ++ usageInfo "" options
    (FlagMapping (Right m):FlagOrganization (Right o):FlagSize (Right s):FlagFile f:_,[],[]) ->
      Right $ Config { mapping = m
                     , organization = o
                     , size = s
                     , file = f
                     , blockSize = 64
                     }
    _ -> Left $ usageInfo "aaaaa" options

parseFile :: String -> Either String [MemoryAccess]
parseFile = mapM lineToInstr . lines
  where
    lineToInstr :: String -> Either String MemoryAccess
    lineToInstr s = do
      (i,d) <- case words s of
        i:d:_ -> Right (i, d)
        _ -> Left $ "Cannot parse line: " ++ s

      n <- case readHex d of
        [(n,"")] -> Right n
        _ -> Left $ "Cannot parse line: " ++ s

      case i of
        "I" -> Right $ Instruction n
        "D" -> Right $ Data n
        _ -> Left $ "Cannot parse line: " ++ s

mask :: Int -> Int -> Int -> Int
mask digits offset n = shift (2^digits - 1) offset .&. n

directMappingSimulation :: Config -> [MemoryAccess] -> t2 -> CacheStats -> CacheStats
directMappingSimulation c [] cache stats = stats
directMappingSimulation c (m:ms) cache stats = let
  numberOfBlocks = (size c) `div` (blockSize c)

  bitsForOffset = finiteBitSize $ blockSize c
  bitsForIndex = finiteBitSize $ numberOfBlocks
  bitsForTag = 32 - bitsForIndex - bitsForOffset

  index = mask bitsForIndex bitsForOffset $ address m
  tag = mask bitsForTag (bitsForIndex + bitsForOffset) $ address m

  contains = undefined
  newCache = if contains m cache
              then cache
              else

  newStats = if contains m cache
    then stats { hits = hits stats + 1 }
    else stats { misses = misses stats + 1 }
  in directMappingSimulation c ms newCache newStats

fullAssociativeSimulation :: Config -> [MemoryAccess] -> t2 -> Int -> CacheStats -> CacheStats
fullAssociativeSimulation c [] cache i stats = stats
fullAssociativeSimulation c (m:ms) cache i stats = let
  tag = mask (32 - (finiteBitSize $ blockSize c)) (finiteBitSize $ blockSize c) $ address m

  contains = undefined
  newCache = undefined
  newStats = if contains m cache i
    then stats { hits = hits stats + 1 }
    else stats { misses = misses stats + 1 }
  in fullAssociativeSimulation c ms newCache (i + 1 `mod` (blockSize c)) newStats

-- f :: [MemoryAccess] -> Writer CacheStats [MemoryAccess]
-- f accessesLeft = x
--   where
--     head x

simulateCache :: Config -> [MemoryAccess] -> CacheStats
simulateCache c m = 
  
  CacheStats {hits=1, misses=2}

printStats :: CacheStats -> IO ()
printStats = print

main :: IO ()
main = do
  config <- handleArgs
  config' <- case config of
    Left err -> putStrLn err >> exitFailure
    Right cfg -> return cfg

  fileContent <- readFile $ file config'
  print $ parseFile fileContent
  case parseFile fileContent of
    Left err -> putStrLn err >> exitFailure
    Right memory -> printStats $ simulateCache config' memory