diff --git a/System/Cpuid.hs b/System/Cpuid.hs --- a/System/Cpuid.hs +++ b/System/Cpuid.hs @@ -3,13 +3,14 @@ -- | -- 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 +-- 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. @@ -18,26 +19,32 @@ -- 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 "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" +-- > _ <- 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 - (-- * Data types + (-- * Functions + cpuid, + processorInfo, + vendorString, + brandString, + cacheInfo, + -- * Data types Associativity(..), PageSize(..), Ways(..), @@ -48,29 +55,97 @@ MuOps(..), BytesPerSector(..), ProcessorInfo(..), - -- * Functions - cpuid, - processorInfo, - vendorString, - brandString, - cacheInfo) where + -- * 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 Foreign.C.String (peekCStringLen, ) +import qualified Foreign.C.String as CString import Foreign.Storable (pokeElemOff, peekElemOff, ) import Foreign.Ptr (Ptr, castPtr, ) -import Data.Bits ((.&.), shiftR, complement, ) + +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, ) -foreign import ccall unsafe "cpuid_array" _cpuid :: Word32 -> Ptr Word32 -> IO () +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 + cpuid_ op arr [a,b,c,d] <- peekArray 4 arr return (a, b, c, d) @@ -82,17 +157,22 @@ 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 + 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) + peekCStringLen (advancePtr arr 1, 3*4) -- | Execute the @cpuid@ instruction and return the brand string -- (processor name and maximum frequency) reported by that @@ -100,10 +180,10 @@ 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) + 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 @@ -165,21 +245,16 @@ case m of Nothing -> return [] Just (a, b, c, d) -> - collectCacheDescriptors - (fromIntegral ((a .&. 0xff) - 1)) [] - (a .&. complement 0xff) b c d - --- | Call the @cpuid@ instruction as often as needed and merge the values. -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' + 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 valie entries. +-- | Convert the strange 0x40 code to valid entries. postProcess :: [CacheInfo] -> [CacheInfo] -postProcess infos = +postProcess infos = let has2ndLevel = any (\ info -> case info of SecondLevelCache{} -> True _ -> False) infos @@ -190,28 +265,19 @@ NoSecondOrThirdLevelCache{} -> False _ -> True) infos in if has2ndLevel - then if hasNo2ndOr3rd + then if hasNo2ndOr3rd then NoThirdLevelCache : infos' else infos' else NoSecondLevelCache : infos' --- | Convert the values from the registers to cache information --- records. -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 +-- | 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 @@ -293,14 +359,269 @@ 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}) + 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 diff --git a/cpuid.cabal b/cpuid.cabal --- a/cpuid.cabal +++ b/cpuid.cabal @@ -1,21 +1,21 @@ Name: cpuid -Version: 0.2.1.3 +Version: 0.2.2 License: GPL License-file: COPYING Author: Martin Grabmueller Maintainer: martin@grabmueller.de, cpuid@henning-thielemann.de -Homepage: http://code.haskell.org/cpuid +Homepage: http://code.haskell.org/cpuid/ Category: Foreign binding -Synopsis: Binding for the cpuid machine instruction on x86 compatible - processors -Description: This module provides the function 'cpuid' for accessing - information about the currently running IA-32 processor. Both a function - for calling the 'cpuid' instruction directly, and some convenience functions - for common uses are provided. This package is only portable to IA-32 - machines. +Synopsis: Binding for the cpuid machine instruction on x86 compatible processors +Description: + This module provides the function 'cpuid' + for accessing information about the currently running IA-32 processor. + Both a function for calling the 'cpuid' instruction directly, + and some convenience functions for common uses are provided. + This package is only portable to IA-32 machines. Stability: Experimental Build-type: Simple -Cabal-version: >=1.2 +Cabal-version: >=1.6 Extra-source-files: README @@ -26,13 +26,20 @@ Description: Build example executables Default: False +Source-Repository head + Type: darcs + Location: http://code.haskell.org/cpuid/ + Library If !arch(i386) Buildable: False - Build-depends: base >= 4 && < 5 + Build-depends: + data-accessor >=0.2.2 && <0.3, + enumset >=0.0.3 && <0.1, + base >=4 && < 5 Exposed-Modules: System.Cpuid Extensions: ForeignFunctionInterface - C-sources: cbits/cpuid.c + C-sources: cbits/cpuid.c Include-dirs: cbits Install-includes: cpuid.h GHC-Options: -Wall @@ -41,5 +48,5 @@ If !(flag(buildExamples) && arch(i386)) Buildable: False Main-Is: tests/TestCpuid.hs - C-sources: cbits/cpuid.c + C-sources: cbits/cpuid.c GHC-Options: -Wall diff --git a/tests/TestCpuid.hs b/tests/TestCpuid.hs --- a/tests/TestCpuid.hs +++ b/tests/TestCpuid.hs @@ -7,13 +7,19 @@ 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 "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" + _ <- printf "Processor info: family: %d, model: %d, stepping: %d, processor type: %d\n" (piFamily p) (piModel p) (piStepping p) (piType p) - return () + putStrLn "Features:" + (fc,fd) <- features + let showFeatures flags = + putStrLn $ concatMap (\f -> " " ++ show f) $ + filter (flip testFlag flags) [minBound..maxBound] + showFeatures fd + showFeatures fc