cpuid 0.2.1.3 → 0.2.2

raw patch · 3 files changed

+414/−80 lines, 3 filesdep +data-accessordep +enumsetPVP ok

version bump matches the API change (PVP)

Dependencies added: data-accessor, enumset

API changes (from Hackage documentation)

Files

• System/Cpuid.hs +385/−64
• cpuid.cabal +20/−13
• tests/TestCpuid.hs +9/−3

@@ -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

@@ -1,21 +1,21 @@ Name:               cpuid-Version:            0.2.1.3+Version:            0.2.2 License:            GPL License-file:       COPYING Author:             Martin Grabmueller <martin@grabmueller.de> 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

@@ -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