200 lines
6.1 KiB
Haskell
200 lines
6.1 KiB
Haskell
{-# 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 |