{-# LANGUAGE ForeignFunctionInterface #-} -------------------------------------------------------------------------- -- | -- Module: System.Cpuid -- Copyright: (c) 2008,2010 Martin Grabmueller -- (c) 2011 Henning Thielemann -- License: GPL -- -- Maintainer: martin@grabmueller.de -- Stability: provisional -- Portability: non-portable (requires IA-32 processor) -- -- This module provides the function 'cpuid' for accessing the cpuid -- instruction on modern IA-32 processors. Additionally, some convenience -- functions are provided, which perform some of the (really complicated and -- obstruse) decoding. -- -- As an example, you may use the following program to determine some -- characteristics of your machine: -- -- > module Main(main) where -- > -- > import Text.Printf (printf, ) -- > import System.Cpuid -- > -- > main :: IO () -- > main = do -- > (a, b, c, d) <- cpuid 0 -- > _ <- printf "Basic CPUID usage: EAX=0: %8x %8x %8x %8x\n\n" a b c d -- > _ <- printf "Vendor string: %s\n\n" =<< vendorString -- > _ <- printf "Brand string: %s\n\n" =<< brandString -- > putStrLn "Cache information:" -- > putStrLn . unlines . -- > map (\ v -> " " ++ show v) =<< cacheInfo -- > p <- processorInfo -- > _ <- printf "Processor info: family: %d, model: %d, stepping: %d, processor type: %d\n" -- > (piFamily p) (piModel p) (piStepping p) (piType p) -- > return () -------------------------------------------------------------------------- module System.Cpuid (-- * Functions cpuid, processorInfo, vendorString, brandString, cacheInfo, -- * Data types Associativity(..), PageSize(..), Ways(..), Entries(..), CacheSize(..), CacheInfo(..), LineSize(..), MuOps(..), BytesPerSector(..), ProcessorInfo(..), -- * Features features, FlagSet, testFlag, -- Feature1C, sse3, pclmulqdq, dtes64, monitor, dscpl, vmx, smx, est, tm2, ssse3, cnxtid, fma, cmpxchg16b, xtpr, pdcm, dca, sse4_1, sse4_2, x2apic, movbe, popcnt, aes, xsave, osxsave, avx, -- 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, 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 () -- | Execute the @cpuid@ instructions with the given argument -- in the EAX register. Return the values of the registers -- EAX, EBX, ECX and EDX in that order. 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) -- | Run @cpuid@ but check before that the used operation is actually supported 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) -- | Execute the @cpuid@ instruction and return the vendor -- string reported by that instruction. 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) -- | Execute the @cpuid@ instruction and return the brand string -- (processor name and maximum frequency) reported by that -- instruction. 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) -- | Number of entries in a TLB. newtype Entries = Entries Int deriving (Show) -- | Associativity in a set-associative cache. newtype Ways = Ways Int deriving (Show) -- | MuOps in a processors trace cache. newtype MuOps = MuOps Int deriving (Show) -- | Page size. Some entries can have alternative page sizes, -- therefore the complicated type. data PageSize = PageSize Int | PageSizeOr PageSize PageSize deriving (Show) -- | Cache size. Some entries can have alternative cache sizes, -- therefore the complicated type. data CacheSize = CacheSize Int | CacheSizeOr CacheSize CacheSize deriving (Show) -- | Line size in a cache. newtype LineSize = LineSize Int deriving (Show) -- | Bytes per sector in a cache. newtype BytesPerSector = BytesPerSector Int deriving (Show) -- | Cache associativity. For some entries, this is not specified in -- the manual. We report these as 'DirectMapped'. data Associativity = SetAssociative Ways | DirectMapped deriving (Show) -- | Information for caches and TLBs. data CacheInfo = InstructionTLB (Maybe CacheSize) PageSize Associativity Entries -- ^ Configuration of code TLB. | DataTLB (Maybe CacheSize) PageSize Associativity Entries -- ^ Configuration of data TLB. | FirstLevelICache CacheSize Associativity LineSize -- ^ First-level code cache configuration. | FirstLevelDCache CacheSize Associativity LineSize -- ^ First-level code cache configuration. | NoSecondLevelCache -- ^ No second level support. | SecondLevelCache CacheSize Associativity LineSize (Maybe BytesPerSector) -- ^ Second-level cache configuration. | NoThirdLevelCache -- ^ No third level support. | NoSecondOrThirdLevelCache -- ^ Internal use only. | ThirdLevelCache CacheSize Associativity LineSize (Maybe BytesPerSector) -- ^ Second-level cache configuration. | TraceCache MuOps Associativity -- ^ Trace cache (1st-level code cache) configuration. | Prefetching Int -- ^ Prefetching information. deriving (Show) -- | Fetch all available cache information from the processor, using -- the @cpuid@ instruction. The list is not ordered. 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) -- | Convert the strange 0x40 code to valid entries. 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' -- | Convert the values from the registers to cache information records. interpretCD :: [Word32] -> [CacheInfo] interpretCD = mapMaybe (flip lookup cacheTable) . concatMap (\w -> map (fromIntegral . shiftR w) [0,8,16,24]) . filter (not . flip testBit 31) -- | Convert kBytes to bytes. kByte :: Int -> Int kByte b = b * 1024 -- | Convert mBytes to bytes. mByte :: Int -> Int mByte b = b * 1024 * 1024 -- | Table of cache configuration. Information from the CPUID -- documentation in the /IA-32 Intel Architecture Software Developer's -- Manual Volumes 2A/. 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) ] -- | Processor information. data ProcessorInfo = ProcessorInfo{piFamily :: Int, -- ^ Processor family. piModel :: Int, -- ^ Processor model. piStepping :: Int, -- ^ Processor stepping. piType :: Int -- ^ Processor type. } -- | Retrieve basic processor information from the processor using the -- @cpuid@ instruction. 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 } {- | Instead of ProcessorInfo we could also export this FlagSet and the accessors. This would be more space efficient and would also allow for construction of processor identifiers. -} 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,n-15)) (\(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 -- | features as found in page 1, register C 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" : dca *-> "dca" : sse4_1 *-> "sse4_1" : sse4_2 *-> "sse4_2" : x2apic *-> "x2apic" : movbe *-> "movbe" : popcnt *-> "popcnt" : aes *-> "aes" : xsave *-> "xsave" : osxsave *-> "osxsave" : avx *-> "avx" : [] 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 dca :: Feature1C sse4_1 :: Feature1C sse4_2 :: Feature1C x2apic :: Feature1C movbe :: Feature1C popcnt :: Feature1C aes :: Feature1C xsave :: Feature1C osxsave :: Feature1C avx :: 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 dca = Feature1C 18 sse4_1 = Feature1C 19 sse4_2 = Feature1C 20 x2apic = Feature1C 21 movbe = Feature1C 22 popcnt = Feature1C 23 aes = Feature1C 25 xsave = Feature1C 26 osxsave = Feature1C 27 avx = Feature1C 28 -- | features as found in page 1, register D 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" : 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 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 pbe = Feature1D 31