module System.Cpuid
(
Associativity(..),
PageSize(..),
Ways(..),
Entries(..),
CacheSize(..),
CacheInfo(..),
LineSize(..),
MuOps(..),
BytesPerSector(..),
ProcessorInfo(..),
cpuid,
processorInfo,
vendorString,
brandString,
cacheInfo) where
import Foreign.Marshal.Array (allocaArray, peekArray, advancePtr, )
import Foreign.C.String (peekCStringLen, )
import Foreign.Storable (pokeElemOff, peekElemOff, )
import Foreign.Ptr (Ptr, castPtr, )
import Data.Bits ((.&.), shiftR, complement, )
import Data.Word (Word8, Word32, )
foreign import ccall unsafe "cpuid_array" _cpuid :: Word32 -> Ptr Word32 -> IO ()
cpuid :: Word32 -> IO (Word32, Word32, Word32, Word32)
cpuid op =
allocaArray 4 $ \ arr -> do
_cpuid op arr
[a,b,c,d] <- peekArray 4 arr
return (a, b, c, d)
cpuidMaybe :: Word32 -> IO (Maybe (Word32, Word32, Word32, Word32))
cpuidMaybe op = do
(high, _, _, _) <- cpuid 0
if op>high
then return Nothing
else fmap Just $ cpuid op
vendorString :: IO String
vendorString =
allocaArray 4 $ \ arr -> do
_cpuid 0 arr
c <- peekElemOff arr 2
d <- peekElemOff arr 3
pokeElemOff arr 2 d
pokeElemOff arr 3 c
peekCStringLen (castPtr (advancePtr arr 1), 3*4)
brandString :: IO String
brandString =
allocaArray (3*4) $ \ arr -> do
_cpuid 0x80000002 arr
_cpuid 0x80000003 (advancePtr arr 4)
_cpuid 0x80000004 (advancePtr arr 8)
peekCStringLen (castPtr arr, 3*4*4)
newtype Entries = Entries Int
deriving (Show)
newtype Ways = Ways Int
deriving (Show)
newtype MuOps = MuOps Int
deriving (Show)
data PageSize = PageSize Int
| PageSizeOr PageSize PageSize
deriving (Show)
data CacheSize = CacheSize Int
| CacheSizeOr CacheSize CacheSize
deriving (Show)
newtype LineSize = LineSize Int
deriving (Show)
newtype BytesPerSector = BytesPerSector Int
deriving (Show)
data Associativity = SetAssociative Ways
| DirectMapped
deriving (Show)
data CacheInfo = InstructionTLB (Maybe CacheSize) PageSize Associativity Entries
| DataTLB (Maybe CacheSize) PageSize Associativity Entries
| FirstLevelICache CacheSize Associativity LineSize
| FirstLevelDCache CacheSize Associativity LineSize
| NoSecondLevelCache
| SecondLevelCache CacheSize Associativity LineSize (Maybe BytesPerSector)
| NoThirdLevelCache
| NoSecondOrThirdLevelCache
| ThirdLevelCache CacheSize Associativity LineSize (Maybe BytesPerSector)
| TraceCache MuOps Associativity
| Prefetching Int
deriving (Show)
cacheInfo :: IO [CacheInfo]
cacheInfo =
do m <- cpuidMaybe 2
case m of
Nothing -> return []
Just (a, b, c, d) ->
collectCacheDescriptors
(fromIntegral ((a .&. 0xff) 1)) []
(a .&. complement 0xff) b c d
collectCacheDescriptors :: Int -> [CacheInfo] -> Word32 -> Word32 -> Word32 -> Word32 -> IO [CacheInfo]
collectCacheDescriptors 0 infos a b c d = return $ postProcess $ updateCD infos [a, b, c, d]
collectCacheDescriptors n infos a b c d =
do let infos' = updateCD infos [a, b, c, d]
(a', b', c', d') <- cpuid 2
collectCacheDescriptors (n 1) infos' a' b' c' d'
postProcess :: [CacheInfo] -> [CacheInfo]
postProcess infos =
let has2ndLevel = any (\ info -> case info of
SecondLevelCache{} -> True
_ -> False) infos
hasNo2ndOr3rd = any (\ info -> case info of
NoSecondOrThirdLevelCache{} -> True
_ -> False) infos
infos' = filter (\ info -> case info of
NoSecondOrThirdLevelCache{} -> False
_ -> True) infos
in if has2ndLevel
then if hasNo2ndOr3rd
then NoThirdLevelCache : infos'
else infos'
else NoSecondLevelCache : infos'
updateCD :: [CacheInfo] -> [Word32] -> [CacheInfo]
updateCD infos wss = updateBytes infos (splitBytes wss)
where splitBytes :: [Word32] -> [Word8]
splitBytes [] = []
splitBytes (w:ws) | w .&. 0x80000000 /= 0 = splitBytes ws
splitBytes (w:ws) = [fromIntegral $ w .&. 0xff,
fromIntegral $ (w `shiftR` 8) .&. 0xff,
fromIntegral $ (w `shiftR` 16) .&. 0xff,
fromIntegral $ (w `shiftR` 24) .&. 0xff] ++ splitBytes ws
updateBytes :: [CacheInfo] -> [Word8] -> [CacheInfo]
updateBytes infos' [] = infos'
updateBytes infos' (b:bs) = case lookup b cacheTable of
Nothing -> updateBytes infos' bs
Just info -> updateBytes (info : infos') bs
kByte :: Int -> Int
kByte b = b * 1024
mByte :: Int -> Int
mByte b = b * 1024 * 1024
cacheTable :: [(Word8, CacheInfo)]
cacheTable =
[
(0x01, InstructionTLB Nothing (PageSize (kByte 4)) (SetAssociative (Ways 4)) (Entries 32)),
(0x02, InstructionTLB Nothing (PageSize (mByte 4)) (SetAssociative (Ways 4)) (Entries 2)),
(0x03, DataTLB Nothing (PageSize (kByte 4)) (SetAssociative (Ways 4)) (Entries 64)),
(0x04, DataTLB Nothing (PageSize (mByte 4)) (SetAssociative (Ways 4)) (Entries 8)),
(0x06, FirstLevelICache (CacheSize (kByte 4)) (SetAssociative (Ways 4)) (LineSize 32)),
(0x08, FirstLevelICache (CacheSize (kByte 16)) (SetAssociative (Ways 4)) (LineSize 32)),
(0x0a, FirstLevelDCache (CacheSize (kByte 8)) (SetAssociative (Ways 2)) (LineSize 32)),
(0x0c, FirstLevelDCache (CacheSize (kByte 16)) (SetAssociative (Ways 4)) (LineSize 32)),
(0x22, ThirdLevelCache (CacheSize (kByte 512)) (SetAssociative (Ways 4)) (LineSize 64) (Just (BytesPerSector 2))),
(0x23, ThirdLevelCache (CacheSize (mByte 1)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x25, ThirdLevelCache (CacheSize (mByte 2)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x29, ThirdLevelCache (CacheSize (mByte 4)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x2c, FirstLevelDCache (CacheSize (kByte 32)) (SetAssociative (Ways 8)) (LineSize 64)),
(0x30, FirstLevelICache (CacheSize (kByte 32)) (SetAssociative (Ways 8)) (LineSize 64)),
(0x40, NoSecondOrThirdLevelCache),
(0x41, SecondLevelCache (CacheSize (kByte 128)) (SetAssociative (Ways 4)) (LineSize 32) Nothing),
(0x42, SecondLevelCache (CacheSize (kByte 256)) (SetAssociative (Ways 4)) (LineSize 32) Nothing),
(0x43, SecondLevelCache (CacheSize (kByte 512)) (SetAssociative (Ways 4)) (LineSize 32) Nothing),
(0x44, SecondLevelCache (CacheSize (mByte 1)) (SetAssociative (Ways 4)) (LineSize 32) Nothing),
(0x45, SecondLevelCache (CacheSize (mByte 2)) (SetAssociative (Ways 4)) (LineSize 32) Nothing),
(0x46, ThirdLevelCache (CacheSize (mByte 4)) (SetAssociative (Ways 4)) (LineSize 64) Nothing),
(0x47, ThirdLevelCache (CacheSize (mByte 8)) (SetAssociative (Ways 8)) (LineSize 64) Nothing),
(0x50, InstructionTLB (Just (CacheSize (kByte 4))) (PageSizeOr (PageSize (mByte 2)) (PageSize (mByte 4))) DirectMapped (Entries 64)),
(0x51, InstructionTLB (Just (CacheSize (kByte 4))) (PageSizeOr (PageSize (mByte 2)) (PageSize (mByte 4))) DirectMapped (Entries 128)),
(0x52, InstructionTLB (Just (CacheSize (kByte 4))) (PageSizeOr (PageSize (mByte 2)) (PageSize (mByte 4))) DirectMapped (Entries 256)),
(0x5b, DataTLB (Just (CacheSize (kByte 4))) (PageSize (mByte 4)) DirectMapped (Entries 64)),
(0x5c, DataTLB (Just (CacheSize (kByte 4))) (PageSize (mByte 4)) DirectMapped (Entries 128)),
(0x5d, DataTLB (Just (CacheSize (kByte 4))) (PageSize (mByte 4)) DirectMapped (Entries 256)),
(0x60, FirstLevelDCache (CacheSize (kByte 16)) (SetAssociative (Ways 8)) (LineSize 64)),
(0x66, FirstLevelDCache (CacheSize (kByte 8)) (SetAssociative (Ways 4)) (LineSize 64)),
(0x67, FirstLevelDCache (CacheSize (kByte 16)) (SetAssociative (Ways 4)) (LineSize 64)),
(0x68, FirstLevelDCache (CacheSize (kByte 32)) (SetAssociative (Ways 4)) (LineSize 64)),
(0x70, TraceCache (MuOps (kByte 12)) (SetAssociative (Ways 8))),
(0x71, TraceCache (MuOps (kByte 16)) (SetAssociative (Ways 8))),
(0x72, TraceCache (MuOps (kByte 32)) (SetAssociative (Ways 8))),
(0x78, SecondLevelCache (CacheSize (mByte 1)) (SetAssociative (Ways 4)) (LineSize 64) Nothing),
(0x79, SecondLevelCache (CacheSize (kByte 128)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x7a, SecondLevelCache (CacheSize (kByte 256)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x7b, SecondLevelCache (CacheSize (kByte 512)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x7c, SecondLevelCache (CacheSize (mByte 1)) (SetAssociative (Ways 8)) (LineSize 64) (Just (BytesPerSector 2))),
(0x7d, SecondLevelCache (CacheSize (mByte 2)) (SetAssociative (Ways 8)) (LineSize 64) Nothing),
(0x7f, SecondLevelCache (CacheSize (kByte 512)) (SetAssociative (Ways 2)) (LineSize 64) Nothing),
(0x82, SecondLevelCache (CacheSize (kByte 256)) (SetAssociative (Ways 8)) (LineSize 32) Nothing),
(0x83, SecondLevelCache (CacheSize (kByte 512)) (SetAssociative (Ways 8)) (LineSize 32) Nothing),
(0x84, SecondLevelCache (CacheSize (mByte 1)) (SetAssociative (Ways 8)) (LineSize 32) Nothing),
(0x85, SecondLevelCache (CacheSize (mByte 2)) (SetAssociative (Ways 8)) (LineSize 32) Nothing),
(0x86, SecondLevelCache (CacheSize (kByte 512)) (SetAssociative (Ways 4)) (LineSize 64) Nothing),
(0x87, SecondLevelCache (CacheSize (mByte 1)) (SetAssociative (Ways 8)) (LineSize 64) Nothing),
(0xb0, InstructionTLB Nothing (PageSize (kByte 4)) (SetAssociative (Ways 4)) (Entries 128)),
(0xb3, DataTLB Nothing (PageSize (kByte 4)) (SetAssociative (Ways 4)) (Entries 128)),
(0xf0, Prefetching 64),
(0xf1, Prefetching 128)
]
data ProcessorInfo = ProcessorInfo{piFamily :: Int,
piModel :: Int,
piStepping :: Int,
piType :: Int
}
processorInfo :: IO ProcessorInfo
processorInfo =
do (a, _, _, _) <- cpuid 1
let stepping = a .&. 0xf
model = (a `shiftR` 4) .&. 0xf
family = (a `shiftR` 8) .&. 0x0f
extFamily = (a `shiftR` 20) .&. 0xff
typ = (a `shiftR` 12) .&. 0x3
return (ProcessorInfo{piFamily = fromIntegral (if family /= 0xf
then family
else family + extFamily),
piModel = fromIntegral model,
piStepping = fromIntegral stepping,
piType = fromIntegral typ})