{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE PatternSynonyms #-}

-- |
-- Module      : Crypto.System.CPU
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- Gives information about crypton runtime environment.
module Crypto.System.CPU (
    -- The names are bundled with the type rather than listed as
    -- `pattern' exports, so an importer writes ProcessorOption (..), or
    -- names the ones it wants, as it would for a type with constructors.
    ProcessorOption (
        -- x86
        AESNI,
        PCLMUL,
        SSSE3,
        AVX,
        AVX2,
        SHANI,
        MOVBE,
        ADX,
        VAES,
        VAES512,
        AVX512IFMA,
        -- AArch64
        NEON,
        ARMAES,
        ARMPMULL,
        ARMSHA1,
        ARMSHA2,
        ARMSHA512,
        -- PowerISA
        PPCAES,
        PPCVPMSUM
    ),
    processorOptions,

    -- * Questions that do not name an architecture
    hasAESAcceleration,
    hasGHASHAcceleration,
) where

import Control.Monad (filterM)
import Data.List (sort)
import Data.Word (Word16)
import Foreign.C.Types (CInt (..), CUInt (..))
import Crypto.Internal.Compat

-- | A processor feature crypton looked for, and dispatches on where it
-- finds it.
--
-- This is a number with names rather than a sum of constructors, and the
-- names are pattern synonyms with no @COMPLETE@ pragma, so a @case@ over
-- them needs a catch-all and a feature named in a later release breaks
-- nothing that compiled against this one.  The same reason 'Show' is
-- written out below: a program built against an older crypton still says
-- something useful about a value from a newer one.
--
-- The names are the processor's, not the operation's.  'AESNI' is x86's
-- and 'ARMAES' is AArch64's, and a machine reports only the ones it has;
-- ask 'hasAESAcceleration' if the question is whether AES is fast here.
--
-- They are bundled with the type in the export list, so @ProcessorOption
-- (..)@ brings in all of them and naming one brings in that one, as for a
-- type with constructors.  The constructor underneath is not exported:
-- these values say what the processor was found to have, and a caller has
-- nothing to build.
newtype ProcessorOption = ProcessorOption Word16
    deriving (ProcessorOption -> ProcessorOption -> Bool
(ProcessorOption -> ProcessorOption -> Bool)
-> (ProcessorOption -> ProcessorOption -> Bool)
-> Eq ProcessorOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProcessorOption -> ProcessorOption -> Bool
== :: ProcessorOption -> ProcessorOption -> Bool
$c/= :: ProcessorOption -> ProcessorOption -> Bool
/= :: ProcessorOption -> ProcessorOption -> Bool
Eq, Eq ProcessorOption
Eq ProcessorOption =>
(ProcessorOption -> ProcessorOption -> Ordering)
-> (ProcessorOption -> ProcessorOption -> Bool)
-> (ProcessorOption -> ProcessorOption -> Bool)
-> (ProcessorOption -> ProcessorOption -> Bool)
-> (ProcessorOption -> ProcessorOption -> Bool)
-> (ProcessorOption -> ProcessorOption -> ProcessorOption)
-> (ProcessorOption -> ProcessorOption -> ProcessorOption)
-> Ord ProcessorOption
ProcessorOption -> ProcessorOption -> Bool
ProcessorOption -> ProcessorOption -> Ordering
ProcessorOption -> ProcessorOption -> ProcessorOption
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ProcessorOption -> ProcessorOption -> Ordering
compare :: ProcessorOption -> ProcessorOption -> Ordering
$c< :: ProcessorOption -> ProcessorOption -> Bool
< :: ProcessorOption -> ProcessorOption -> Bool
$c<= :: ProcessorOption -> ProcessorOption -> Bool
<= :: ProcessorOption -> ProcessorOption -> Bool
$c> :: ProcessorOption -> ProcessorOption -> Bool
> :: ProcessorOption -> ProcessorOption -> Bool
$c>= :: ProcessorOption -> ProcessorOption -> Bool
>= :: ProcessorOption -> ProcessorOption -> Bool
$cmax :: ProcessorOption -> ProcessorOption -> ProcessorOption
max :: ProcessorOption -> ProcessorOption -> ProcessorOption
$cmin :: ProcessorOption -> ProcessorOption -> ProcessorOption
min :: ProcessorOption -> ProcessorOption -> ProcessorOption
Ord)

-- | Support for AES instructions, with flag @support_aesni@.
pattern AESNI :: ProcessorOption
pattern $mAESNI :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bAESNI :: ProcessorOption
AESNI = ProcessorOption 0

-- | Support for CLMUL instructions, with flag @support_pclmuldq@.
pattern PCLMUL :: ProcessorOption
pattern $mPCLMUL :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bPCLMUL :: ProcessorOption
PCLMUL = ProcessorOption 1

-- | Supplemental SSE3.
pattern SSSE3 :: ProcessorOption
pattern $mSSSE3 :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bSSSE3 :: ProcessorOption
SSSE3 = ProcessorOption 3

-- | AVX, and an operating system that saves its registers.
pattern AVX :: ProcessorOption
pattern $mAVX :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bAVX :: ProcessorOption
AVX = ProcessorOption 4

-- | AVX2, and an operating system that saves its registers.
pattern AVX2 :: ProcessorOption
pattern $mAVX2 :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bAVX2 :: ProcessorOption
AVX2 = ProcessorOption 5

-- | The SHA extensions, @sha1rnds4@ and @sha256rnds2@ and their neighbours.
pattern SHANI :: ProcessorOption
pattern $mSHANI :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bSHANI :: ProcessorOption
SHANI = ProcessorOption 6

-- | The byte-swapping load.
pattern MOVBE :: ProcessorOption
pattern $mMOVBE :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bMOVBE :: ProcessorOption
MOVBE = ProcessorOption 7

-- | @MULX@, @ADCX@ and @ADOX@: the two independent carry chains.
pattern ADX :: ProcessorOption
pattern $mADX :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bADX :: ProcessorOption
ADX = ProcessorOption 8

-- | The AES and carry-less multiply instructions in their 256-bit form.
pattern VAES :: ProcessorOption
pattern $mVAES :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bVAES :: ProcessorOption
VAES = ProcessorOption 9

-- | The same pair in their 512-bit form.
pattern VAES512 :: ProcessorOption
pattern $mVAES512 :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bVAES512 :: ProcessorOption
VAES512 = ProcessorOption 10

-- | The AVX-512 52-bit integer multiply-adds, with AVX-512 F and VL, and the
-- operating system saving their state: RSA's private-key operation uses them.
pattern AVX512IFMA :: ProcessorOption
pattern $mAVX512IFMA :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bAVX512IFMA :: ProcessorOption
AVX512IFMA = ProcessorOption 19

-- | Advanced SIMD, which is not optional on AArch64.
pattern NEON :: ProcessorOption
pattern $mNEON :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bNEON :: ProcessorOption
NEON = ProcessorOption 11

-- | The ARMv8 AES instructions.
pattern ARMAES :: ProcessorOption
pattern $mARMAES :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bARMAES :: ProcessorOption
ARMAES = ProcessorOption 12

-- | @PMULL@, the ARMv8 carry-less multiply.
pattern ARMPMULL :: ProcessorOption
pattern $mARMPMULL :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bARMPMULL :: ProcessorOption
ARMPMULL = ProcessorOption 13

-- | The ARMv8 SHA-1 instructions.
pattern ARMSHA1 :: ProcessorOption
pattern $mARMSHA1 :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bARMSHA1 :: ProcessorOption
ARMSHA1 = ProcessorOption 14

-- | The ARMv8 SHA-256 instructions.
pattern ARMSHA2 :: ProcessorOption
pattern $mARMSHA2 :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bARMSHA2 :: ProcessorOption
ARMSHA2 = ProcessorOption 15

-- | The ARMv8.2 SHA-512 instructions, which are optional where SHA-256's
-- are not.
pattern ARMSHA512 :: ProcessorOption
pattern $mARMSHA512 :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bARMSHA512 :: ProcessorOption
ARMSHA512 = ProcessorOption 16

-- | Support for the PowerISA 2.07 vector AES instructions, which POWER8 was
-- the first to implement.
pattern PPCAES :: ProcessorOption
pattern $mPPCAES :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bPPCAES :: ProcessorOption
PPCAES = ProcessorOption 17

-- | Support for @vpmsumd@, the vector carry-less multiply that came with
-- them, which is what makes GHASH fast.
pattern PPCVPMSUM :: ProcessorOption
pattern $mPPCVPMSUM :: forall {r}. ProcessorOption -> ((# #) -> r) -> ((# #) -> r) -> r
$bPPCVPMSUM :: ProcessorOption
PPCVPMSUM = ProcessorOption 18

-- | Named where the name is known, numbered where it is not, so that a
-- binary built against an older crypton can still print a value a newer one
-- produced.
instance Show ProcessorOption where
    show :: ProcessorOption -> String
show ProcessorOption
AESNI = String
"AESNI"
    show ProcessorOption
PCLMUL = String
"PCLMUL"
    show ProcessorOption
SSSE3 = String
"SSSE3"
    show ProcessorOption
AVX = String
"AVX"
    show ProcessorOption
AVX2 = String
"AVX2"
    show ProcessorOption
SHANI = String
"SHANI"
    show ProcessorOption
MOVBE = String
"MOVBE"
    show ProcessorOption
ADX = String
"ADX"
    show ProcessorOption
VAES = String
"VAES"
    show ProcessorOption
VAES512 = String
"VAES512"
    show ProcessorOption
AVX512IFMA = String
"AVX512IFMA"
    show ProcessorOption
NEON = String
"NEON"
    show ProcessorOption
ARMAES = String
"ARMAES"
    show ProcessorOption
ARMPMULL = String
"ARMPMULL"
    show ProcessorOption
ARMSHA1 = String
"ARMSHA1"
    show ProcessorOption
ARMSHA2 = String
"ARMSHA2"
    show ProcessorOption
ARMSHA512 = String
"ARMSHA512"
    show ProcessorOption
PPCAES = String
"PPCAES"
    show ProcessorOption
PPCVPMSUM = String
"PPCVPMSUM"
    show (ProcessorOption Word16
n) = String
"ProcessorOption " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
n

-- | Options which have been enabled at compile time and which this machine
-- says may be used: on x86-64 what the processor declares through CPUID, and
-- for the vector extensions only where the operating system saves their
-- state as well; elsewhere what the operating system reports of the
-- processor.
--
-- That is what crypton itself decides by, and it is not always everything
-- the core underneath executes.  A guest under a hypervisor may be shown an
-- older processor model than the host's, so that it can be moved to another
-- host -- and an instruction used because it happens to run would fail
-- there.  So an option missing here means crypton will not use it, not that
-- the hardware lacks it.
--
-- Sorted, and without repeats.  A machine reports the names of its own
-- architecture only: an AArch64 processor with AES says 'ARMAES', not
-- 'AESNI', which it does not have.
processorOptions :: [ProcessorOption]
processorOptions :: [ProcessorOption]
processorOptions = IO [ProcessorOption] -> [ProcessorOption]
forall a. IO a -> a
unsafeDoIO ([ProcessorOption] -> [ProcessorOption]
forall a. Ord a => [a] -> [a]
sort ([ProcessorOption] -> [ProcessorOption])
-> IO [ProcessorOption] -> IO [ProcessorOption]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProcessorOption -> IO Bool)
-> [ProcessorOption] -> IO [ProcessorOption]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ProcessorOption -> IO Bool
askC [ProcessorOption]
allOptions)
  where
    -- 2 is not asked for and has no name: it was RDRAND, which crypton no
    -- longer dispatches on.  The number is left out rather than reused, so
    -- that the others keep the values they had.
    allOptions :: [ProcessorOption]
allOptions = [Word16 -> ProcessorOption
ProcessorOption Word16
n | Word16
n <- [Word16
0 .. Word16
19], Word16
n Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
2]
    askC :: ProcessorOption -> IO Bool
askC (ProcessorOption Word16
n) =
        (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CUInt -> IO CInt
crypton_cpu_option (Word16 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
n)
{-# NOINLINE processorOptions #-}

-- | Is there hardware AES on this machine?
--
-- The instructions have different names on different architectures, and a
-- caller that wants to know whether AES-GCM will be fast wants this rather
-- than either name.
hasAESAcceleration :: Bool
hasAESAcceleration :: Bool
hasAESAcceleration =
    (ProcessorOption -> Bool) -> [ProcessorOption] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        (ProcessorOption -> [ProcessorOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProcessorOption]
processorOptions)
        [ProcessorOption
AESNI, ProcessorOption
ARMAES, ProcessorOption
PPCAES]

-- | Is there a hardware carry-less multiply, which is what GHASH, and so
-- AES-GCM, spends its time in once AES itself is fast?
hasGHASHAcceleration :: Bool
hasGHASHAcceleration :: Bool
hasGHASHAcceleration =
    (ProcessorOption -> Bool) -> [ProcessorOption] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
        (ProcessorOption -> [ProcessorOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ProcessorOption]
processorOptions)
        [ProcessorOption
PCLMUL, ProcessorOption
ARMPMULL, ProcessorOption
PPCVPMSUM]

foreign import ccall unsafe "crypton_cpu_option"
    crypton_cpu_option :: CUInt -> IO CInt