{-# LANGUAGE CPP #-}
{-# LANGUAGE MonoLocalBinds #-}
module System.CPUFeatures.X86.Cpuid
  ( CpuidResult(..)
  , X86Cpuid(..)
  , queryCpuid
  , getManufacturerString
  , Dict(Dict)
  ) where
import Data.Word
import System.CPUFeatures.Util
#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH)
import Data.Bits
import Data.Char (chr)
import System.IO.Unsafe
import Foreign.Marshal.Alloc
import Foreign.Storable
import Foreign.Ptr
#endif

data CpuidResult = CpuidResult { CpuidResult -> Word32
eax :: !Word32, CpuidResult -> Word32
ebx :: !Word32, CpuidResult -> Word32
ecx :: !Word32, CpuidResult -> Word32
edx :: !Word32 } deriving Int -> CpuidResult -> ShowS
[CpuidResult] -> ShowS
CpuidResult -> String
(Int -> CpuidResult -> ShowS)
-> (CpuidResult -> String)
-> ([CpuidResult] -> ShowS)
-> Show CpuidResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CpuidResult -> ShowS
showsPrec :: Int -> CpuidResult -> ShowS
$cshow :: CpuidResult -> String
show :: CpuidResult -> String
$cshowList :: [CpuidResult] -> ShowS
showList :: [CpuidResult] -> ShowS
Show

class X86Cpuid where
  cpuid :: Word32 -- ^ Initial eax value (leaf / function)
        -> Word32 -- ^ Initial ecx value (subleaf / subfunction)
        -> CpuidResult
  xgetbv :: Word32 -> Word64

queryCpuid :: Maybe (Dict X86Cpuid)

getManufacturerString :: X86Cpuid => String

#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH)

foreign import ccall unsafe hs_cpu_features_cpuid :: Word32 -> Word32 -> Ptr Word32 -> IO ()

foreign import ccall unsafe hs_cpu_features_xgetbv :: Word32 -> Word64

instance Word32 -> Word64
Word32 -> Word32 -> CpuidResult
(Word32 -> Word32 -> CpuidResult) -> (Word32 -> Word64) -> X86Cpuid
$ccpuid :: Word32 -> Word32 -> CpuidResult
$cxgetbv :: Word32 -> Word64
X86Cpuid where
  cpuid :: Word32 -> Word32 -> CpuidResult
cpuid !Word32
initialEax !Word32
initialEcx = IO CpuidResult -> CpuidResult
forall a. IO a -> a
unsafePerformIO (IO CpuidResult -> CpuidResult) -> IO CpuidResult -> CpuidResult
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Word32 -> IO CpuidResult) -> IO CpuidResult
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) ((Ptr Word32 -> IO CpuidResult) -> IO CpuidResult)
-> (Ptr Word32 -> IO CpuidResult) -> IO CpuidResult
forall a b. (a -> b) -> a -> b
$ \Ptr Word32
ptr -> do
    Word32 -> Word32 -> Ptr Word32 -> IO ()
hs_cpu_features_cpuid Word32
initialEax Word32
initialEcx Ptr Word32
ptr
    Word32
a <- Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
ptr
    Word32
b <- Ptr Word32 -> Int -> IO Word32
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word32
ptr Int
1
    Word32
c <- Ptr Word32 -> Int -> IO Word32
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word32
ptr Int
2
    Word32
d <- Ptr Word32 -> Int -> IO Word32
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word32
ptr Int
3
    CpuidResult -> IO CpuidResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CpuidResult -> IO CpuidResult) -> CpuidResult -> IO CpuidResult
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Word32 -> Word32 -> CpuidResult
CpuidResult Word32
a Word32
b Word32
c Word32
d
  xgetbv :: Word32 -> Word64
xgetbv = Word32 -> Word64
hs_cpu_features_xgetbv

queryCpuid :: Maybe (Dict X86Cpuid)
queryCpuid = Dict X86Cpuid -> Maybe (Dict X86Cpuid)
forall a. a -> Maybe a
Just Dict X86Cpuid
forall (c :: Constraint). c => Dict c
Dict

getManufacturerString :: X86Cpuid => String
getManufacturerString = case Word32 -> Word32 -> CpuidResult
X86Cpuid => Word32 -> Word32 -> CpuidResult
cpuid Word32
0 Word32
0 of
  CpuidResult Word32
_ Word32
b Word32
c Word32
d -> Word32 -> ShowS
wordToChars Word32
b ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word32 -> ShowS
wordToChars Word32
d ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word32 -> ShowS
wordToChars Word32
c String
""
  where
    bchr :: Word32 -> Char
bchr = Int -> Char
chr (Int -> Char) -> (Word32 -> Int) -> Word32 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    wordToChars :: Word32 -> ShowS
wordToChars Word32
x String
s = Word32 -> Char
bchr (Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Char -> ShowS
forall a. a -> [a] -> [a]
: Word32 -> Char
bchr ((Word32
x Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Char -> ShowS
forall a. a -> [a] -> [a]
: Word32 -> Char
bchr ((Word32
x Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Char -> ShowS
forall a. a -> [a] -> [a]
: Word32 -> Char
bchr ((Word32
x Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF) Char -> ShowS
forall a. a -> [a] -> [a]
: String
s

#else

queryCpuid = Nothing
getManufacturerString = undefined

#endif