module System.Cpuid
(
cpuid,
processorInfo,
vendorString,
brandString,
cacheInfo,
Associativity(..),
PageSize(..),
Ways(..),
Entries(..),
CacheSize(..),
CacheInfo(..),
LineSize(..),
MuOps(..),
BytesPerSector(..),
ProcessorInfo(..),
features,
FlagSet,
testFlag,
Feature1C,
sse3,
pclmulqdq,
dtes64,
monitor,
dscpl,
vmx,
smx,
est,
tm2,
ssse3,
cnxtid,
fma,
cmpxchg16b,
xtpr,
pdcm,
pcid,
dca,
sse4_1,
sse4_2,
x2apic,
movbe,
popcnt,
deadline,
aes,
xsave,
osxsave,
avx,
f16c,
rdrand,
hypervisor,
Feature1D,
fpu,
vme,
de,
pse,
tsc,
msr,
pae,
mce,
cx8,
apic,
sep,
mtrr,
pge,
mca,
cmov,
pat,
pse36,
psn,
clfsh,
ds,
acpi,
mmx,
fxsr,
sse,
sse2,
ss,
htt,
tm,
ia64,
pbe,
) where
import Foreign.Marshal.Array (allocaArray, peekArray, advancePtr, )
import qualified Foreign.C.String as CString
import Foreign.Storable (pokeElemOff, peekElemOff, )
import Foreign.Ptr (Ptr, castPtr, )
import qualified Data.EnumSet as EnumSet
import qualified Data.FlagSet as FlagSet
import qualified Data.FlagSet.PackedRecord as PackedRec
import Data.Bits ((.&.), shiftR, complement, testBit, )
import Data.Word (Word8, Word32, )
import Data.Maybe (mapMaybe, )
import Control.Monad (replicateM, )
import qualified Data.Accessor.Basic as Acc
import Data.Accessor ((^.), )
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
peekCStringLen :: (Ptr Word32, Int) -> IO String
peekCStringLen (ptr,len) =
fmap (takeWhile ('\0' /=)) $
CString.peekCAStringLen (castPtr ptr, len)
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 (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 (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) ->
fmap (postProcess . interpretCD) $
fmap ([a .&. complement 0xff, b, c, d] ++) $
fmap (concatMap (\(a', b', c', d') -> [a', b', c', d'])) $
replicateM
(fromIntegral ((a .&. 0xff) 1))
(cpuid 2)
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'
interpretCD :: [Word32] -> [CacheInfo]
interpretCD =
mapMaybe (flip lookup cacheTable) .
concatMap (\w -> map (fromIntegral . shiftR w) [0,8,16,24]) .
filter (not . flip testBit 31)
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 p = FlagSet.Cons a
return $ ProcessorInfo{
piFamily = p ^. family,
piModel = p ^. model,
piStepping = p ^. stepping,
piType = p ^. typ
}
stepping, model, baseFamily, extFamily, typ ::
Acc.T (FlagSet.T Word32 ProcessorInfo) Int
stepping = PackedRec.accessorIntByRange 4 0
model = PackedRec.accessorIntByRange 4 4
baseFamily = PackedRec.accessorIntByRange 4 8
typ = PackedRec.accessorIntByRange 2 12
extFamily = PackedRec.accessorIntByRange 8 20
family :: Acc.T (FlagSet.T Word32 ProcessorInfo) Int
family =
Acc.fromWrapper
(\n ->
if n<=15
then (n,0)
else (15,n15))
(\(bf,ef) ->
case bf of
0xf -> 0xf + ef
fam -> fam)
Acc.<.
Acc.merge baseFamily extFamily
type FlagSet = EnumSet.T Word32
features :: IO (FlagSet Feature1C, FlagSet Feature1D)
features =
flip fmap (cpuidMaybe 1) $ \m ->
case m of
Nothing -> (EnumSet.empty, EnumSet.empty)
Just (_, _, c, d) -> (EnumSet.Cons c, EnumSet.Cons d)
testFlag :: Enum a => a -> FlagSet a -> Bool
testFlag = EnumSet.get
infix 9 *->
(*->) :: a -> b -> (a, b)
(*->) = (,)
showsPrecEnum ::
(Eq e, Enum e) =>
String -> [(e, String)] -> Int -> e -> ShowS
showsPrecEnum consName table prec item =
maybe
(showParen (prec>10)
(showString consName . showString " " . shows (fromEnum item)))
showString $
lookup item table
newtype Feature1C = Feature1C Int
deriving (Eq, Ord)
instance Enum Feature1C where
fromEnum (Feature1C n) = n
toEnum n = Feature1C n
instance Bounded Feature1C where
minBound = (Feature1C 0)
maxBound = (Feature1C 31)
instance Show Feature1C where
showsPrec =
showsPrecEnum "Feature1C" $
sse3 *-> "sse3" :
pclmulqdq *-> "pclmulqdq" :
dtes64 *-> "dtes64" :
monitor *-> "monitor" :
dscpl *-> "dscpl" :
vmx *-> "vmx" :
smx *-> "smx" :
est *-> "est" :
tm2 *-> "tm2" :
ssse3 *-> "ssse3" :
cnxtid *-> "cnxtid" :
fma *-> "fma" :
cmpxchg16b *-> "cmpxchg16b" :
xtpr *-> "xtpr" :
pdcm *-> "pdcm" :
pcid *-> "pcid" :
dca *-> "dca" :
sse4_1 *-> "sse4_1" :
sse4_2 *-> "sse4_2" :
x2apic *-> "x2apic" :
movbe *-> "movbe" :
popcnt *-> "popcnt" :
deadline *-> "deadline" :
aes *-> "aes" :
xsave *-> "xsave" :
osxsave *-> "osxsave" :
avx *-> "avx" :
f16c *-> "f16c" :
rdrand *-> "rdrand" :
hypervisor *-> "hypervisor" :
[]
sse3 :: Feature1C
pclmulqdq :: Feature1C
dtes64 :: Feature1C
monitor :: Feature1C
dscpl :: Feature1C
vmx :: Feature1C
smx :: Feature1C
est :: Feature1C
tm2 :: Feature1C
ssse3 :: Feature1C
cnxtid :: Feature1C
fma :: Feature1C
cmpxchg16b :: Feature1C
xtpr :: Feature1C
pdcm :: Feature1C
pcid :: Feature1C
dca :: Feature1C
sse4_1 :: Feature1C
sse4_2 :: Feature1C
x2apic :: Feature1C
movbe :: Feature1C
popcnt :: Feature1C
deadline :: Feature1C
aes :: Feature1C
xsave :: Feature1C
osxsave :: Feature1C
avx :: Feature1C
f16c :: Feature1C
rdrand :: Feature1C
hypervisor :: Feature1C
sse3 = Feature1C 0
pclmulqdq = Feature1C 1
dtes64 = Feature1C 2
monitor = Feature1C 3
dscpl = Feature1C 4
vmx = Feature1C 5
smx = Feature1C 6
est = Feature1C 7
tm2 = Feature1C 8
ssse3 = Feature1C 9
cnxtid = Feature1C 10
fma = Feature1C 12
cmpxchg16b = Feature1C 13
xtpr = Feature1C 14
pdcm = Feature1C 15
pcid = Feature1C 17
dca = Feature1C 18
sse4_1 = Feature1C 19
sse4_2 = Feature1C 20
x2apic = Feature1C 21
movbe = Feature1C 22
popcnt = Feature1C 23
deadline = Feature1C 24
aes = Feature1C 25
xsave = Feature1C 26
osxsave = Feature1C 27
avx = Feature1C 28
f16c = Feature1C 29
rdrand = Feature1C 30
hypervisor = Feature1C 31
newtype Feature1D = Feature1D Int
deriving (Eq, Ord)
instance Enum Feature1D where
fromEnum (Feature1D n) = n
toEnum n = Feature1D n
instance Bounded Feature1D where
minBound = (Feature1D 0)
maxBound = (Feature1D 31)
instance Show Feature1D where
showsPrec =
showsPrecEnum "Feature1D" $
fpu *-> "fpu" :
vme *-> "vme" :
de *-> "de" :
pse *-> "pse" :
tsc *-> "tsc" :
msr *-> "msr" :
pae *-> "pae" :
mce *-> "mce" :
cx8 *-> "cx8" :
apic *-> "apic" :
sep *-> "sep" :
mtrr *-> "mtrr" :
pge *-> "pge" :
mca *-> "mca" :
cmov *-> "cmov" :
pat *-> "pat" :
pse36 *-> "pse36" :
psn *-> "psn" :
clfsh *-> "clfsh" :
ds *-> "ds" :
acpi *-> "acpi" :
mmx *-> "mmx" :
fxsr *-> "fxsr" :
sse *-> "sse" :
sse2 *-> "sse2" :
ss *-> "ss" :
htt *-> "htt" :
tm *-> "tm" :
ia64 *-> "ia64" :
pbe *-> "pbe" :
[]
fpu :: Feature1D
vme :: Feature1D
de :: Feature1D
pse :: Feature1D
tsc :: Feature1D
msr :: Feature1D
pae :: Feature1D
mce :: Feature1D
cx8 :: Feature1D
apic :: Feature1D
sep :: Feature1D
mtrr :: Feature1D
pge :: Feature1D
mca :: Feature1D
cmov :: Feature1D
pat :: Feature1D
pse36 :: Feature1D
psn :: Feature1D
clfsh :: Feature1D
ds :: Feature1D
acpi :: Feature1D
mmx :: Feature1D
fxsr :: Feature1D
sse :: Feature1D
sse2 :: Feature1D
ss :: Feature1D
htt :: Feature1D
tm :: Feature1D
ia64 :: Feature1D
pbe :: Feature1D
fpu = Feature1D 0
vme = Feature1D 1
de = Feature1D 2
pse = Feature1D 3
tsc = Feature1D 4
msr = Feature1D 5
pae = Feature1D 6
mce = Feature1D 7
cx8 = Feature1D 8
apic = Feature1D 9
sep = Feature1D 11
mtrr = Feature1D 12
pge = Feature1D 13
mca = Feature1D 14
cmov = Feature1D 15
pat = Feature1D 16
pse36 = Feature1D 17
psn = Feature1D 18
clfsh = Feature1D 19
ds = Feature1D 21
acpi = Feature1D 22
mmx = Feature1D 23
fxsr = Feature1D 24
sse = Feature1D 25
sse2 = Feature1D 26
ss = Feature1D 27
htt = Feature1D 28
tm = Feature1D 29
ia64 = Feature1D 30
pbe = Feature1D 31