diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# Revision history for cpu-features + +## 0.1.0.0 -- 2025-04-26 + +Initial release. + +Supported platforms: + +* x86_64: via `cpuid` + * Windows + * macOS: uses `sysctlbyname` to detect AVX-512 + * Linux +* AArch64 + * macOS: via `sysctlbyname` + * Linux: via `getauxval(AT_HWCAP/AT_HWCAP2)` +* RISC-V 64 + * Linux: via `getauxval(AT_HWCAP)` and hwprobe diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2024, ARATA Mizuki + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# cpu-features for Haskell + +This is a library to detect the features supported by the CPU running the Haskell program. + +Supported platforms: + +* i386/x86_64: via `cpuid` + * Windows + * macOS: uses `sysctlbyname` to detect AVX-512 + * Linux +* AArch64 + * macOS: via `sysctlbyname` + * Linux: via `getauxval(AT_HWCAP/AT_HWCAP2)` +* RISC-V 64 + * Linux: via `getauxval(AT_HWCAP)` and hwprobe diff --git a/cbits/cpuid.c b/cbits/cpuid.c new file mode 100644 --- /dev/null +++ b/cbits/cpuid.c @@ -0,0 +1,14 @@ +#include +#include +#include + +void hs_cpu_features_cpuid(uint32_t eax, uint32_t ecx, uint32_t result[4]) +{ + __cpuid_count(eax, ecx, result[0], result[1], result[2], result[3]); +} + +__attribute__((target("xsave"))) +uint64_t hs_cpu_features_xgetbv(uint32_t a) +{ + return _xgetbv(a); +} diff --git a/cbits/hwprobe.c b/cbits/hwprobe.c new file mode 100644 --- /dev/null +++ b/cbits/hwprobe.c @@ -0,0 +1,21 @@ +// For RISC-V Linux +#define _GNU_SOURCE +#include +#include +#include +#include // cpu_set_t +#include // SYS_riscv_hwprobe + +uint64_t hs_cpu_features_hwprobe_ima_ext_0(void) +{ + struct riscv_hwprobe probe[1] = { + {.key = RISCV_HWPROBE_KEY_IMA_EXT_0, .value = 0}, + }; + // long result = sys_riscv_hwprobe(probe, 1, 0, NULL, 0); + long result = syscall(SYS_riscv_hwprobe, probe, (size_t)1, (size_t)0, (cpu_set_t *)NULL, 0u); + if (result == 0) { + return probe[0].value; + } else { + return 0; + } +} diff --git a/cbits/sysctl.c b/cbits/sysctl.c new file mode 100644 --- /dev/null +++ b/cbits/sysctl.c @@ -0,0 +1,10 @@ +#include "HsFFI.h" +#include + +HsBool hs_cpu_features_sysctl(const char *name) +{ + int result = 0; + size_t len = sizeof(result); + int succ = sysctlbyname(name, &result, &len, NULL, 0); + return succ == 0 && result != 0; +} diff --git a/cpu-features.cabal b/cpu-features.cabal new file mode 100644 --- /dev/null +++ b/cpu-features.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: cpu-features +version: 0.1.0.0 +synopsis: A library to detect CPU features +description: This is a library to detect the features supported by the CPU running the Haskell program. +license: BSD-3-Clause +license-file: LICENSE +author: ARATA Mizuki +maintainer: minorinoki@gmail.com +copyright: 2025 ARATA Mizuki +category: System +build-type: Simple +extra-doc-files: README.md CHANGELOG.md +-- extra-source-files: + +common warnings + ghc-options: -Wall -Wno-unticked-promoted-constructors + +library + import: warnings + exposed-modules: System.CPUFeatures.X86 + System.CPUFeatures.X86.Bool + System.CPUFeatures.X86.TypeBool + System.CPUFeatures.X86.Constraint + System.CPUFeatures.X86.Constraint.Unsafe + System.CPUFeatures.X86.Cpuid + System.CPUFeatures.Arm + System.CPUFeatures.Arm.Bool + System.CPUFeatures.Arm.TypeBool + System.CPUFeatures.Arm.Constraint + System.CPUFeatures.Arm.Constraint.Unsafe + System.CPUFeatures.RISCV + System.CPUFeatures.RISCV.Bool + System.CPUFeatures.RISCV.TypeBool + System.CPUFeatures.RISCV.Constraint + System.CPUFeatures.RISCV.Constraint.Unsafe + System.CPUFeatures.Util + -- other-modules: + -- other-extensions: + if os(darwin) + c-sources: cbits/sysctl.c + if os(linux) && (arch(aarch64) || arch(riscv64)) + other-modules: Hwcap + if arch(x86_64) || arch(i386) + c-sources: cbits/cpuid.c + if os(linux) && arch(riscv64) + other-modules: Hwprobe + c-sources: cbits/hwprobe.c + build-depends: base >=4.16.0.0 && <4.22 + hs-source-dirs: src + default-language: GHC2021 + +executable cpu-features-demo + import: warnings + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: + base >=4.16.0.0 && <4.22, + cpu-features + + hs-source-dirs: demo + default-language: GHC2021 + +test-suite cpu-features-test + import: warnings + default-language: GHC2021 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base >=4.16.0.0 && <4.22, + cpu-features diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE GADTs #-} +module Main where + +import System.CPUFeatures.X86 as X86 +import System.CPUFeatures.X86.Cpuid as X86 +import System.CPUFeatures.Arm as Arm +import System.CPUFeatures.RISCV as RISCV + +main :: IO () +main = do + case X86.queryCpuid of + Just Dict -> putStrLn $ "X86 Manufacturer: " ++ getManufacturerString + Nothing -> putStrLn "Not X86" + putStrLn $ "X86.AESNI = " ++ show X86.bAESNI + putStrLn $ "X86.AMX_BF16 = " ++ show X86.bAMX_BF16 + putStrLn $ "X86.AMX_FP16 = " ++ show X86.bAMX_FP16 + putStrLn $ "X86.AMX_INT8 = " ++ show X86.bAMX_INT8 + putStrLn $ "X86.AMX_TILE = " ++ show X86.bAMX_TILE + putStrLn $ "X86.AVX = " ++ show X86.bAVX + putStrLn $ "X86.AVX_VNNI = " ++ show X86.bAVX_VNNI + putStrLn $ "X86.AVX10_1 = " ++ show X86.bAVX10_1 + putStrLn $ "X86.AVX10_2 = " ++ show X86.bAVX10_2 + putStrLn $ "X86.AVX2 = " ++ show X86.bAVX2 + putStrLn $ "X86.AVX512_BF16 = " ++ show X86.bAVX512_BF16 + putStrLn $ "X86.AVX512_BITALG = " ++ show X86.bAVX512_BITALG + putStrLn $ "X86.AVX512_FP16 = " ++ show X86.bAVX512_FP16 + putStrLn $ "X86.AVX512_IFMA = " ++ show X86.bAVX512_IFMA + putStrLn $ "X86.AVX512_VBMI = " ++ show X86.bAVX512_VBMI + putStrLn $ "X86.AVX512_VBMI2 = " ++ show X86.bAVX512_VBMI2 + putStrLn $ "X86.AVX512_VNNI = " ++ show X86.bAVX512_VNNI + putStrLn $ "X86.AVX512_VPOPCNTDQ = " ++ show X86.bAVX512_VPOPCNTDQ + putStrLn $ "X86.AVX512BW = " ++ show X86.bAVX512BW + putStrLn $ "X86.AVX512CD = " ++ show X86.bAVX512CD + putStrLn $ "X86.AVX512DQ = " ++ show X86.bAVX512DQ + putStrLn $ "X86.AVX512F = " ++ show X86.bAVX512F + putStrLn $ "X86.AVX512VL = " ++ show X86.bAVX512VL + putStrLn $ "X86.BMI1 = " ++ show X86.bBMI1 + putStrLn $ "X86.BMI2 = " ++ show X86.bBMI2 + putStrLn $ "X86.F16C = " ++ show X86.bF16C + putStrLn $ "X86.FMA = " ++ show X86.bFMA + putStrLn $ "X86.GFNI = " ++ show X86.bGFNI + putStrLn $ "X86.PCLMULQDQ = " ++ show X86.bPCLMULQDQ + putStrLn $ "X86.POPCNT = " ++ show X86.bPOPCNT + putStrLn $ "X86.RDRAND = " ++ show X86.bRDRAND + putStrLn $ "X86.SHA = " ++ show X86.bSHA + putStrLn $ "X86.SSE3 = " ++ show X86.bSSE3 + putStrLn $ "X86.SSE4_1 = " ++ show X86.bSSE4_1 + putStrLn $ "X86.SSE4_2 = " ++ show X86.bSSE4_2 + putStrLn $ "X86.SSSE3 = " ++ show X86.bSSSE3 + putStrLn $ "X86.VAES = " ++ show X86.bVAES + putStrLn $ "X86.VPCLMULQDQ = " ++ show X86.bVPCLMULQDQ + putStrLn $ "Arm.FEAT_AES = " ++ show Arm.bFEAT_AES + putStrLn $ "Arm.FEAT_AFP = " ++ show Arm.bFEAT_AFP + putStrLn $ "Arm.FEAT_BF16 = " ++ show Arm.bFEAT_BF16 + putStrLn $ "Arm.FEAT_BTI = " ++ show Arm.bFEAT_BTI + putStrLn $ "Arm.FEAT_CSV2 = " ++ show Arm.bFEAT_CSV2 + putStrLn $ "Arm.FEAT_CSV3 = " ++ show Arm.bFEAT_CSV3 + putStrLn $ "Arm.FEAT_DIT = " ++ show Arm.bFEAT_DIT + putStrLn $ "Arm.FEAT_DotProd = " ++ show Arm.bFEAT_DotProd + putStrLn $ "Arm.FEAT_DPB = " ++ show Arm.bFEAT_DPB + putStrLn $ "Arm.FEAT_DPB2 = " ++ show Arm.bFEAT_DPB2 + putStrLn $ "Arm.FEAT_ECV = " ++ show Arm.bFEAT_ECV + putStrLn $ "Arm.FEAT_FCMA = " ++ show Arm.bFEAT_FCMA + putStrLn $ "Arm.FEAT_FHM = " ++ show Arm.bFEAT_FHM + putStrLn $ "Arm.FEAT_FlagM = " ++ show Arm.bFEAT_FlagM + putStrLn $ "Arm.FEAT_FlagM2 = " ++ show Arm.bFEAT_FlagM2 + putStrLn $ "Arm.FEAT_FP16 = " ++ show Arm.bFEAT_FP16 + putStrLn $ "Arm.FEAT_FPAC = " ++ show Arm.bFEAT_FPAC + putStrLn $ "Arm.FEAT_FRINTTS = " ++ show Arm.bFEAT_FRINTTS + putStrLn $ "Arm.FEAT_I8MM = " ++ show Arm.bFEAT_I8MM + putStrLn $ "Arm.FEAT_JSCVT = " ++ show Arm.bFEAT_JSCVT + putStrLn $ "Arm.FEAT_LRCPC = " ++ show Arm.bFEAT_LRCPC + putStrLn $ "Arm.FEAT_LRCPC2 = " ++ show Arm.bFEAT_LRCPC2 + putStrLn $ "Arm.FEAT_LSE = " ++ show Arm.bFEAT_LSE + putStrLn $ "Arm.FEAT_LSE2 = " ++ show Arm.bFEAT_LSE2 + putStrLn $ "Arm.FEAT_PAuth = " ++ show Arm.bFEAT_PAuth + putStrLn $ "Arm.FEAT_PAuth2 = " ++ show Arm.bFEAT_PAuth2 + putStrLn $ "Arm.FEAT_PMULL = " ++ show Arm.bFEAT_PMULL + putStrLn $ "Arm.FEAT_RDM = " ++ show Arm.bFEAT_RDM + putStrLn $ "Arm.FEAT_RPRES = " ++ show Arm.bFEAT_RPRES + putStrLn $ "Arm.FEAT_SB = " ++ show Arm.bFEAT_SB + putStrLn $ "Arm.FEAT_SHA1 = " ++ show Arm.bFEAT_SHA1 + putStrLn $ "Arm.FEAT_SHA256 = " ++ show Arm.bFEAT_SHA256 + putStrLn $ "Arm.FEAT_SHA3 = " ++ show Arm.bFEAT_SHA3 + putStrLn $ "Arm.FEAT_SHA512 = " ++ show Arm.bFEAT_SHA512 + putStrLn $ "Arm.FEAT_SME = " ++ show Arm.bFEAT_SME + putStrLn $ "Arm.FEAT_SME_F64F64 = " ++ show Arm.bFEAT_SME_F64F64 + putStrLn $ "Arm.FEAT_SME_I16I64 = " ++ show Arm.bFEAT_SME_I16I64 + putStrLn $ "Arm.FEAT_SME2 = " ++ show Arm.bFEAT_SME2 + putStrLn $ "Arm.FEAT_SPECRES = " ++ show Arm.bFEAT_SPECRES + putStrLn $ "Arm.FEAT_SSBS = " ++ show Arm.bFEAT_SSBS + putStrLn $ "Arm.FEAT_SVE = " ++ show Arm.bFEAT_SVE + putStrLn $ "Arm.FEAT_SVE2 = " ++ show Arm.bFEAT_SVE2 + putStrLn $ "Arm.FEAT_WFxT = " ++ show Arm.bFEAT_WFxT + putStrLn $ "RISCV.C = " ++ show RISCV.bC + putStrLn $ "RISCV.V = " ++ show RISCV.bV + putStrLn $ "RISCV.Zba = " ++ show RISCV.bZba + putStrLn $ "RISCV.Zbb = " ++ show RISCV.bZbb + putStrLn $ "RISCV.Zbs = " ++ show RISCV.bZbs + putStrLn $ "RISCV.Zicboz = " ++ show RISCV.bZicboz + putStrLn $ "RISCV.Zbc = " ++ show RISCV.bZbc + putStrLn $ "RISCV.Zbkb = " ++ show RISCV.bZbkb + putStrLn $ "RISCV.Zbkc = " ++ show RISCV.bZbkc + putStrLn $ "RISCV.Zbkx = " ++ show RISCV.bZbkx + putStrLn $ "RISCV.Zknd = " ++ show RISCV.bZknd + putStrLn $ "RISCV.Zkne = " ++ show RISCV.bZkne + putStrLn $ "RISCV.Zknh = " ++ show RISCV.bZknh + putStrLn $ "RISCV.Zksed = " ++ show RISCV.bZksed + putStrLn $ "RISCV.Zksh = " ++ show RISCV.bZksh + putStrLn $ "RISCV.Zkt = " ++ show RISCV.bZkt + putStrLn $ "RISCV.Zvbb = " ++ show RISCV.bZvbb + putStrLn $ "RISCV.Zvbc = " ++ show RISCV.bZvbc + putStrLn $ "RISCV.Zvkb = " ++ show RISCV.bZvkb + putStrLn $ "RISCV.Zvkg = " ++ show RISCV.bZvkg + putStrLn $ "RISCV.Zvkned = " ++ show RISCV.bZvkned + putStrLn $ "RISCV.Zvknha = " ++ show RISCV.bZvknha + putStrLn $ "RISCV.Zvknhb = " ++ show RISCV.bZvknhb + putStrLn $ "RISCV.Zvksed = " ++ show RISCV.bZvksed + putStrLn $ "RISCV.Zvksh = " ++ show RISCV.bZvksh + putStrLn $ "RISCV.Zvkt = " ++ show RISCV.bZvkt + putStrLn $ "RISCV.Zfh = " ++ show RISCV.bZfh + putStrLn $ "RISCV.Zfhmin = " ++ show RISCV.bZfhmin + putStrLn $ "RISCV.Zihintntl = " ++ show RISCV.bZihintntl + putStrLn $ "RISCV.Zvfh = " ++ show RISCV.bZvfh + putStrLn $ "RISCV.Zvfhmin = " ++ show RISCV.bZvfhmin + putStrLn $ "RISCV.Zfa = " ++ show RISCV.bZfa + putStrLn $ "RISCV.Ztso = " ++ show RISCV.bZtso + putStrLn $ "RISCV.Zacas = " ++ show RISCV.bZacas + putStrLn $ "RISCV.Zicntr = " ++ show RISCV.bZicntr + putStrLn $ "RISCV.Zicond = " ++ show RISCV.bZicond + putStrLn $ "RISCV.Zihintpause = " ++ show RISCV.bZihintpause + putStrLn $ "RISCV.Zihpm = " ++ show RISCV.bZihpm + putStrLn $ "RISCV.Zve32x = " ++ show RISCV.bZve32x + putStrLn $ "RISCV.Zve32f = " ++ show RISCV.bZve32f + putStrLn $ "RISCV.Zve64x = " ++ show RISCV.bZve64x + putStrLn $ "RISCV.Zve64f = " ++ show RISCV.bZve64f + putStrLn $ "RISCV.Zve64d = " ++ show RISCV.bZve64d + putStrLn $ "RISCV.Zimop = " ++ show RISCV.bZimop + putStrLn $ "RISCV.Zca = " ++ show RISCV.bZca + putStrLn $ "RISCV.Zcb = " ++ show RISCV.bZcb + putStrLn $ "RISCV.Zcd = " ++ show RISCV.bZcd + putStrLn $ "RISCV.Zcf = " ++ show RISCV.bZcf + putStrLn $ "RISCV.Zcmop = " ++ show RISCV.bZcmop + putStrLn $ "RISCV.Zawrs = " ++ show RISCV.bZawrs + putStrLn $ "RISCV.Zaamo = " ++ show RISCV.bZaamo + putStrLn $ "RISCV.Zalrsc = " ++ show RISCV.bZalrsc + putStrLn $ "RISCV.Supm = " ++ show RISCV.bSupm + putStrLn $ "RISCV.Zfbfmin = " ++ show RISCV.bZfbfmin + putStrLn $ "RISCV.Zvfbfmin = " ++ show RISCV.bZvfbfmin + putStrLn $ "RISCV.Zvfbfwma = " ++ show RISCV.bZvfbfwma + putStrLn $ "RISCV.Zicbom = " ++ show RISCV.bZicbom diff --git a/src/Hwcap.hsc b/src/Hwcap.hsc new file mode 100644 --- /dev/null +++ b/src/Hwcap.hsc @@ -0,0 +1,224 @@ +{-# LANGUAGE CApiFFI #-} +module Hwcap where +import Foreign.C.Types +#if defined(riscv64_HOST_ARCH) +import Data.Char (ord) +import Data.Bits (bit) +#endif + +#include + +foreign import capi unsafe "sys/auxv.h getauxval" getauxval :: CULong -> CULong + +{-# NOINLINE hwcap #-} +hwcap :: CULong +hwcap = getauxval #{const AT_HWCAP} + +hwcap2 :: CULong +#if defined(AT_HWCAP2) +hwcap2 = getauxval #{const AT_HWCAP2} +{-# NOINLINE hwcap2 #-} +#else +hwcap2 = 0 +#endif + +#if defined(aarch64_HOST_ARCH) + +hwcap_FP :: CULong +hwcap_FP = #{const HWCAP_FP} + +hwcap_ASIMD :: CULong +hwcap_ASIMD = #{const HWCAP_ASIMD} + +hwcap_EVTSTRM :: CULong +hwcap_EVTSTRM = #{const HWCAP_EVTSTRM} + +hwcap_AES :: CULong +hwcap_AES = #{const HWCAP_AES} + +hwcap_PMULL :: CULong +hwcap_PMULL = #{const HWCAP_PMULL} + +hwcap_SHA1 :: CULong +hwcap_SHA1 = #{const HWCAP_SHA1} + +hwcap_SHA2 :: CULong +hwcap_SHA2 = #{const HWCAP_SHA2} + +hwcap_CRC32 :: CULong +hwcap_CRC32 = #{const HWCAP_CRC32} + +hwcap_ATOMICS :: CULong +hwcap_ATOMICS = #{const HWCAP_ATOMICS} + +hwcap_FPHP :: CULong +hwcap_FPHP = #{const HWCAP_FPHP} + +hwcap_ASIMDHP :: CULong +hwcap_ASIMDHP = #{const HWCAP_ASIMDHP} + +hwcap_CPUID :: CULong +hwcap_CPUID = #{const HWCAP_CPUID} + +hwcap_ASIMDRDM :: CULong +hwcap_ASIMDRDM = #{const HWCAP_ASIMDRDM} + +hwcap_JSCVT :: CULong +hwcap_JSCVT = #{const HWCAP_JSCVT} + +hwcap_FCMA :: CULong +hwcap_FCMA = #{const HWCAP_FCMA} + +hwcap_LRCPC :: CULong +hwcap_LRCPC = #{const HWCAP_LRCPC} + +hwcap_DCPOP :: CULong +hwcap_DCPOP = #{const HWCAP_DCPOP} + +hwcap_SHA3 :: CULong +hwcap_SHA3 = #{const HWCAP_SHA3} + +hwcap_SM3 :: CULong +hwcap_SM3 = #{const HWCAP_SM3} + +hwcap_SM4 :: CULong +hwcap_SM4 = #{const HWCAP_SM4} + +hwcap_ASIMDDP :: CULong +hwcap_ASIMDDP = #{const HWCAP_ASIMDDP} + +hwcap_SHA512 :: CULong +hwcap_SHA512 = #{const HWCAP_SHA512} + +hwcap_SVE :: CULong +hwcap_SVE = #{const HWCAP_SVE} + +hwcap_ASIMDFHM :: CULong +hwcap_ASIMDFHM = #{const HWCAP_ASIMDFHM} + +hwcap_DIT :: CULong +hwcap_DIT = #{const HWCAP_DIT} + +hwcap_USCAT :: CULong +hwcap_USCAT = #{const HWCAP_USCAT} + +hwcap_ILRCPC :: CULong +hwcap_ILRCPC = #{const HWCAP_ILRCPC} + +hwcap_FLAGM :: CULong +hwcap_FLAGM = #{const HWCAP_FLAGM} + +hwcap_SSBS :: CULong +hwcap_SSBS = #{const HWCAP_SSBS} + +hwcap_SB :: CULong +hwcap_SB = #{const HWCAP_SB} + +hwcap_PACA :: CULong +hwcap_PACA = #{const HWCAP_PACA} + +hwcap_PACG :: CULong +hwcap_PACG = #{const HWCAP_PACG} + +hwcap2_DCPODP :: CULong +hwcap2_DCPODP = #{const HWCAP2_DCPODP} + +hwcap2_SVE2 :: CULong +hwcap2_SVE2 = #{const HWCAP2_SVE2} + +hwcap2_SVEAES :: CULong +hwcap2_SVEAES = #{const HWCAP2_SVEAES} + +hwcap2_SVEPMULL :: CULong +hwcap2_SVEPMULL = #{const HWCAP2_SVEPMULL} + +hwcap2_SVEBITPERM :: CULong +hwcap2_SVEBITPERM = #{const HWCAP2_SVEBITPERM} + +hwcap2_SVESHA3 :: CULong +hwcap2_SVESHA3 = #{const HWCAP2_SVESHA3} + +hwcap2_SVESM4 :: CULong +hwcap2_SVESM4 = #{const HWCAP2_SVESM4} + +hwcap2_FLAGM2 :: CULong +hwcap2_FLAGM2 = #{const HWCAP2_FLAGM2} + +hwcap2_FRINT :: CULong +hwcap2_FRINT = #{const HWCAP2_FRINT} + +hwcap2_SVEI8MM :: CULong +hwcap2_SVEI8MM = #{const HWCAP2_SVEI8MM} + +hwcap2_SVEF32MM :: CULong +hwcap2_SVEF32MM = #{const HWCAP2_SVEF32MM} + +hwcap2_SVEF64MM :: CULong +hwcap2_SVEF64MM = #{const HWCAP2_SVEF64MM} + +hwcap2_SVEBF16 :: CULong +hwcap2_SVEBF16 = #{const HWCAP2_SVEBF16} + +hwcap2_I8MM :: CULong +hwcap2_I8MM = #{const HWCAP2_I8MM} + +hwcap2_BF16 :: CULong +hwcap2_BF16 = #{const HWCAP2_BF16} + +hwcap2_DGH :: CULong +hwcap2_DGH = #{const HWCAP2_DGH} + +hwcap2_RNG :: CULong +hwcap2_RNG = #{const HWCAP2_RNG} + +hwcap2_BTI :: CULong +hwcap2_BTI = #{const HWCAP2_BTI} + +hwcap2_MTE :: CULong +hwcap2_MTE = #{const HWCAP2_MTE} + +hwcap2_AFP :: CULong +hwcap2_AFP = #{const HWCAP2_AFP} + +hwcap2_RPRES :: CULong +hwcap2_RPRES = #{const HWCAP2_RPRES} + +hwcap2_SME :: CULong +hwcap2_SME = #{const HWCAP2_SME} + +hwcap2_SME_F64F64 :: CULong +hwcap2_SME_F64F64 = #{const HWCAP2_SME_F64F64} + +hwcap2_SME_I16I64 :: CULong +hwcap2_SME_I16I64 = #{const HWCAP2_SME_I16I64} + +hwcap2_SME2 :: CULong +hwcap2_SME2 = #{const HWCAP2_SME2} + +hwcap2_WFXT :: CULong +hwcap2_WFXT = #{const HWCAP2_WFXT} + +#elif defined(riscv64_HOST_ARCH) + +hwcap_I :: CULong +hwcap_I = bit (ord 'I' - ord 'A') + +hwcap_M :: CULong +hwcap_M = bit (ord 'M' - ord 'A') + +hwcap_A :: CULong +hwcap_A = bit (ord 'A' - ord 'A') + +hwcap_F :: CULong +hwcap_F = bit (ord 'F' - ord 'A') + +hwcap_D :: CULong +hwcap_D = bit (ord 'D' - ord 'A') + +hwcap_C :: CULong +hwcap_C = bit (ord 'C' - ord 'A') + +hwcap_V :: CULong +hwcap_V = bit (ord 'V' - ord 'A') + +#endif diff --git a/src/Hwprobe.hsc b/src/Hwprobe.hsc new file mode 100644 --- /dev/null +++ b/src/Hwprobe.hsc @@ -0,0 +1,281 @@ +{-# LANGUAGE CApiFFI #-} +module Hwprobe where +import Data.Bits (bit) +import Data.Word (Word64) +import Foreign.C.Types +import System.IO.Unsafe (unsafePerformIO) + +#include + +foreign import ccall unsafe hs_cpu_features_hwprobe_ima_ext_0 :: IO Word64 + +hwprobe_ima_ext_0 :: Word64 +hwprobe_ima_ext_0 = unsafePerformIO hs_cpu_features_hwprobe_ima_ext_0 +{-# NOINLINE hwprobe_ima_ext_0 #-} + +hwprobe_IMA_FD :: Word64 +hwprobe_IMA_FD = #{const RISCV_HWPROBE_IMA_FD} + +hwprobe_IMA_C :: Word64 +hwprobe_IMA_C = #{const RISCV_HWPROBE_IMA_C} + +hwprobe_IMA_V :: Word64 +hwprobe_IMA_V = #{const RISCV_HWPROBE_IMA_V} + +hwprobe_EXT_ZBA :: Word64 +hwprobe_EXT_ZBA = #{const RISCV_HWPROBE_EXT_ZBA} + +hwprobe_EXT_ZBB :: Word64 +hwprobe_EXT_ZBB = #{const RISCV_HWPROBE_EXT_ZBB} + +hwprobe_EXT_ZBS :: Word64 +hwprobe_EXT_ZBS = #{const RISCV_HWPROBE_EXT_ZBS} + +hwprobe_EXT_ZICBOZ :: Word64 +hwprobe_EXT_ZICBOZ = #{const RISCV_HWPROBE_EXT_ZICBOZ} + +hwprobe_EXT_ZBC :: Word64 +hwprobe_EXT_ZBC = #{const RISCV_HWPROBE_EXT_ZBC} + +hwprobe_EXT_ZBKB :: Word64 +hwprobe_EXT_ZBKB = #{const RISCV_HWPROBE_EXT_ZBKB} + +hwprobe_EXT_ZBKC :: Word64 +hwprobe_EXT_ZBKC = #{const RISCV_HWPROBE_EXT_ZBKC} + +hwprobe_EXT_ZBKX :: Word64 +hwprobe_EXT_ZBKX = #{const RISCV_HWPROBE_EXT_ZBKX} + +hwprobe_EXT_ZKND :: Word64 +hwprobe_EXT_ZKND = #{const RISCV_HWPROBE_EXT_ZKND} + +hwprobe_EXT_ZKNE :: Word64 +hwprobe_EXT_ZKNE = #{const RISCV_HWPROBE_EXT_ZKNE} + +hwprobe_EXT_ZKNH :: Word64 +hwprobe_EXT_ZKNH = #{const RISCV_HWPROBE_EXT_ZKNH} + +hwprobe_EXT_ZKSED :: Word64 +hwprobe_EXT_ZKSED = #{const RISCV_HWPROBE_EXT_ZKSED} + +hwprobe_EXT_ZKSH :: Word64 +hwprobe_EXT_ZKSH = #{const RISCV_HWPROBE_EXT_ZKSH} + +hwprobe_EXT_ZKT :: Word64 +hwprobe_EXT_ZKT = #{const RISCV_HWPROBE_EXT_ZKT} + +hwprobe_EXT_ZVBB :: Word64 +hwprobe_EXT_ZVBB = #{const RISCV_HWPROBE_EXT_ZVBB} + +hwprobe_EXT_ZVBC :: Word64 +hwprobe_EXT_ZVBC = #{const RISCV_HWPROBE_EXT_ZVBC} + +hwprobe_EXT_ZVKB :: Word64 +hwprobe_EXT_ZVKB = #{const RISCV_HWPROBE_EXT_ZVKB} + +hwprobe_EXT_ZVKG :: Word64 +hwprobe_EXT_ZVKG = #{const RISCV_HWPROBE_EXT_ZVKG} + +hwprobe_EXT_ZVKNED :: Word64 +hwprobe_EXT_ZVKNED = #{const RISCV_HWPROBE_EXT_ZVKNED} + +hwprobe_EXT_ZVKNHA :: Word64 +hwprobe_EXT_ZVKNHA = #{const RISCV_HWPROBE_EXT_ZVKNHA} + +hwprobe_EXT_ZVKNHB :: Word64 +hwprobe_EXT_ZVKNHB = #{const RISCV_HWPROBE_EXT_ZVKNHB} + +hwprobe_EXT_ZVKSED :: Word64 +hwprobe_EXT_ZVKSED = #{const RISCV_HWPROBE_EXT_ZVKSED} + +hwprobe_EXT_ZVKSH :: Word64 +hwprobe_EXT_ZVKSH = #{const RISCV_HWPROBE_EXT_ZVKSH} + +hwprobe_EXT_ZVKT :: Word64 +hwprobe_EXT_ZVKT = #{const RISCV_HWPROBE_EXT_ZVKT} + +hwprobe_EXT_ZFH :: Word64 +hwprobe_EXT_ZFH = #{const RISCV_HWPROBE_EXT_ZFH} + +hwprobe_EXT_ZFHMIN :: Word64 +hwprobe_EXT_ZFHMIN = #{const RISCV_HWPROBE_EXT_ZFHMIN} + +hwprobe_EXT_ZIHINTNTL :: Word64 +hwprobe_EXT_ZIHINTNTL = #{const RISCV_HWPROBE_EXT_ZIHINTNTL} + +hwprobe_EXT_ZVFH :: Word64 +hwprobe_EXT_ZVFH = #{const RISCV_HWPROBE_EXT_ZVFH} + +hwprobe_EXT_ZVFHMIN :: Word64 +-- An older header defines RISCV_HWPROBE_EXT_ZVFHMIN as "(1 << 31)", not "(1ULL << 31)" +#if RISCV_HWPROBE_EXT_ZVFHMIN == (1ULL << 31) +hwprobe_EXT_ZVFHMIN = bit 31 +#else +hwprobe_EXT_ZVFHMIN = #{const RISCV_HWPROBE_EXT_ZVFHMIN} +#endif + +hwprobe_EXT_ZFA :: Word64 +hwprobe_EXT_ZFA = #{const RISCV_HWPROBE_EXT_ZFA} + +hwprobe_EXT_ZTSO :: Word64 +hwprobe_EXT_ZTSO = #{const RISCV_HWPROBE_EXT_ZTSO} + +hwprobe_EXT_ZACAS :: Word64 +hwprobe_EXT_ZACAS = #{const RISCV_HWPROBE_EXT_ZACAS} + +hwprobe_EXT_ZICNTR :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZICNTR +hwprobe_EXT_ZICNTR = #{const RISCV_HWPROBE_EXT_ZICNTR} +#else +hwprobe_EXT_ZICNTR = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZICOND :: Word64 +hwprobe_EXT_ZICOND = #{const RISCV_HWPROBE_EXT_ZICOND} + +hwprobe_EXT_ZIHINTPAUSE :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZHINTPAUSE +hwprobe_EXT_ZIHINTPAUSE = #{const RISCV_HWPROBE_EXT_ZIHINTPAUSE} +#else +hwprobe_EXT_ZIHINTPAUSE = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZIHPM :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZIHPM +hwprobe_EXT_ZIHPM = #{const RISCV_HWPROBE_EXT_ZIHPM} +#else +hwprobe_EXT_ZIHPM = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVE32X :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVE32X +hwprobe_EXT_ZVE32X = #{const RISCV_HWPROBE_EXT_ZVE32X} +#else +hwprobe_EXT_ZVE32X = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVE32F :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVE32F +hwprobe_EXT_ZVE32F = #{const RISCV_HWPROBE_EXT_ZVE32F} +#else +hwprobe_EXT_ZVE32F = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVE64X :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVE64X +hwprobe_EXT_ZVE64X = #{const RISCV_HWPROBE_EXT_ZVE64X} +#else +hwprobe_EXT_ZVE64X = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVE64F :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVE64F +hwprobe_EXT_ZVE64F = #{const RISCV_HWPROBE_EXT_ZVE64F} +#else +hwprobe_EXT_ZVE64F = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVE64D :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVE64D +hwprobe_EXT_ZVE64D = #{const RISCV_HWPROBE_EXT_ZVE64D} +#else +hwprobe_EXT_ZVE64D = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZIMOP :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZIMOP +hwprobe_EXT_ZIMOP = #{const RISCV_HWPROBE_EXT_ZIMOP} +#else +hwprobe_EXT_ZIMOP = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZCA :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZCA +hwprobe_EXT_ZCA = #{const RISCV_HWPROBE_EXT_ZCA} +#else +hwprobe_EXT_ZCA = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZCB :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZCB +hwprobe_EXT_ZCB = #{const RISCV_HWPROBE_EXT_ZCB} +#else +hwprobe_EXT_ZCB = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZCD :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZCD +hwprobe_EXT_ZCD = #{const RISCV_HWPROBE_EXT_ZCD} +#else +hwprobe_EXT_ZCD = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZCF :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZCF +hwprobe_EXT_ZCF = #{const RISCV_HWPROBE_EXT_ZCF} +#else +hwprobe_EXT_ZCF = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZCMOP :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZCMOP +hwprobe_EXT_ZCMOP = #{const RISCV_HWPROBE_EXT_ZCMOP} +#else +hwprobe_EXT_ZCMOP = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZAWRS :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZAWRS +hwprobe_EXT_ZAWRS = #{const RISCV_HWPROBE_EXT_ZAWRS} +#else +hwprobe_EXT_ZAWRS = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZAAMO :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZAAMO +hwprobe_EXT_ZAAMO = #{const RISCV_HWPROBE_EXT_ZAAMO} +#else +hwprobe_EXT_ZAAMO = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZALRSC :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZALRSC +hwprobe_EXT_ZALRSC = #{const RISCV_HWPROBE_EXT_ZALRSC} +#else +hwprobe_EXT_ZALRSC = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_SUPM :: Word64 +#ifdef RISCV_HWPROBE_EXT_SUPM +hwprobe_EXT_SUPM = #{const RISCV_HWPROBE_EXT_SUPM} +#else +hwprobe_EXT_SUPM = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZFBFMIN :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZFBFMIN +hwprobe_EXT_ZFBFMIN = #{const RISCV_HWPROBE_EXT_ZFBFMIN} +#else +hwprobe_EXT_ZFBFMIN = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVFBFMIN :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVFBFMIN +hwprobe_EXT_ZVFBFMIN = #{const RISCV_HWPROBE_EXT_ZVFBFMIN} +#else +hwprobe_EXT_ZVFBFMIN = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZVFBFWMA :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZVFBFWMA +hwprobe_EXT_ZVFBFWMA = #{const RISCV_HWPROBE_EXT_ZVFBFWMA} +#else +hwprobe_EXT_ZVFBFWMA = 0 -- TODO: Should we embed the value? +#endif + +hwprobe_EXT_ZICBOM :: Word64 +#ifdef RISCV_HWPROBE_EXT_ZICBOM +hwprobe_EXT_ZICBOM = #{const RISCV_HWPROBE_EXT_ZICBOM} +#else +hwprobe_EXT_ZICBOM = 0 -- TODO: Should we embed the value? +#endif diff --git a/src/System/CPUFeatures/Arm.hs b/src/System/CPUFeatures/Arm.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/Arm.hs @@ -0,0 +1,4 @@ +module System.CPUFeatures.Arm + (module System.CPUFeatures.Arm.Bool + ) where +import System.CPUFeatures.Arm.Bool diff --git a/src/System/CPUFeatures/Arm/Bool.hs b/src/System/CPUFeatures/Arm/Bool.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/Arm/Bool.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{- | +Description: Detect Arm features at runtime + +This module provides the basic interface to detect CPU features. +The availability is indicated by a boolean variable (@b\@). +-} +module System.CPUFeatures.Arm.Bool + (bFEAT_AES + ,bFEAT_AFP + ,bFEAT_BF16 + ,bFEAT_BTI + ,bFEAT_CSV2 + ,bFEAT_CSV3 + ,bFEAT_DIT + ,bFEAT_DotProd + ,bFEAT_DPB + ,bFEAT_DPB2 + ,bFEAT_ECV + ,bFEAT_FCMA + ,bFEAT_FHM + ,bFEAT_FlagM + ,bFEAT_FlagM2 + ,bFEAT_FP16 + ,bFEAT_FPAC + ,bFEAT_FRINTTS + ,bFEAT_I8MM + ,bFEAT_JSCVT + ,bFEAT_LRCPC + ,bFEAT_LRCPC2 + ,bFEAT_LSE + ,bFEAT_LSE2 + ,bFEAT_PAuth + ,bFEAT_PAuth2 + ,bFEAT_PMULL + ,bFEAT_RDM + ,bFEAT_RPRES + ,bFEAT_SB + ,bFEAT_SHA1 + ,bFEAT_SHA256 + ,bFEAT_SHA3 + ,bFEAT_SHA512 + ,bFEAT_SME + ,bFEAT_SME_F64F64 + ,bFEAT_SME_I16I64 + ,bFEAT_SME2 + ,bFEAT_SPECRES + ,bFEAT_SSBS + ,bFEAT_SVE + ,bFEAT_SVE2 + ,bFEAT_WFxT + ) where +#if defined(aarch64_HOST_ARCH) && defined(darwin_HOST_OS) +import GHC.Exts (Addr#) +#endif +#if defined(aarch64_HOST_ARCH) && defined(linux_HOST_OS) +import Hwcap +import Data.Bits +#endif + +bFEAT_AES :: Bool +bFEAT_AFP :: Bool +bFEAT_BF16 :: Bool +bFEAT_BTI :: Bool +bFEAT_CSV2 :: Bool +bFEAT_CSV3 :: Bool +bFEAT_DIT :: Bool +bFEAT_DotProd :: Bool +bFEAT_DPB :: Bool +bFEAT_DPB2 :: Bool +bFEAT_ECV :: Bool +bFEAT_FCMA :: Bool +bFEAT_FHM :: Bool +bFEAT_FlagM :: Bool +bFEAT_FlagM2 :: Bool +bFEAT_FP16 :: Bool +bFEAT_FPAC :: Bool +bFEAT_FRINTTS :: Bool +bFEAT_I8MM :: Bool +bFEAT_JSCVT :: Bool +bFEAT_LRCPC :: Bool +bFEAT_LRCPC2 :: Bool +bFEAT_LSE :: Bool +bFEAT_LSE2 :: Bool +bFEAT_PAuth :: Bool +bFEAT_PAuth2 :: Bool +bFEAT_PMULL :: Bool +bFEAT_RDM :: Bool +bFEAT_RPRES :: Bool +bFEAT_SB :: Bool +bFEAT_SHA1 :: Bool +bFEAT_SHA256 :: Bool +bFEAT_SHA3 :: Bool +bFEAT_SHA512 :: Bool +bFEAT_SME :: Bool +bFEAT_SME_F64F64 :: Bool +bFEAT_SME_I16I64 :: Bool +bFEAT_SME2 :: Bool +bFEAT_SPECRES :: Bool +bFEAT_SSBS :: Bool +bFEAT_SVE :: Bool +bFEAT_SVE2 :: Bool +bFEAT_WFxT :: Bool + +#if defined(aarch64_HOST_ARCH) && (defined(darwin_HOST_OS) || defined(linux_HOST_OS)) + +#if defined(darwin_HOST_OS) + +foreign import ccall unsafe hs_cpu_features_sysctl :: Addr# -> Bool + +{-# NOINLINE bFEAT_AES #-} +bFEAT_AES = hs_cpu_features_sysctl "hw.optional.arm.FEAT_AES"# + +{-# NOINLINE bFEAT_AFP #-} +bFEAT_AFP = hs_cpu_features_sysctl "hw.optional.arm.FEAT_AFP"# + +{-# NOINLINE bFEAT_BF16 #-} +bFEAT_BF16 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_BF16"# + +{-# NOINLINE bFEAT_BTI #-} +bFEAT_BTI = hs_cpu_features_sysctl "hw.optional.arm.FEAT_BTI"# + +{-# NOINLINE bFEAT_CSV2 #-} +bFEAT_CSV2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_CSV2"# + +{-# NOINLINE bFEAT_CSV3 #-} +bFEAT_CSV3 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_CSV3"# + +{-# NOINLINE bFEAT_DIT #-} +bFEAT_DIT = hs_cpu_features_sysctl "hw.optional.arm.FEAT_DIT"# + +{-# NOINLINE bFEAT_DotProd #-} +bFEAT_DotProd = hs_cpu_features_sysctl "hw.optional.arm.FEAT_DotProd"# + +{-# NOINLINE bFEAT_DPB #-} +bFEAT_DPB = hs_cpu_features_sysctl "hw.optional.arm.FEAT_DPB"# + +{-# NOINLINE bFEAT_DPB2 #-} +bFEAT_DPB2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_DPB2"# + +{-# NOINLINE bFEAT_ECV #-} +bFEAT_ECV = hs_cpu_features_sysctl "hw.optional.arm.FEAT_ECV"# + +{-# NOINLINE bFEAT_FCMA #-} +bFEAT_FCMA = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FCMA"# + +{-# NOINLINE bFEAT_FHM #-} +bFEAT_FHM = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FHM"# + +{-# NOINLINE bFEAT_FlagM #-} +bFEAT_FlagM = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FlagM"# + +{-# NOINLINE bFEAT_FlagM2 #-} +bFEAT_FlagM2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FlagM2"# + +{-# NOINLINE bFEAT_FP16 #-} +bFEAT_FP16 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FP16"# + +{-# NOINLINE bFEAT_FPAC #-} +bFEAT_FPAC = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FPAC"# + +{-# NOINLINE bFEAT_FRINTTS #-} +bFEAT_FRINTTS = hs_cpu_features_sysctl "hw.optional.arm.FEAT_FRINTTS"# + +{-# NOINLINE bFEAT_I8MM #-} +bFEAT_I8MM = hs_cpu_features_sysctl "hw.optional.arm.FEAT_I8MM"# + +{-# NOINLINE bFEAT_JSCVT #-} +bFEAT_JSCVT = hs_cpu_features_sysctl "hw.optional.arm.FEAT_JSCVT"# + +{-# NOINLINE bFEAT_LRCPC #-} +bFEAT_LRCPC = hs_cpu_features_sysctl "hw.optional.arm.FEAT_LRCPC"# + +{-# NOINLINE bFEAT_LRCPC2 #-} +bFEAT_LRCPC2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_LRCPC2"# + +{-# NOINLINE bFEAT_LSE #-} +bFEAT_LSE = hs_cpu_features_sysctl "hw.optional.arm.FEAT_LSE"# + +{-# NOINLINE bFEAT_LSE2 #-} +bFEAT_LSE2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_LSE2"# + +{-# NOINLINE bFEAT_PAuth #-} +bFEAT_PAuth = hs_cpu_features_sysctl "hw.optional.arm.FEAT_PAuth"# + +{-# NOINLINE bFEAT_PAuth2 #-} +bFEAT_PAuth2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_PAuth2"# + +{-# NOINLINE bFEAT_PMULL #-} +bFEAT_PMULL = hs_cpu_features_sysctl "hw.optional.arm.FEAT_PMULL"# + +{-# NOINLINE bFEAT_RDM #-} +bFEAT_RDM = hs_cpu_features_sysctl "hw.optional.arm.FEAT_RDM"# + +{-# NOINLINE bFEAT_RPRES #-} +bFEAT_RPRES = hs_cpu_features_sysctl "hw.optional.arm.FEAT_RPRES"# + +{-# NOINLINE bFEAT_SB #-} +bFEAT_SB = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SB"# + +{-# NOINLINE bFEAT_SHA1 #-} +bFEAT_SHA1 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SHA1"# + +{-# NOINLINE bFEAT_SHA256 #-} +bFEAT_SHA256 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SHA256"# + +{-# NOINLINE bFEAT_SHA3 #-} +bFEAT_SHA3 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SHA3"# + +{-# NOINLINE bFEAT_SHA512 #-} +bFEAT_SHA512 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SHA512"# + +{-# NOINLINE bFEAT_SME #-} +bFEAT_SME = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SME"# + +{-# NOINLINE bFEAT_SME_F64F64 #-} +bFEAT_SME_F64F64 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SME_F64F64"# + +{-# NOINLINE bFEAT_SME_I16I64 #-} +bFEAT_SME_I16I64 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SME_I16I64"# + +{-# NOINLINE bFEAT_SME2 #-} +bFEAT_SME2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SME2"# + +{-# NOINLINE bFEAT_SPECRES #-} +bFEAT_SPECRES = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SPECRES"# + +{-# NOINLINE bFEAT_SSBS #-} +bFEAT_SSBS = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SSBS"# + +{-# NOINLINE bFEAT_SVE #-} +bFEAT_SVE = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SVE"# + +{-# NOINLINE bFEAT_SVE2 #-} +bFEAT_SVE2 = hs_cpu_features_sysctl "hw.optional.arm.FEAT_SVE2"# + +{-# NOINLINE bFEAT_WFxT #-} +bFEAT_WFxT = hs_cpu_features_sysctl "hw.optional.arm.FEAT_WFxT"# + +#elif defined(linux_HOST_OS) + +bFEAT_AES = hwcap .&. hwcap_AES /= 0 +bFEAT_AFP = hwcap2 .&. hwcap2_AFP /= 0 +bFEAT_BF16 = hwcap2 .&. hwcap2_BF16 /= 0 +bFEAT_BTI = hwcap2 .&. hwcap2_BTI /= 0 +bFEAT_CSV2 = False +bFEAT_CSV3 = False +bFEAT_DIT = hwcap .&. hwcap_DIT /= 0 +bFEAT_DotProd = hwcap .&. hwcap_ASIMDDP /= 0 +bFEAT_DPB = hwcap .&. hwcap_DCPOP /= 0 +bFEAT_DPB2 = hwcap2 .&. hwcap2_DCPODP /= 0 +bFEAT_ECV = False +bFEAT_FCMA = hwcap .&. hwcap_FCMA /= 0 +bFEAT_FHM = hwcap .&. hwcap_ASIMDFHM /= 0 +bFEAT_FlagM = hwcap .&. hwcap_FLAGM /= 0 +bFEAT_FlagM2 = hwcap2 .&. hwcap2_FLAGM2 /= 0 +bFEAT_FP16 = hwcap .&. hwcap_FPHP /= 0 -- hwcap_ASIMDHP? +bFEAT_FPAC = False +bFEAT_FRINTTS = hwcap2 .&. hwcap2_FRINT /= 0 +bFEAT_I8MM = hwcap2 .&. hwcap2_I8MM /= 0 +bFEAT_JSCVT = hwcap .&. hwcap_JSCVT /= 0 +bFEAT_LRCPC = hwcap .&. hwcap_LRCPC /= 0 +bFEAT_LRCPC2 = hwcap .&. hwcap_ILRCPC /= 0 +bFEAT_LSE = hwcap .&. hwcap_ATOMICS /= 0 +bFEAT_LSE2 = hwcap .&. hwcap_USCAT /= 0 +bFEAT_PAuth = hwcap .&. hwcap_PACA /= 0 +bFEAT_PAuth2 = False +bFEAT_PMULL = hwcap .&. hwcap_PMULL /= 0 +bFEAT_RDM = hwcap .&. hwcap_ASIMDRDM /= 0 +bFEAT_RPRES = hwcap2 .&. hwcap2_RPRES /= 0 +bFEAT_SB = hwcap .&. hwcap_SB /= 0 +bFEAT_SHA1 = hwcap .&. hwcap_SHA1 /= 0 +bFEAT_SHA256 = hwcap .&. hwcap_SHA2 /= 0 +bFEAT_SHA3 = hwcap .&. hwcap_SHA3 /= 0 +bFEAT_SHA512 = hwcap .&. hwcap_SHA512 /= 0 +bFEAT_SME = hwcap2 .&. hwcap2_SME /= 0 +bFEAT_SME_F64F64 = hwcap2 .&. hwcap2_SME_F64F64 /= 0 +bFEAT_SME_I16I64 = hwcap2 .&. hwcap2_SME_I16I64 /= 0 +bFEAT_SME2 = hwcap2 .&. hwcap2_SME2 /= 0 +bFEAT_SPECRES = False +bFEAT_SSBS = hwcap .&. hwcap_SSBS /= 0 -- FEAT_SSB2? +bFEAT_SVE = hwcap .&. hwcap_SVE /= 0 +bFEAT_SVE2 = hwcap2 .&. hwcap2_SVE2 /= 0 +bFEAT_WFxT = hwcap2 .&. hwcap2_WFXT /= 0 + +#else +#error bug +#endif + +#else + +{-# INLINE bFEAT_AES #-} +bFEAT_AES = False + +{-# INLINE bFEAT_AFP #-} +bFEAT_AFP = False + +{-# INLINE bFEAT_BF16 #-} +bFEAT_BF16 = False + +{-# INLINE bFEAT_BTI #-} +bFEAT_BTI = False + +{-# INLINE bFEAT_CSV2 #-} +bFEAT_CSV2 = False + +{-# INLINE bFEAT_CSV3 #-} +bFEAT_CSV3 = False + +{-# INLINE bFEAT_DIT #-} +bFEAT_DIT = False + +{-# INLINE bFEAT_DotProd #-} +bFEAT_DotProd = False + +{-# INLINE bFEAT_DPB #-} +bFEAT_DPB = False + +{-# INLINE bFEAT_DPB2 #-} +bFEAT_DPB2 = False + +{-# INLINE bFEAT_ECV #-} +bFEAT_ECV = False + +{-# INLINE bFEAT_FCMA #-} +bFEAT_FCMA = False + +{-# INLINE bFEAT_FHM #-} +bFEAT_FHM = False + +{-# INLINE bFEAT_FlagM #-} +bFEAT_FlagM = False + +{-# INLINE bFEAT_FlagM2 #-} +bFEAT_FlagM2 = False + +{-# INLINE bFEAT_FP16 #-} +bFEAT_FP16 = False + +{-# INLINE bFEAT_FPAC #-} +bFEAT_FPAC = False + +{-# INLINE bFEAT_FRINTTS #-} +bFEAT_FRINTTS = False + +{-# INLINE bFEAT_I8MM #-} +bFEAT_I8MM = False + +{-# INLINE bFEAT_JSCVT #-} +bFEAT_JSCVT = False + +{-# INLINE bFEAT_LRCPC #-} +bFEAT_LRCPC = False + +{-# INLINE bFEAT_LRCPC2 #-} +bFEAT_LRCPC2 = False + +{-# INLINE bFEAT_LSE #-} +bFEAT_LSE = False + +{-# INLINE bFEAT_LSE2 #-} +bFEAT_LSE2 = False + +{-# INLINE bFEAT_PAuth #-} +bFEAT_PAuth = False + +{-# INLINE bFEAT_PAuth2 #-} +bFEAT_PAuth2 = False + +{-# INLINE bFEAT_PMULL #-} +bFEAT_PMULL = False + +{-# INLINE bFEAT_RDM #-} +bFEAT_RDM = False + +{-# INLINE bFEAT_RPRES #-} +bFEAT_RPRES = False + +{-# INLINE bFEAT_SB #-} +bFEAT_SB = False + +{-# INLINE bFEAT_SHA1 #-} +bFEAT_SHA1 = False + +{-# INLINE bFEAT_SHA256 #-} +bFEAT_SHA256 = False + +{-# INLINE bFEAT_SHA3 #-} +bFEAT_SHA3 = False + +{-# INLINE bFEAT_SHA512 #-} +bFEAT_SHA512 = False + +{-# INLINE bFEAT_SME #-} +bFEAT_SME = False + +{-# INLINE bFEAT_SME_F64F64 #-} +bFEAT_SME_F64F64 = False + +{-# INLINE bFEAT_SME_I16I64 #-} +bFEAT_SME_I16I64 = False + +{-# INLINE bFEAT_SME2 #-} +bFEAT_SME2 = False + +{-# INLINE bFEAT_SPECRES #-} +bFEAT_SPECRES = False + +{-# INLINE bFEAT_SSBS #-} +bFEAT_SSBS = False + +{-# INLINE bFEAT_SVE #-} +bFEAT_SVE = False + +{-# INLINE bFEAT_SVE2 #-} +bFEAT_SVE2 = False + +{-# INLINE bFEAT_WFxT #-} +bFEAT_WFxT = False + +#endif diff --git a/src/System/CPUFeatures/Arm/Constraint.hs b/src/System/CPUFeatures/Arm/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/Arm/Constraint.hs @@ -0,0 +1,65 @@ +{- | +Description: Arm features as nullary constraints + +This module provides the constraint interface to detect CPU features. +You can mark your function with @Has\ =>@ to indicate that +it requires a specific CPU feature. +You can detect the availability and get the constraint @Has\@ +by pattern-matching on the variable @query\@. + +Example: + +> -- This function requires FEAT_PMULL +> someFunction :: HasFEAT_PMULL => ... +> +> case queryFEAT_PMULL of +> Just Dict -> {- In this branch, HasFEAT_PMULL is available -} someFunction +> Nothing -> {- In this branch, HasFEAT_PMULL is not available -} error "FEAT_PMULL not available" +-} +module System.CPUFeatures.Arm.Constraint + (HasFEAT_AES, queryFEAT_AES + ,HasFEAT_AFP, queryFEAT_AFP + ,HasFEAT_BF16, queryFEAT_BF16 + ,HasFEAT_BTI, queryFEAT_BTI + ,HasFEAT_CSV2, queryFEAT_CSV2 + ,HasFEAT_CSV3, queryFEAT_CSV3 + ,HasFEAT_DIT, queryFEAT_DIT + ,HasFEAT_DotProd, queryFEAT_DotProd + ,HasFEAT_DPB, queryFEAT_DPB + ,HasFEAT_DPB2, queryFEAT_DPB2 + ,HasFEAT_ECV, queryFEAT_ECV + ,HasFEAT_FCMA, queryFEAT_FCMA + ,HasFEAT_FHM, queryFEAT_FHM + ,HasFEAT_FlagM, queryFEAT_FlagM + ,HasFEAT_FlagM2, queryFEAT_FlagM2 + ,HasFEAT_FP16, queryFEAT_FP16 + ,HasFEAT_FPAC, queryFEAT_FPAC + ,HasFEAT_FRINTTS, queryFEAT_FRINTTS + ,HasFEAT_I8MM, queryFEAT_I8MM + ,HasFEAT_JSCVT, queryFEAT_JSCVT + ,HasFEAT_LRCPC, queryFEAT_LRCPC + ,HasFEAT_LRCPC2, queryFEAT_LRCPC2 + ,HasFEAT_LSE, queryFEAT_LSE + ,HasFEAT_LSE2, queryFEAT_LSE2 + ,HasFEAT_PAuth, queryFEAT_PAuth + ,HasFEAT_PAuth2, queryFEAT_PAuth2 + ,HasFEAT_PMULL, queryFEAT_PMULL + ,HasFEAT_RDM, queryFEAT_RDM + ,HasFEAT_RPRES, queryFEAT_RPRES + ,HasFEAT_SB, queryFEAT_SB + ,HasFEAT_SHA1, queryFEAT_SHA1 + ,HasFEAT_SHA256, queryFEAT_SHA256 + ,HasFEAT_SHA3, queryFEAT_SHA3 + ,HasFEAT_SHA512, queryFEAT_SHA512 + ,HasFEAT_SME, queryFEAT_SME + ,HasFEAT_SME_F64F64, queryFEAT_SME_F64F64 + ,HasFEAT_SME_I16I64, queryFEAT_SME_I16I64 + ,HasFEAT_SME2, queryFEAT_SME2 + ,HasFEAT_SPECRES, queryFEAT_SPECRES + ,HasFEAT_SSBS, queryFEAT_SSBS + ,HasFEAT_SVE, queryFEAT_SVE + ,HasFEAT_SVE2, queryFEAT_SVE2 + ,HasFEAT_WFxT, queryFEAT_WFxT + ,Dict(Dict) + ) where +import System.CPUFeatures.Arm.Constraint.Unsafe diff --git a/src/System/CPUFeatures/Arm/Constraint/Unsafe.hs b/src/System/CPUFeatures/Arm/Constraint/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/Arm/Constraint/Unsafe.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module System.CPUFeatures.Arm.Constraint.Unsafe + ( module System.CPUFeatures.Arm.Constraint.Unsafe + , Dict (Dict) + ) where +import Data.Type.Equality ((:~:)(Refl)) +import System.CPUFeatures.Util +import System.CPUFeatures.Arm.TypeBool +import Unsafe.Coerce (unsafeCoerce) + +class FEAT_AES ~ True => HasFEAT_AES +instance FEAT_AES ~ True => HasFEAT_AES + +class FEAT_AFP ~ True => HasFEAT_AFP +instance FEAT_AFP ~ True => HasFEAT_AFP + +class FEAT_BF16 ~ True => HasFEAT_BF16 +instance FEAT_BF16 ~ True => HasFEAT_BF16 + +class FEAT_BTI ~ True => HasFEAT_BTI +instance FEAT_BTI ~ True => HasFEAT_BTI + +class FEAT_CSV2 ~ True => HasFEAT_CSV2 +instance FEAT_CSV2 ~ True => HasFEAT_CSV2 + +class FEAT_CSV3 ~ True => HasFEAT_CSV3 +instance FEAT_CSV3 ~ True => HasFEAT_CSV3 + +class FEAT_DIT ~ True => HasFEAT_DIT +instance FEAT_DIT ~ True => HasFEAT_DIT + +class FEAT_DotProd ~ True => HasFEAT_DotProd +instance FEAT_DotProd ~ True => HasFEAT_DotProd + +class FEAT_DPB ~ True => HasFEAT_DPB +instance FEAT_DPB ~ True => HasFEAT_DPB + +class FEAT_DPB2 ~ True => HasFEAT_DPB2 +instance FEAT_DPB2 ~ True => HasFEAT_DPB2 + +class FEAT_ECV ~ True => HasFEAT_ECV +instance FEAT_ECV ~ True => HasFEAT_ECV + +class FEAT_FCMA ~ True => HasFEAT_FCMA +instance FEAT_FCMA ~ True => HasFEAT_FCMA + +class FEAT_FHM ~ True => HasFEAT_FHM +instance FEAT_FHM ~ True => HasFEAT_FHM + +class FEAT_FlagM ~ True => HasFEAT_FlagM +instance FEAT_FlagM ~ True => HasFEAT_FlagM + +class FEAT_FlagM2 ~ True => HasFEAT_FlagM2 +instance FEAT_FlagM2 ~ True => HasFEAT_FlagM2 + +class FEAT_FP16 ~ True => HasFEAT_FP16 +instance FEAT_FP16 ~ True => HasFEAT_FP16 + +class FEAT_FPAC ~ True => HasFEAT_FPAC +instance FEAT_FPAC ~ True => HasFEAT_FPAC + +class FEAT_FRINTTS ~ True => HasFEAT_FRINTTS +instance FEAT_FRINTTS ~ True => HasFEAT_FRINTTS + +class FEAT_I8MM ~ True => HasFEAT_I8MM +instance FEAT_I8MM ~ True => HasFEAT_I8MM + +class FEAT_JSCVT ~ True => HasFEAT_JSCVT +instance FEAT_JSCVT ~ True => HasFEAT_JSCVT + +class FEAT_LRCPC ~ True => HasFEAT_LRCPC +instance FEAT_LRCPC ~ True => HasFEAT_LRCPC + +class FEAT_LRCPC2 ~ True => HasFEAT_LRCPC2 +instance FEAT_LRCPC2 ~ True => HasFEAT_LRCPC2 + +class FEAT_LSE ~ True => HasFEAT_LSE +instance FEAT_LSE ~ True => HasFEAT_LSE + +class FEAT_LSE2 ~ True => HasFEAT_LSE2 +instance FEAT_LSE2 ~ True => HasFEAT_LSE2 + +class FEAT_PAuth ~ True => HasFEAT_PAuth +instance FEAT_PAuth ~ True => HasFEAT_PAuth + +class FEAT_PAuth2 ~ True => HasFEAT_PAuth2 +instance FEAT_PAuth2 ~ True => HasFEAT_PAuth2 + +class FEAT_PMULL ~ True => HasFEAT_PMULL +instance FEAT_PMULL ~ True => HasFEAT_PMULL + +class FEAT_RDM ~ True => HasFEAT_RDM +instance FEAT_RDM ~ True => HasFEAT_RDM + +class FEAT_RPRES ~ True => HasFEAT_RPRES +instance FEAT_RPRES ~ True => HasFEAT_RPRES + +class FEAT_SB ~ True => HasFEAT_SB +instance FEAT_SB ~ True => HasFEAT_SB + +class FEAT_SHA1 ~ True => HasFEAT_SHA1 +instance FEAT_SHA1 ~ True => HasFEAT_SHA1 + +class FEAT_SHA256 ~ True => HasFEAT_SHA256 +instance FEAT_SHA256 ~ True => HasFEAT_SHA256 + +class FEAT_SHA3 ~ True => HasFEAT_SHA3 +instance FEAT_SHA3 ~ True => HasFEAT_SHA3 + +class FEAT_SHA512 ~ True => HasFEAT_SHA512 +instance FEAT_SHA512 ~ True => HasFEAT_SHA512 + +class FEAT_SME ~ True => HasFEAT_SME +instance FEAT_SME ~ True => HasFEAT_SME + +class FEAT_SME_F64F64 ~ True => HasFEAT_SME_F64F64 +instance FEAT_SME_F64F64 ~ True => HasFEAT_SME_F64F64 + +class FEAT_SME_I16I64 ~ True => HasFEAT_SME_I16I64 +instance FEAT_SME_I16I64 ~ True => HasFEAT_SME_I16I64 + +class FEAT_SME2 ~ True => HasFEAT_SME2 +instance FEAT_SME2 ~ True => HasFEAT_SME2 + +class FEAT_SPECRES ~ True => HasFEAT_SPECRES +instance FEAT_SPECRES ~ True => HasFEAT_SPECRES + +class FEAT_SSBS ~ True => HasFEAT_SSBS +instance FEAT_SSBS ~ True => HasFEAT_SSBS + +class FEAT_SVE ~ True => HasFEAT_SVE +instance FEAT_SVE ~ True => HasFEAT_SVE + +class FEAT_SVE2 ~ True => HasFEAT_SVE2 +instance FEAT_SVE2 ~ True => HasFEAT_SVE2 + +class FEAT_WFxT ~ True => HasFEAT_WFxT +instance FEAT_WFxT ~ True => HasFEAT_WFxT + +unsafeAssumeFEAT_AES :: (HasFEAT_AES => a) -> a +unsafeAssumeFEAT_AES k = case unsafeCoerce Refl :: FEAT_AES :~: True of Refl -> k + +queryFEAT_AES :: Maybe (Dict HasFEAT_AES) +queryFEAT_AES = case sFEAT_AES of STrue -> unsafeAssumeFEAT_AES (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_AES #-} + +unsafeAssumeFEAT_AFP :: (HasFEAT_AFP => a) -> a +unsafeAssumeFEAT_AFP k = case unsafeCoerce Refl :: FEAT_AFP :~: True of Refl -> k + +queryFEAT_AFP :: Maybe (Dict HasFEAT_AFP) +queryFEAT_AFP = case sFEAT_AFP of STrue -> unsafeAssumeFEAT_AFP (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_AFP #-} + +unsafeAssumeFEAT_BF16 :: (HasFEAT_BF16 => a) -> a +unsafeAssumeFEAT_BF16 k = case unsafeCoerce Refl :: FEAT_BF16 :~: True of Refl -> k + +queryFEAT_BF16 :: Maybe (Dict HasFEAT_BF16) +queryFEAT_BF16 = case sFEAT_BF16 of STrue -> unsafeAssumeFEAT_BF16 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_BF16 #-} + +unsafeAssumeFEAT_BTI :: (HasFEAT_BTI => a) -> a +unsafeAssumeFEAT_BTI k = case unsafeCoerce Refl :: FEAT_BTI :~: True of Refl -> k + +queryFEAT_BTI :: Maybe (Dict HasFEAT_BTI) +queryFEAT_BTI = case sFEAT_BTI of STrue -> unsafeAssumeFEAT_BTI (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_BTI #-} + +unsafeAssumeFEAT_CSV2 :: (HasFEAT_CSV2 => a) -> a +unsafeAssumeFEAT_CSV2 k = case unsafeCoerce Refl :: FEAT_CSV2 :~: True of Refl -> k + +queryFEAT_CSV2 :: Maybe (Dict HasFEAT_CSV2) +queryFEAT_CSV2 = case sFEAT_CSV2 of STrue -> unsafeAssumeFEAT_CSV2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_CSV2 #-} + +unsafeAssumeFEAT_CSV3 :: (HasFEAT_CSV3 => a) -> a +unsafeAssumeFEAT_CSV3 k = case unsafeCoerce Refl :: FEAT_CSV3 :~: True of Refl -> k + +queryFEAT_CSV3 :: Maybe (Dict HasFEAT_CSV3) +queryFEAT_CSV3 = case sFEAT_CSV3 of STrue -> unsafeAssumeFEAT_CSV3 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_CSV3 #-} + +unsafeAssumeFEAT_DIT :: (HasFEAT_DIT => a) -> a +unsafeAssumeFEAT_DIT k = case unsafeCoerce Refl :: FEAT_DIT :~: True of Refl -> k + +queryFEAT_DIT :: Maybe (Dict HasFEAT_DIT) +queryFEAT_DIT = case sFEAT_DIT of STrue -> unsafeAssumeFEAT_DIT (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_DIT #-} + +unsafeAssumeFEAT_DotProd :: (HasFEAT_DotProd => a) -> a +unsafeAssumeFEAT_DotProd k = case unsafeCoerce Refl :: FEAT_DotProd :~: True of Refl -> k + +queryFEAT_DotProd :: Maybe (Dict HasFEAT_DotProd) +queryFEAT_DotProd = case sFEAT_DotProd of STrue -> unsafeAssumeFEAT_DotProd (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_DotProd #-} + +unsafeAssumeFEAT_DPB :: (HasFEAT_DPB => a) -> a +unsafeAssumeFEAT_DPB k = case unsafeCoerce Refl :: FEAT_DPB :~: True of Refl -> k + +queryFEAT_DPB :: Maybe (Dict HasFEAT_DPB) +queryFEAT_DPB = case sFEAT_DPB of STrue -> unsafeAssumeFEAT_DPB (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_DPB #-} + +unsafeAssumeFEAT_DPB2 :: (HasFEAT_DPB2 => a) -> a +unsafeAssumeFEAT_DPB2 k = case unsafeCoerce Refl :: FEAT_DPB2 :~: True of Refl -> k + +queryFEAT_DPB2 :: Maybe (Dict HasFEAT_DPB2) +queryFEAT_DPB2 = case sFEAT_DPB2 of STrue -> unsafeAssumeFEAT_DPB2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_DPB2 #-} + +unsafeAssumeFEAT_ECV :: (HasFEAT_ECV => a) -> a +unsafeAssumeFEAT_ECV k = case unsafeCoerce Refl :: FEAT_ECV :~: True of Refl -> k + +queryFEAT_ECV :: Maybe (Dict HasFEAT_ECV) +queryFEAT_ECV = case sFEAT_ECV of STrue -> unsafeAssumeFEAT_ECV (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_ECV #-} + +unsafeAssumeFEAT_FCMA :: (HasFEAT_FCMA => a) -> a +unsafeAssumeFEAT_FCMA k = case unsafeCoerce Refl :: FEAT_FCMA :~: True of Refl -> k + +queryFEAT_FCMA :: Maybe (Dict HasFEAT_FCMA) +queryFEAT_FCMA = case sFEAT_FCMA of STrue -> unsafeAssumeFEAT_FCMA (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FCMA #-} + +unsafeAssumeFEAT_FHM :: (HasFEAT_FHM => a) -> a +unsafeAssumeFEAT_FHM k = case unsafeCoerce Refl :: FEAT_FHM :~: True of Refl -> k + +queryFEAT_FHM :: Maybe (Dict HasFEAT_FHM) +queryFEAT_FHM = case sFEAT_FHM of STrue -> unsafeAssumeFEAT_FHM (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FHM #-} + +unsafeAssumeFEAT_FlagM :: (HasFEAT_FlagM => a) -> a +unsafeAssumeFEAT_FlagM k = case unsafeCoerce Refl :: FEAT_FlagM :~: True of Refl -> k + +queryFEAT_FlagM :: Maybe (Dict HasFEAT_FlagM) +queryFEAT_FlagM = case sFEAT_FlagM of STrue -> unsafeAssumeFEAT_FlagM (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FlagM #-} + +unsafeAssumeFEAT_FlagM2 :: (HasFEAT_FlagM2 => a) -> a +unsafeAssumeFEAT_FlagM2 k = case unsafeCoerce Refl :: FEAT_FlagM2 :~: True of Refl -> k + +queryFEAT_FlagM2 :: Maybe (Dict HasFEAT_FlagM2) +queryFEAT_FlagM2 = case sFEAT_FlagM2 of STrue -> unsafeAssumeFEAT_FlagM2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FlagM2 #-} + +unsafeAssumeFEAT_FP16 :: (HasFEAT_FP16 => a) -> a +unsafeAssumeFEAT_FP16 k = case unsafeCoerce Refl :: FEAT_FP16 :~: True of Refl -> k + +queryFEAT_FP16 :: Maybe (Dict HasFEAT_FP16) +queryFEAT_FP16 = case sFEAT_FP16 of STrue -> unsafeAssumeFEAT_FP16 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FP16 #-} + +unsafeAssumeFEAT_FPAC :: (HasFEAT_FPAC => a) -> a +unsafeAssumeFEAT_FPAC k = case unsafeCoerce Refl :: FEAT_FPAC :~: True of Refl -> k + +queryFEAT_FPAC :: Maybe (Dict HasFEAT_FPAC) +queryFEAT_FPAC = case sFEAT_FPAC of STrue -> unsafeAssumeFEAT_FPAC (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FPAC #-} + +unsafeAssumeFEAT_FRINTTS :: (HasFEAT_FRINTTS => a) -> a +unsafeAssumeFEAT_FRINTTS k = case unsafeCoerce Refl :: FEAT_FRINTTS :~: True of Refl -> k + +queryFEAT_FRINTTS :: Maybe (Dict HasFEAT_FRINTTS) +queryFEAT_FRINTTS = case sFEAT_FRINTTS of STrue -> unsafeAssumeFEAT_FRINTTS (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_FRINTTS #-} + +unsafeAssumeFEAT_I8MM :: (HasFEAT_I8MM => a) -> a +unsafeAssumeFEAT_I8MM k = case unsafeCoerce Refl :: FEAT_I8MM :~: True of Refl -> k + +queryFEAT_I8MM :: Maybe (Dict HasFEAT_I8MM) +queryFEAT_I8MM = case sFEAT_I8MM of STrue -> unsafeAssumeFEAT_I8MM (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_I8MM #-} + +unsafeAssumeFEAT_JSCVT :: (HasFEAT_JSCVT => a) -> a +unsafeAssumeFEAT_JSCVT k = case unsafeCoerce Refl :: FEAT_JSCVT :~: True of Refl -> k + +queryFEAT_JSCVT :: Maybe (Dict HasFEAT_JSCVT) +queryFEAT_JSCVT = case sFEAT_JSCVT of STrue -> unsafeAssumeFEAT_JSCVT (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_JSCVT #-} + +unsafeAssumeFEAT_LRCPC :: (HasFEAT_LRCPC => a) -> a +unsafeAssumeFEAT_LRCPC k = case unsafeCoerce Refl :: FEAT_LRCPC :~: True of Refl -> k + +queryFEAT_LRCPC :: Maybe (Dict HasFEAT_LRCPC) +queryFEAT_LRCPC = case sFEAT_LRCPC of STrue -> unsafeAssumeFEAT_LRCPC (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_LRCPC #-} + +unsafeAssumeFEAT_LRCPC2 :: (HasFEAT_LRCPC2 => a) -> a +unsafeAssumeFEAT_LRCPC2 k = case unsafeCoerce Refl :: FEAT_LRCPC2 :~: True of Refl -> k + +queryFEAT_LRCPC2 :: Maybe (Dict HasFEAT_LRCPC2) +queryFEAT_LRCPC2 = case sFEAT_LRCPC2 of STrue -> unsafeAssumeFEAT_LRCPC2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_LRCPC2 #-} + +unsafeAssumeFEAT_LSE :: (HasFEAT_LSE => a) -> a +unsafeAssumeFEAT_LSE k = case unsafeCoerce Refl :: FEAT_LSE :~: True of Refl -> k + +queryFEAT_LSE :: Maybe (Dict HasFEAT_LSE) +queryFEAT_LSE = case sFEAT_LSE of STrue -> unsafeAssumeFEAT_LSE (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_LSE #-} + +unsafeAssumeFEAT_LSE2 :: (HasFEAT_LSE2 => a) -> a +unsafeAssumeFEAT_LSE2 k = case unsafeCoerce Refl :: FEAT_LSE2 :~: True of Refl -> k + +queryFEAT_LSE2 :: Maybe (Dict HasFEAT_LSE2) +queryFEAT_LSE2 = case sFEAT_LSE2 of STrue -> unsafeAssumeFEAT_LSE2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_LSE2 #-} + +unsafeAssumeFEAT_PAuth :: (HasFEAT_PAuth => a) -> a +unsafeAssumeFEAT_PAuth k = case unsafeCoerce Refl :: FEAT_PAuth :~: True of Refl -> k + +queryFEAT_PAuth :: Maybe (Dict HasFEAT_PAuth) +queryFEAT_PAuth = case sFEAT_PAuth of STrue -> unsafeAssumeFEAT_PAuth (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_PAuth #-} + +unsafeAssumeFEAT_PAuth2 :: (HasFEAT_PAuth2 => a) -> a +unsafeAssumeFEAT_PAuth2 k = case unsafeCoerce Refl :: FEAT_PAuth2 :~: True of Refl -> k + +queryFEAT_PAuth2 :: Maybe (Dict HasFEAT_PAuth2) +queryFEAT_PAuth2 = case sFEAT_PAuth2 of STrue -> unsafeAssumeFEAT_PAuth2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_PAuth2 #-} + +unsafeAssumeFEAT_PMULL :: (HasFEAT_PMULL => a) -> a +unsafeAssumeFEAT_PMULL k = case unsafeCoerce Refl :: FEAT_PMULL :~: True of Refl -> k + +queryFEAT_PMULL :: Maybe (Dict HasFEAT_PMULL) +queryFEAT_PMULL = case sFEAT_PMULL of STrue -> unsafeAssumeFEAT_PMULL (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_PMULL #-} + +unsafeAssumeFEAT_RDM :: (HasFEAT_RDM => a) -> a +unsafeAssumeFEAT_RDM k = case unsafeCoerce Refl :: FEAT_RDM :~: True of Refl -> k + +queryFEAT_RDM :: Maybe (Dict HasFEAT_RDM) +queryFEAT_RDM = case sFEAT_RDM of STrue -> unsafeAssumeFEAT_RDM (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_RDM #-} + +unsafeAssumeFEAT_RPRES :: (HasFEAT_RPRES => a) -> a +unsafeAssumeFEAT_RPRES k = case unsafeCoerce Refl :: FEAT_RPRES :~: True of Refl -> k + +queryFEAT_RPRES :: Maybe (Dict HasFEAT_RPRES) +queryFEAT_RPRES = case sFEAT_RPRES of STrue -> unsafeAssumeFEAT_RPRES (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_RPRES #-} + +unsafeAssumeFEAT_SB :: (HasFEAT_SB => a) -> a +unsafeAssumeFEAT_SB k = case unsafeCoerce Refl :: FEAT_SB :~: True of Refl -> k + +queryFEAT_SB :: Maybe (Dict HasFEAT_SB) +queryFEAT_SB = case sFEAT_SB of STrue -> unsafeAssumeFEAT_SB (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SB #-} + +unsafeAssumeFEAT_SHA1 :: (HasFEAT_SHA1 => a) -> a +unsafeAssumeFEAT_SHA1 k = case unsafeCoerce Refl :: FEAT_SHA1 :~: True of Refl -> k + +queryFEAT_SHA1 :: Maybe (Dict HasFEAT_SHA1) +queryFEAT_SHA1 = case sFEAT_SHA1 of STrue -> unsafeAssumeFEAT_SHA1 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SHA1 #-} + +unsafeAssumeFEAT_SHA256 :: (HasFEAT_SHA256 => a) -> a +unsafeAssumeFEAT_SHA256 k = case unsafeCoerce Refl :: FEAT_SHA256 :~: True of Refl -> k + +queryFEAT_SHA256 :: Maybe (Dict HasFEAT_SHA256) +queryFEAT_SHA256 = case sFEAT_SHA256 of STrue -> unsafeAssumeFEAT_SHA256 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SHA256 #-} + +unsafeAssumeFEAT_SHA3 :: (HasFEAT_SHA3 => a) -> a +unsafeAssumeFEAT_SHA3 k = case unsafeCoerce Refl :: FEAT_SHA3 :~: True of Refl -> k + +queryFEAT_SHA3 :: Maybe (Dict HasFEAT_SHA3) +queryFEAT_SHA3 = case sFEAT_SHA3 of STrue -> unsafeAssumeFEAT_SHA3 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SHA3 #-} + +unsafeAssumeFEAT_SHA512 :: (HasFEAT_SHA512 => a) -> a +unsafeAssumeFEAT_SHA512 k = case unsafeCoerce Refl :: FEAT_SHA512 :~: True of Refl -> k + +queryFEAT_SHA512 :: Maybe (Dict HasFEAT_SHA512) +queryFEAT_SHA512 = case sFEAT_SHA512 of STrue -> unsafeAssumeFEAT_SHA512 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SHA512 #-} + +unsafeAssumeFEAT_SME :: (HasFEAT_SME => a) -> a +unsafeAssumeFEAT_SME k = case unsafeCoerce Refl :: FEAT_SME :~: True of Refl -> k + +queryFEAT_SME :: Maybe (Dict HasFEAT_SME) +queryFEAT_SME = case sFEAT_SME of STrue -> unsafeAssumeFEAT_SME (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SME #-} + +unsafeAssumeFEAT_SME_F64F64 :: (HasFEAT_SME_F64F64 => a) -> a +unsafeAssumeFEAT_SME_F64F64 k = case unsafeCoerce Refl :: FEAT_SME_F64F64 :~: True of Refl -> k + +queryFEAT_SME_F64F64 :: Maybe (Dict HasFEAT_SME_F64F64) +queryFEAT_SME_F64F64 = case sFEAT_SME_F64F64 of STrue -> unsafeAssumeFEAT_SME_F64F64 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SME_F64F64 #-} + +unsafeAssumeFEAT_SME_I16I64 :: (HasFEAT_SME_I16I64 => a) -> a +unsafeAssumeFEAT_SME_I16I64 k = case unsafeCoerce Refl :: FEAT_SME_I16I64 :~: True of Refl -> k + +queryFEAT_SME_I16I64 :: Maybe (Dict HasFEAT_SME_I16I64) +queryFEAT_SME_I16I64 = case sFEAT_SME_I16I64 of STrue -> unsafeAssumeFEAT_SME_I16I64 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SME_I16I64 #-} + +unsafeAssumeFEAT_SME2 :: (HasFEAT_SME2 => a) -> a +unsafeAssumeFEAT_SME2 k = case unsafeCoerce Refl :: FEAT_SME2 :~: True of Refl -> k + +queryFEAT_SME2 :: Maybe (Dict HasFEAT_SME2) +queryFEAT_SME2 = case sFEAT_SME2 of STrue -> unsafeAssumeFEAT_SME2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SME2 #-} + +unsafeAssumeFEAT_SPECRES :: (HasFEAT_SPECRES => a) -> a +unsafeAssumeFEAT_SPECRES k = case unsafeCoerce Refl :: FEAT_SPECRES :~: True of Refl -> k + +queryFEAT_SPECRES :: Maybe (Dict HasFEAT_SPECRES) +queryFEAT_SPECRES = case sFEAT_SPECRES of STrue -> unsafeAssumeFEAT_SPECRES (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SPECRES #-} + +unsafeAssumeFEAT_SSBS :: (HasFEAT_SSBS => a) -> a +unsafeAssumeFEAT_SSBS k = case unsafeCoerce Refl :: FEAT_SSBS :~: True of Refl -> k + +queryFEAT_SSBS :: Maybe (Dict HasFEAT_SSBS) +queryFEAT_SSBS = case sFEAT_SSBS of STrue -> unsafeAssumeFEAT_SSBS (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SSBS #-} + +unsafeAssumeFEAT_SVE :: (HasFEAT_SVE => a) -> a +unsafeAssumeFEAT_SVE k = case unsafeCoerce Refl :: FEAT_SVE :~: True of Refl -> k + +queryFEAT_SVE :: Maybe (Dict HasFEAT_SVE) +queryFEAT_SVE = case sFEAT_SVE of STrue -> unsafeAssumeFEAT_SVE (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SVE #-} + +unsafeAssumeFEAT_SVE2 :: (HasFEAT_SVE2 => a) -> a +unsafeAssumeFEAT_SVE2 k = case unsafeCoerce Refl :: FEAT_SVE2 :~: True of Refl -> k + +queryFEAT_SVE2 :: Maybe (Dict HasFEAT_SVE2) +queryFEAT_SVE2 = case sFEAT_SVE2 of STrue -> unsafeAssumeFEAT_SVE2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_SVE2 #-} + +unsafeAssumeFEAT_WFxT :: (HasFEAT_WFxT => a) -> a +unsafeAssumeFEAT_WFxT k = case unsafeCoerce Refl :: FEAT_WFxT :~: True of Refl -> k + +queryFEAT_WFxT :: Maybe (Dict HasFEAT_WFxT) +queryFEAT_WFxT = case sFEAT_WFxT of STrue -> unsafeAssumeFEAT_WFxT (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFEAT_WFxT #-} diff --git a/src/System/CPUFeatures/Arm/TypeBool.hs b/src/System/CPUFeatures/Arm/TypeBool.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/Arm/TypeBool.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{- | +Description: Arm features as type-level booleans + +This module provides the type-level interface to detect CPU features. +You can mark your function with @\ ~ True =>@ to indicate that +it requires a specific CPU feature. +You can detect the availability and get the constraint @\ ~ True@ +by pattern-matching on the variable @s\@. + +Example: + +> -- This function requires FEAT_PMULL +> someFunction :: FEAT_PMULL ~ True => ... +> +> case sFEAT_PMULL of +> STrue -> {- In this branch, FEAT_PMULL is True -} someFunction +> SFalse -> {- In this branch, FEAT_PMULL is False -} error "FEAT_PMULL not available" +-} +module System.CPUFeatures.Arm.TypeBool + (FEAT_AES, sFEAT_AES + ,FEAT_AFP, sFEAT_AFP + ,FEAT_BF16, sFEAT_BF16 + ,FEAT_BTI, sFEAT_BTI + ,FEAT_CSV2, sFEAT_CSV2 + ,FEAT_CSV3, sFEAT_CSV3 + ,FEAT_DIT, sFEAT_DIT + ,FEAT_DotProd, sFEAT_DotProd + ,FEAT_DPB, sFEAT_DPB + ,FEAT_DPB2, sFEAT_DPB2 + ,FEAT_ECV, sFEAT_ECV + ,FEAT_FCMA, sFEAT_FCMA + ,FEAT_FHM, sFEAT_FHM + ,FEAT_FlagM, sFEAT_FlagM + ,FEAT_FlagM2, sFEAT_FlagM2 + ,FEAT_FP16, sFEAT_FP16 + ,FEAT_FPAC, sFEAT_FPAC + ,FEAT_FRINTTS, sFEAT_FRINTTS + ,FEAT_I8MM, sFEAT_I8MM + ,FEAT_JSCVT, sFEAT_JSCVT + ,FEAT_LRCPC, sFEAT_LRCPC + ,FEAT_LRCPC2, sFEAT_LRCPC2 + ,FEAT_LSE, sFEAT_LSE + ,FEAT_LSE2, sFEAT_LSE2 + ,FEAT_PAuth, sFEAT_PAuth + ,FEAT_PAuth2, sFEAT_PAuth2 + ,FEAT_PMULL, sFEAT_PMULL + ,FEAT_RDM, sFEAT_RDM + ,FEAT_RPRES, sFEAT_RPRES + ,FEAT_SB, sFEAT_SB + ,FEAT_SHA1, sFEAT_SHA1 + ,FEAT_SHA256, sFEAT_SHA256 + ,FEAT_SHA3, sFEAT_SHA3 + ,FEAT_SHA512, sFEAT_SHA512 + ,FEAT_SME, sFEAT_SME + ,FEAT_SME_F64F64, sFEAT_SME_F64F64 + ,FEAT_SME_I16I64, sFEAT_SME_I16I64 + ,FEAT_SME2, sFEAT_SME2 + ,FEAT_SPECRES, sFEAT_SPECRES + ,FEAT_SSBS, sFEAT_SSBS + ,FEAT_SVE, sFEAT_SVE + ,FEAT_SVE2, sFEAT_SVE2 + ,FEAT_WFxT, sFEAT_WFxT + ,SBool(..) + ) where +import System.CPUFeatures.Arm.Bool +import System.CPUFeatures.Util + +type family FEAT_AES :: Bool -- optional from Armv8.0 +type family FEAT_AFP :: Bool +type family FEAT_BF16 :: Bool -- optional from Armv8.2, mandatory from Armv8.6 +type family FEAT_BTI :: Bool -- optional from Armv8.4, mandatory from Armv8.5 +type family FEAT_CSV2 :: Bool -- optional from Armv8.0, mandatory from Armv8.5 +type family FEAT_CSV3 :: Bool -- optional from Armv8.0, mandatory from Armv8.5 +type family FEAT_DIT :: Bool -- optional from Armv8.3, mandatory from Armv8.4 +type family FEAT_DotProd :: Bool -- optional from Armv8.1 +type family FEAT_DPB :: Bool -- optional from Armv8.1, mandatory from Armv8.2 +type family FEAT_DPB2 :: Bool -- optional from Armv8.1, mandatory from Armv8.5 +type family FEAT_ECV :: Bool -- optional from Armv8.5, mandatory from Armv8.6 +type family FEAT_FCMA :: Bool -- optional from Armv8.2 +type family FEAT_FHM :: Bool -- optional from Armv8.1 +type family FEAT_FlagM :: Bool -- optional from Armv8.1, mandatory from Armv8.4 +type family FEAT_FlagM2 :: Bool -- optional from Armv8.4 +type family FEAT_FP16 :: Bool -- optional from Armv8.2 +type family FEAT_FPAC :: Bool -- optional from Armv8.2 +type family FEAT_FRINTTS :: Bool -- optional from Armv8.4 +type family FEAT_I8MM :: Bool -- optional from Armv8.1, mandatory from Armv8.6 +type family FEAT_JSCVT :: Bool -- optional from Armv8.2 +type family FEAT_LRCPC :: Bool -- optional from Armv8.2, mandatory from Armv8.3 +type family FEAT_LRCPC2 :: Bool -- optional from Armv8.2, mandatory from Armv8.4 +type family FEAT_LSE :: Bool -- optional from Armv8.0, mandatory from Armv8.1 +type family FEAT_LSE2 :: Bool -- optional from Armv8.2, mandatory from Armv8.4 +type family FEAT_PAuth :: Bool -- optional from Armv8.2, mandatory from Armv8.3 +type family FEAT_PAuth2 :: Bool -- optional from Armv8.2, mandatory from Armv8.6 +type family FEAT_PMULL :: Bool -- optional from Armv8.0 +type family FEAT_RDM :: Bool -- optional from Armv8.0 +type family FEAT_RPRES :: Bool -- optional from Armv8.0 +type family FEAT_SB :: Bool -- optional from Armv8.0, mandatory from Armv8.5 +type family FEAT_SHA1 :: Bool -- optional from Armv8.0 +type family FEAT_SHA256 :: Bool -- optional from Armv8.0 +type family FEAT_SHA3 :: Bool -- optional from Armv8.1 +type family FEAT_SHA512 :: Bool -- optional from Armv8.1 +type family FEAT_SME :: Bool +type family FEAT_SME_F64F64 :: Bool +type family FEAT_SME_I16I64 :: Bool +type family FEAT_SME2 :: Bool +type family FEAT_SPECRES :: Bool -- optional from Armv8.0, mandatory from Armv8.5 +type family FEAT_SSBS :: Bool -- optional from Armv8.0 +type family FEAT_SVE :: Bool -- optional from Armv8.2 +type family FEAT_SVE2 :: Bool -- optional from Armv9.0 +type family FEAT_WFxT :: Bool + +sFEAT_AES :: SBool FEAT_AES +sFEAT_AFP :: SBool FEAT_AFP +sFEAT_BF16 :: SBool FEAT_BF16 +sFEAT_BTI :: SBool FEAT_BTI +sFEAT_CSV2 :: SBool FEAT_CSV2 +sFEAT_CSV3 :: SBool FEAT_CSV3 +sFEAT_DIT :: SBool FEAT_DIT +sFEAT_DotProd :: SBool FEAT_DotProd +sFEAT_DPB :: SBool FEAT_DPB +sFEAT_DPB2 :: SBool FEAT_DPB2 +sFEAT_ECV :: SBool FEAT_ECV +sFEAT_FCMA :: SBool FEAT_FCMA +sFEAT_FHM :: SBool FEAT_FHM +sFEAT_FlagM :: SBool FEAT_FlagM +sFEAT_FlagM2 :: SBool FEAT_FlagM2 +sFEAT_FP16 :: SBool FEAT_FP16 +sFEAT_FPAC :: SBool FEAT_FPAC +sFEAT_FRINTTS :: SBool FEAT_FRINTTS +sFEAT_I8MM :: SBool FEAT_I8MM +sFEAT_JSCVT :: SBool FEAT_JSCVT +sFEAT_LRCPC :: SBool FEAT_LRCPC +sFEAT_LRCPC2 :: SBool FEAT_LRCPC2 +sFEAT_LSE :: SBool FEAT_LSE +sFEAT_LSE2 :: SBool FEAT_LSE2 +sFEAT_PAuth :: SBool FEAT_PAuth +sFEAT_PAuth2 :: SBool FEAT_PAuth2 +sFEAT_PMULL :: SBool FEAT_PMULL +sFEAT_RDM :: SBool FEAT_RDM +sFEAT_RPRES :: SBool FEAT_RPRES +sFEAT_SB :: SBool FEAT_SB +sFEAT_SHA1 :: SBool FEAT_SHA1 +sFEAT_SHA256 :: SBool FEAT_SHA256 +sFEAT_SHA3 :: SBool FEAT_SHA3 +sFEAT_SHA512 :: SBool FEAT_SHA512 +sFEAT_SME :: SBool FEAT_SME +sFEAT_SME_F64F64 :: SBool FEAT_SME_F64F64 +sFEAT_SME_I16I64 :: SBool FEAT_SME_I16I64 +sFEAT_SME2 :: SBool FEAT_SME2 +sFEAT_SPECRES :: SBool FEAT_SPECRES +sFEAT_SSBS :: SBool FEAT_SSBS +sFEAT_SVE :: SBool FEAT_SVE +sFEAT_SVE2 :: SBool FEAT_SVE2 +sFEAT_WFxT :: SBool FEAT_WFxT + +sFEAT_AES = unsafeBoolToSBool bFEAT_AES +sFEAT_AFP = unsafeBoolToSBool bFEAT_AFP +sFEAT_BF16 = unsafeBoolToSBool bFEAT_BF16 +sFEAT_BTI = unsafeBoolToSBool bFEAT_BTI +sFEAT_CSV2 = unsafeBoolToSBool bFEAT_CSV2 +sFEAT_CSV3 = unsafeBoolToSBool bFEAT_CSV3 +sFEAT_DIT = unsafeBoolToSBool bFEAT_DIT +sFEAT_DotProd = unsafeBoolToSBool bFEAT_DotProd +sFEAT_DPB = unsafeBoolToSBool bFEAT_DPB +sFEAT_DPB2 = unsafeBoolToSBool bFEAT_DPB2 +sFEAT_ECV = unsafeBoolToSBool bFEAT_ECV +sFEAT_FCMA = unsafeBoolToSBool bFEAT_FCMA +sFEAT_FHM = unsafeBoolToSBool bFEAT_FHM +sFEAT_FlagM = unsafeBoolToSBool bFEAT_FlagM +sFEAT_FlagM2 = unsafeBoolToSBool bFEAT_FlagM2 +sFEAT_FP16 = unsafeBoolToSBool bFEAT_FP16 +sFEAT_FPAC = unsafeBoolToSBool bFEAT_FPAC +sFEAT_FRINTTS = unsafeBoolToSBool bFEAT_FRINTTS +sFEAT_I8MM = unsafeBoolToSBool bFEAT_I8MM +sFEAT_JSCVT = unsafeBoolToSBool bFEAT_JSCVT +sFEAT_LRCPC = unsafeBoolToSBool bFEAT_LRCPC +sFEAT_LRCPC2 = unsafeBoolToSBool bFEAT_LRCPC2 +sFEAT_LSE = unsafeBoolToSBool bFEAT_LSE +sFEAT_LSE2 = unsafeBoolToSBool bFEAT_LSE2 +sFEAT_PAuth = unsafeBoolToSBool bFEAT_PAuth +sFEAT_PAuth2 = unsafeBoolToSBool bFEAT_PAuth2 +sFEAT_PMULL = unsafeBoolToSBool bFEAT_PMULL +sFEAT_RDM = unsafeBoolToSBool bFEAT_RDM +sFEAT_RPRES = unsafeBoolToSBool bFEAT_RPRES +sFEAT_SB = unsafeBoolToSBool bFEAT_SB +sFEAT_SHA1 = unsafeBoolToSBool bFEAT_SHA1 +sFEAT_SHA256 = unsafeBoolToSBool bFEAT_SHA256 +sFEAT_SHA3 = unsafeBoolToSBool bFEAT_SHA3 +sFEAT_SHA512 = unsafeBoolToSBool bFEAT_SHA512 +sFEAT_SME = unsafeBoolToSBool bFEAT_SME +sFEAT_SME_F64F64 = unsafeBoolToSBool bFEAT_SME_F64F64 +sFEAT_SME_I16I64 = unsafeBoolToSBool bFEAT_SME_I16I64 +sFEAT_SME2 = unsafeBoolToSBool bFEAT_SME2 +sFEAT_SPECRES = unsafeBoolToSBool bFEAT_SPECRES +sFEAT_SSBS = unsafeBoolToSBool bFEAT_SSBS +sFEAT_SVE = unsafeBoolToSBool bFEAT_SVE +sFEAT_SVE2 = unsafeBoolToSBool bFEAT_SVE2 +sFEAT_WFxT = unsafeBoolToSBool bFEAT_WFxT diff --git a/src/System/CPUFeatures/RISCV.hs b/src/System/CPUFeatures/RISCV.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/RISCV.hs @@ -0,0 +1,4 @@ +module System.CPUFeatures.RISCV + (module System.CPUFeatures.RISCV.Bool + ) where +import System.CPUFeatures.RISCV.Bool diff --git a/src/System/CPUFeatures/RISCV/Bool.hs b/src/System/CPUFeatures/RISCV/Bool.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/RISCV/Bool.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{- | +Description: Detect RISC-V features at runtime + +This module provides the basic interface to detect CPU features. +The availability is indicated by a boolean variable (@b\@). +-} +module System.CPUFeatures.RISCV.Bool + (bC + ,bV + ,bZba + ,bZbb + ,bZbs + ,bZicboz + ,bZbc + ,bZbkb + ,bZbkc + ,bZbkx + ,bZknd + ,bZkne + ,bZknh + ,bZksed + ,bZksh + ,bZkt + ,bZvbb + ,bZvbc + ,bZvkb + ,bZvkg + ,bZvkned + ,bZvknha + ,bZvknhb + ,bZvksed + ,bZvksh + ,bZvkt + ,bZfh + ,bZfhmin + ,bZihintntl + ,bZvfh + ,bZvfhmin + ,bZfa + ,bZtso + ,bZacas + ,bZicntr + ,bZicond + ,bZihintpause + ,bZihpm + ,bZve32x + ,bZve32f + ,bZve64x + ,bZve64f + ,bZve64d + ,bZimop + ,bZca + ,bZcb + ,bZcd + ,bZcf + ,bZcmop + ,bZawrs + ,bZaamo + ,bZalrsc + ,bSupm + ,bZfbfmin + ,bZvfbfmin + ,bZvfbfwma + ,bZicbom + ) where +#if defined(riscv64_HOST_ARCH) && defined(linux_HOST_OS) +import Data.Bits ((.&.)) +import Hwcap +import Hwprobe +#endif + +bC :: Bool +bV :: Bool +bZba :: Bool +bZbb :: Bool +bZbs :: Bool +bZicboz :: Bool +bZbc :: Bool +bZbkb :: Bool +bZbkc :: Bool +bZbkx :: Bool +bZknd :: Bool +bZkne :: Bool +bZknh :: Bool +bZksed :: Bool +bZksh :: Bool +bZkt :: Bool +bZvbb :: Bool +bZvbc :: Bool +bZvkb :: Bool +bZvkg :: Bool +bZvkned :: Bool +bZvknha :: Bool +bZvknhb :: Bool +bZvksed :: Bool +bZvksh :: Bool +bZvkt :: Bool +bZfh :: Bool +bZfhmin :: Bool +bZihintntl :: Bool +bZvfh :: Bool +bZvfhmin :: Bool +bZfa :: Bool +bZtso :: Bool +bZacas :: Bool +bZicntr :: Bool +bZicond :: Bool +bZihintpause :: Bool +bZihpm :: Bool +bZve32x :: Bool +bZve32f :: Bool +bZve64x :: Bool +bZve64f :: Bool +bZve64d :: Bool +bZimop :: Bool +bZca :: Bool +bZcb :: Bool +bZcd :: Bool +bZcf :: Bool +bZcmop :: Bool +bZawrs :: Bool +bZaamo :: Bool +bZalrsc :: Bool +bSupm :: Bool +bZfbfmin :: Bool +bZvfbfmin :: Bool +bZvfbfwma :: Bool +bZicbom :: Bool + +#if defined(riscv64_HOST_ARCH) && defined(linux_HOST_OS) + +bC = hwcap .&. hwcap_C /= 0 +bV = hwcap .&. hwcap_V /= 0 +-- bC = hwprobe_ima_ext_0 .&. hwprobe_IMA_C /= 0 +-- bV = hwprobe_ima_ext_0 .&. hwprobe_IMA_V /= 0 +bZba = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBA /= 0 +bZbb = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBB /= 0 +bZbs = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBS /= 0 +bZicboz = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZICBOZ /= 0 +bZbc = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBC /= 0 +bZbkb = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBKB /= 0 +bZbkc = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBKC /= 0 +bZbkx = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZBKX /= 0 +bZknd = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZKND /= 0 +bZkne = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZKNE /= 0 +bZknh = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZKNH /= 0 +bZksed = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZKSED /= 0 +bZksh = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZKSH /= 0 +bZkt = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZKT /= 0 +bZvbb = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVBB /= 0 +bZvbc = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVBC /= 0 +bZvkb = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKB /= 0 +bZvkg = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKG /= 0 +bZvkned = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKNED /= 0 +bZvknha = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKNHA /= 0 +bZvknhb = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKNHB /= 0 +bZvksed = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKSED /= 0 +bZvksh = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKSH /= 0 +bZvkt = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVKT /= 0 +bZfh = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZFH /= 0 +bZfhmin = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZFHMIN /= 0 +bZihintntl = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZIHINTNTL /= 0 +bZvfh = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVFH /= 0 +bZvfhmin = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVFHMIN /= 0 +bZfa = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZFA /= 0 +bZtso = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZTSO /= 0 +bZacas = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZACAS /= 0 +bZicntr = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZICNTR /= 0 +bZicond = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZICOND /= 0 +bZihintpause = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZIHINTPAUSE /= 0 +bZihpm = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZIHPM /= 0 +bZve32x = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVE32X /= 0 +bZve32f = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVE32F /= 0 +bZve64x = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVE64X /= 0 +bZve64f = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVE64F /= 0 +bZve64d = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVE64D /= 0 +bZimop = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZIMOP /= 0 +bZca = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZCA /= 0 +bZcb = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZCB /= 0 +bZcd = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZCD /= 0 +bZcf = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZCF /= 0 +bZcmop = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZCMOP /= 0 +bZawrs = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZAWRS /= 0 +bZaamo = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZAAMO /= 0 +bZalrsc = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZALRSC /= 0 +bSupm = hwprobe_ima_ext_0 .&. hwprobe_EXT_SUPM /= 0 +bZfbfmin = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZFBFMIN /= 0 +bZvfbfmin = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVFBFMIN /= 0 +bZvfbfwma = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZVFBFWMA /= 0 +bZicbom = hwprobe_ima_ext_0 .&. hwprobe_EXT_ZICBOM /= 0 + +#else + +{-# INLINE bC #-} +bC = False + +{-# INLINE bV #-} +bV = False + +{-# INLINE bZba #-} +bZba = False + +{-# INLINE bZbb #-} +bZbb = False + +{-# INLINE bZbs #-} +bZbs = False + +{-# INLINE bZicboz #-} +bZicboz = False + +{-# INLINE bZbc #-} +bZbc = False + +{-# INLINE bZbkb #-} +bZbkb = False + +{-# INLINE bZbkc #-} +bZbkc = False + +{-# INLINE bZbkx #-} +bZbkx = False + +{-# INLINE bZknd #-} +bZknd = False + +{-# INLINE bZkne #-} +bZkne = False + +{-# INLINE bZknh #-} +bZknh = False + +{-# INLINE bZksed #-} +bZksed = False + +{-# INLINE bZksh #-} +bZksh = False + +{-# INLINE bZkt #-} +bZkt = False + +{-# INLINE bZvbb #-} +bZvbb = False + +{-# INLINE bZvbc #-} +bZvbc = False + +{-# INLINE bZvkb #-} +bZvkb = False + +{-# INLINE bZvkg #-} +bZvkg = False + +{-# INLINE bZvkned #-} +bZvkned = False + +{-# INLINE bZvknha #-} +bZvknha = False + +{-# INLINE bZvknhb #-} +bZvknhb = False + +{-# INLINE bZvksed #-} +bZvksed = False + +{-# INLINE bZvksh #-} +bZvksh = False + +{-# INLINE bZvkt #-} +bZvkt = False + +{-# INLINE bZfh #-} +bZfh = False + +{-# INLINE bZfhmin #-} +bZfhmin = False + +{-# INLINE bZihintntl #-} +bZihintntl = False + +{-# INLINE bZvfh #-} +bZvfh = False + +{-# INLINE bZvfhmin #-} +bZvfhmin = False + +{-# INLINE bZfa #-} +bZfa = False + +{-# INLINE bZtso #-} +bZtso = False + +{-# INLINE bZacas #-} +bZacas = False + +{-# INLINE bZicntr #-} +bZicntr = False + +{-# INLINE bZicond #-} +bZicond = False + +{-# INLINE bZihintpause #-} +bZihintpause = False + +{-# INLINE bZihpm #-} +bZihpm = False + +{-# INLINE bZve32x #-} +bZve32x = False + +{-# INLINE bZve32f #-} +bZve32f = False + +{-# INLINE bZve64x #-} +bZve64x = False + +{-# INLINE bZve64f #-} +bZve64f = False + +{-# INLINE bZve64d #-} +bZve64d = False + +{-# INLINE bZimop #-} +bZimop = False + +{-# INLINE bZca #-} +bZca = False + +{-# INLINE bZcb #-} +bZcb = False + +{-# INLINE bZcd #-} +bZcd = False + +{-# INLINE bZcf #-} +bZcf = False + +{-# INLINE bZcmop #-} +bZcmop = False + +{-# INLINE bZawrs #-} +bZawrs = False + +{-# INLINE bZaamo #-} +bZaamo = False + +{-# INLINE bZalrsc #-} +bZalrsc = False + +{-# INLINE bSupm #-} +bSupm = False + +{-# INLINE bZfbfmin #-} +bZfbfmin = False + +{-# INLINE bZvfbfmin #-} +bZvfbfmin = False + +{-# INLINE bZvfbfwma #-} +bZvfbfwma = False + +{-# INLINE bZicbom #-} +bZicbom = False + +#endif diff --git a/src/System/CPUFeatures/RISCV/Constraint.hs b/src/System/CPUFeatures/RISCV/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/RISCV/Constraint.hs @@ -0,0 +1,79 @@ +{- | +Description: RISC-V features as nullary constraints + +This module provides the constraint interface to detect CPU features. +You can mark your function with @Has\ =>@ to indicate that +it requires a specific CPU feature. +You can detect the availability and get the constraint @Has\@ +by pattern-matching on the variable @query\@. + +Example: + +> -- This function requires the Vector extension +> someFunction :: HasV => ... +> +> case queryV of +> Just Dict -> {- In this branch, HasV is available -} someFunction +> Nothing -> {- In this branch, HasV is not available -} error "Vector extension not available" +-} +module System.CPUFeatures.RISCV.Constraint + (HasC, queryC + ,HasV, queryV + ,HasZba, queryZba + ,HasZbb, queryZbb + ,HasZbs, queryZbs + ,HasZicboz, queryZicboz + ,HasZbc, queryZbc + ,HasZbkb, queryZbkb + ,HasZbkc, queryZbkc + ,HasZbkx, queryZbkx + ,HasZknd, queryZknd + ,HasZkne, queryZkne + ,HasZknh, queryZknh + ,HasZksed, queryZksed + ,HasZksh, queryZksh + ,HasZkt, queryZkt + ,HasZvbb, queryZvbb + ,HasZvbc, queryZvbc + ,HasZvkb, queryZvkb + ,HasZvkg, queryZvkg + ,HasZvkned, queryZvkned + ,HasZvknha, queryZvknha + ,HasZvknhb, queryZvknhb + ,HasZvksed, queryZvksed + ,HasZvksh, queryZvksh + ,HasZvkt, queryZvkt + ,HasZfh, queryZfh + ,HasZfhmin, queryZfhmin + ,HasZihintntl, queryZihintntl + ,HasZvfh, queryZvfh + ,HasZvfhmin, queryZvfhmin + ,HasZfa, queryZfa + ,HasZtso, queryZtso + ,HasZacas, queryZacas + ,HasZicntr, queryZicntr + ,HasZicond, queryZicond + ,HasZihintpause, queryZihintpause + ,HasZihpm, queryZihpm + ,HasZve32x, queryZve32x + ,HasZve32f, queryZve32f + ,HasZve64x, queryZve64x + ,HasZve64f, queryZve64f + ,HasZve64d, queryZve64d + ,HasZimop, queryZimop + ,HasZca, queryZca + ,HasZcb, queryZcb + ,HasZcd, queryZcd + ,HasZcf, queryZcf + ,HasZcmop, queryZcmop + ,HasZawrs, queryZawrs + ,HasZaamo, queryZaamo + ,HasZalrsc, queryZalrsc + ,HasSupm, querySupm + ,HasZfbfmin, queryZfbfmin + ,HasZvfbfmin, queryZvfbfmin + ,HasZvfbfwma, queryZvfbfwma + ,HasZicbom, queryZicbom + ,Dict(Dict) + ) where +import System.CPUFeatures.RISCV.Constraint.Unsafe diff --git a/src/System/CPUFeatures/RISCV/Constraint/Unsafe.hs b/src/System/CPUFeatures/RISCV/Constraint/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/RISCV/Constraint/Unsafe.hs @@ -0,0 +1,581 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module System.CPUFeatures.RISCV.Constraint.Unsafe + ( module System.CPUFeatures.RISCV.Constraint.Unsafe + , Dict (Dict) + ) where +import Data.Type.Equality ((:~:)(Refl)) +import System.CPUFeatures.Util +import System.CPUFeatures.RISCV.TypeBool +import Unsafe.Coerce (unsafeCoerce) + +class C ~ True => HasC +instance C ~ True => HasC + +class V ~ True => HasV +instance V ~ True => HasV + +class Zba ~ True => HasZba +instance Zba ~ True => HasZba + +class Zbb ~ True => HasZbb +instance Zbb ~ True => HasZbb + +class Zbs ~ True => HasZbs +instance Zbs ~ True => HasZbs + +class Zicboz ~ True => HasZicboz +instance Zicboz ~ True => HasZicboz + +class Zbc ~ True => HasZbc +instance Zbc ~ True => HasZbc + +class Zbkb ~ True => HasZbkb +instance Zbkb ~ True => HasZbkb + +class Zbkc ~ True => HasZbkc +instance Zbkc ~ True => HasZbkc + +class Zbkx ~ True => HasZbkx +instance Zbkx ~ True => HasZbkx + +class Zknd ~ True => HasZknd +instance Zknd ~ True => HasZknd + +class Zkne ~ True => HasZkne +instance Zkne ~ True => HasZkne + +class Zknh ~ True => HasZknh +instance Zknh ~ True => HasZknh + +class Zksed ~ True => HasZksed +instance Zksed ~ True => HasZksed + +class Zksh ~ True => HasZksh +instance Zksh ~ True => HasZksh + +class Zkt ~ True => HasZkt +instance Zkt ~ True => HasZkt + +class Zvbb ~ True => HasZvbb +instance Zvbb ~ True => HasZvbb + +class Zvbc ~ True => HasZvbc +instance Zvbc ~ True => HasZvbc + +class Zvkb ~ True => HasZvkb +instance Zvkb ~ True => HasZvkb + +class Zvkg ~ True => HasZvkg +instance Zvkg ~ True => HasZvkg + +class Zvkned ~ True => HasZvkned +instance Zvkned ~ True => HasZvkned + +class Zvknha ~ True => HasZvknha +instance Zvknha ~ True => HasZvknha + +class Zvknhb ~ True => HasZvknhb +instance Zvknhb ~ True => HasZvknhb + +class Zvksed ~ True => HasZvksed +instance Zvksed ~ True => HasZvksed + +class Zvksh ~ True => HasZvksh +instance Zvksh ~ True => HasZvksh + +class Zvkt ~ True => HasZvkt +instance Zvkt ~ True => HasZvkt + +class Zfh ~ True => HasZfh +instance Zfh ~ True => HasZfh + +class Zfhmin ~ True => HasZfhmin +instance Zfhmin ~ True => HasZfhmin + +class Zihintntl ~ True => HasZihintntl +instance Zihintntl ~ True => HasZihintntl + +class Zvfh ~ True => HasZvfh +instance Zvfh ~ True => HasZvfh + +class Zvfhmin ~ True => HasZvfhmin +instance Zvfhmin ~ True => HasZvfhmin + +class Zfa ~ True => HasZfa +instance Zfa ~ True => HasZfa + +class Ztso ~ True => HasZtso +instance Ztso ~ True => HasZtso + +class Zacas ~ True => HasZacas +instance Zacas ~ True => HasZacas + +class Zicntr ~ True => HasZicntr +instance Zicntr ~ True => HasZicntr + +class Zicond ~ True => HasZicond +instance Zicond ~ True => HasZicond + +class Zihintpause ~ True => HasZihintpause +instance Zihintpause ~ True => HasZihintpause + +class Zihpm ~ True => HasZihpm +instance Zihpm ~ True => HasZihpm + +class Zve32x ~ True => HasZve32x +instance Zve32x ~ True => HasZve32x + +class Zve32f ~ True => HasZve32f +instance Zve32f ~ True => HasZve32f + +class Zve64x ~ True => HasZve64x +instance Zve64x ~ True => HasZve64x + +class Zve64f ~ True => HasZve64f +instance Zve64f ~ True => HasZve64f + +class Zve64d ~ True => HasZve64d +instance Zve64d ~ True => HasZve64d + +class Zimop ~ True => HasZimop +instance Zimop ~ True => HasZimop + +class Zca ~ True => HasZca +instance Zca ~ True => HasZca + +class Zcb ~ True => HasZcb +instance Zcb ~ True => HasZcb + +class Zcd ~ True => HasZcd +instance Zcd ~ True => HasZcd + +class Zcf ~ True => HasZcf +instance Zcf ~ True => HasZcf + +class Zcmop ~ True => HasZcmop +instance Zcmop ~ True => HasZcmop + +class Zawrs ~ True => HasZawrs +instance Zawrs ~ True => HasZawrs + +class Zaamo ~ True => HasZaamo +instance Zaamo ~ True => HasZaamo + +class Zalrsc ~ True => HasZalrsc +instance Zalrsc ~ True => HasZalrsc + +class Supm ~ True => HasSupm +instance Supm ~ True => HasSupm + +class Zfbfmin ~ True => HasZfbfmin +instance Zfbfmin ~ True => HasZfbfmin + +class Zvfbfmin ~ True => HasZvfbfmin +instance Zvfbfmin ~ True => HasZvfbfmin + +class Zvfbfwma ~ True => HasZvfbfwma +instance Zvfbfwma ~ True => HasZvfbfwma + +class Zicbom ~ True => HasZicbom +instance Zicbom ~ True => HasZicbom + +unsafeAssumeC :: (HasC => a) -> a +unsafeAssumeC k = case unsafeCoerce Refl :: C :~: True of Refl -> k + +queryC :: Maybe (Dict HasC) +queryC = case sC of STrue -> unsafeAssumeC (Just Dict); SFalse -> Nothing +{-# NOINLINE queryC #-} + +unsafeAssumeV :: (HasV => a) -> a +unsafeAssumeV k = case unsafeCoerce Refl :: V :~: True of Refl -> k + +queryV :: Maybe (Dict HasV) +queryV = case sV of STrue -> unsafeAssumeV (Just Dict); SFalse -> Nothing +{-# NOINLINE queryV #-} + +unsafeAssumeZba :: (HasZba => a) -> a +unsafeAssumeZba k = case unsafeCoerce Refl :: Zba :~: True of Refl -> k + +queryZba :: Maybe (Dict HasZba) +queryZba = case sZba of STrue -> unsafeAssumeZba (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZba #-} + +unsafeAssumeZbb :: (HasZbb => a) -> a +unsafeAssumeZbb k = case unsafeCoerce Refl :: Zbb :~: True of Refl -> k + +queryZbb :: Maybe (Dict HasZbb) +queryZbb = case sZbb of STrue -> unsafeAssumeZbb (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZbb #-} + +unsafeAssumeZbs :: (HasZbs => a) -> a +unsafeAssumeZbs k = case unsafeCoerce Refl :: Zbs :~: True of Refl -> k + +queryZbs :: Maybe (Dict HasZbs) +queryZbs = case sZbs of STrue -> unsafeAssumeZbs (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZbs #-} + +unsafeAssumeZicboz :: (HasZicboz => a) -> a +unsafeAssumeZicboz k = case unsafeCoerce Refl :: Zicboz :~: True of Refl -> k + +queryZicboz :: Maybe (Dict HasZicboz) +queryZicboz = case sZicboz of STrue -> unsafeAssumeZicboz (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZicboz #-} + +unsafeAssumeZbc :: (HasZbc => a) -> a +unsafeAssumeZbc k = case unsafeCoerce Refl :: Zbc :~: True of Refl -> k + +queryZbc :: Maybe (Dict HasZbc) +queryZbc = case sZbc of STrue -> unsafeAssumeZbc (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZbc #-} + +unsafeAssumeZbkb :: (HasZbkb => a) -> a +unsafeAssumeZbkb k = case unsafeCoerce Refl :: Zbkb :~: True of Refl -> k + +queryZbkb :: Maybe (Dict HasZbkb) +queryZbkb = case sZbkb of STrue -> unsafeAssumeZbkb (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZbkb #-} + +unsafeAssumeZbkc :: (HasZbkc => a) -> a +unsafeAssumeZbkc k = case unsafeCoerce Refl :: Zbkc :~: True of Refl -> k + +queryZbkc :: Maybe (Dict HasZbkc) +queryZbkc = case sZbkc of STrue -> unsafeAssumeZbkc (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZbkc #-} + +unsafeAssumeZbkx :: (HasZbkx => a) -> a +unsafeAssumeZbkx k = case unsafeCoerce Refl :: Zbkx :~: True of Refl -> k + +queryZbkx :: Maybe (Dict HasZbkx) +queryZbkx = case sZbkx of STrue -> unsafeAssumeZbkx (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZbkx #-} + +unsafeAssumeZknd :: (HasZknd => a) -> a +unsafeAssumeZknd k = case unsafeCoerce Refl :: Zknd :~: True of Refl -> k + +queryZknd :: Maybe (Dict HasZknd) +queryZknd = case sZknd of STrue -> unsafeAssumeZknd (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZknd #-} + +unsafeAssumeZkne :: (HasZkne => a) -> a +unsafeAssumeZkne k = case unsafeCoerce Refl :: Zkne :~: True of Refl -> k + +queryZkne :: Maybe (Dict HasZkne) +queryZkne = case sZkne of STrue -> unsafeAssumeZkne (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZkne #-} + +unsafeAssumeZknh :: (HasZknh => a) -> a +unsafeAssumeZknh k = case unsafeCoerce Refl :: Zknh :~: True of Refl -> k + +queryZknh :: Maybe (Dict HasZknh) +queryZknh = case sZknh of STrue -> unsafeAssumeZknh (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZknh #-} + +unsafeAssumeZksed :: (HasZksed => a) -> a +unsafeAssumeZksed k = case unsafeCoerce Refl :: Zksed :~: True of Refl -> k + +queryZksed :: Maybe (Dict HasZksed) +queryZksed = case sZksed of STrue -> unsafeAssumeZksed (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZksed #-} + +unsafeAssumeZksh :: (HasZksh => a) -> a +unsafeAssumeZksh k = case unsafeCoerce Refl :: Zksh :~: True of Refl -> k + +queryZksh :: Maybe (Dict HasZksh) +queryZksh = case sZksh of STrue -> unsafeAssumeZksh (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZksh #-} + +unsafeAssumeZkt :: (HasZkt => a) -> a +unsafeAssumeZkt k = case unsafeCoerce Refl :: Zkt :~: True of Refl -> k + +queryZkt :: Maybe (Dict HasZkt) +queryZkt = case sZkt of STrue -> unsafeAssumeZkt (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZkt #-} + +unsafeAssumeZvbb :: (HasZvbb => a) -> a +unsafeAssumeZvbb k = case unsafeCoerce Refl :: Zvbb :~: True of Refl -> k + +queryZvbb :: Maybe (Dict HasZvbb) +queryZvbb = case sZvbb of STrue -> unsafeAssumeZvbb (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvbb #-} + +unsafeAssumeZvbc :: (HasZvbc => a) -> a +unsafeAssumeZvbc k = case unsafeCoerce Refl :: Zvbc :~: True of Refl -> k + +queryZvbc :: Maybe (Dict HasZvbc) +queryZvbc = case sZvbc of STrue -> unsafeAssumeZvbc (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvbc #-} + +unsafeAssumeZvkb :: (HasZvkb => a) -> a +unsafeAssumeZvkb k = case unsafeCoerce Refl :: Zvkb :~: True of Refl -> k + +queryZvkb :: Maybe (Dict HasZvkb) +queryZvkb = case sZvkb of STrue -> unsafeAssumeZvkb (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvkb #-} + +unsafeAssumeZvkg :: (HasZvkg => a) -> a +unsafeAssumeZvkg k = case unsafeCoerce Refl :: Zvkg :~: True of Refl -> k + +queryZvkg :: Maybe (Dict HasZvkg) +queryZvkg = case sZvkg of STrue -> unsafeAssumeZvkg (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvkg #-} + +unsafeAssumeZvkned :: (HasZvkned => a) -> a +unsafeAssumeZvkned k = case unsafeCoerce Refl :: Zvkned :~: True of Refl -> k + +queryZvkned :: Maybe (Dict HasZvkned) +queryZvkned = case sZvkned of STrue -> unsafeAssumeZvkned (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvkned #-} + +unsafeAssumeZvknha :: (HasZvknha => a) -> a +unsafeAssumeZvknha k = case unsafeCoerce Refl :: Zvknha :~: True of Refl -> k + +queryZvknha :: Maybe (Dict HasZvknha) +queryZvknha = case sZvknha of STrue -> unsafeAssumeZvknha (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvknha #-} + +unsafeAssumeZvknhb :: (HasZvknhb => a) -> a +unsafeAssumeZvknhb k = case unsafeCoerce Refl :: Zvknhb :~: True of Refl -> k + +queryZvknhb :: Maybe (Dict HasZvknhb) +queryZvknhb = case sZvknhb of STrue -> unsafeAssumeZvknhb (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvknhb #-} + +unsafeAssumeZvksed :: (HasZvksed => a) -> a +unsafeAssumeZvksed k = case unsafeCoerce Refl :: Zvksed :~: True of Refl -> k + +queryZvksed :: Maybe (Dict HasZvksed) +queryZvksed = case sZvksed of STrue -> unsafeAssumeZvksed (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvksed #-} + +unsafeAssumeZvksh :: (HasZvksh => a) -> a +unsafeAssumeZvksh k = case unsafeCoerce Refl :: Zvksh :~: True of Refl -> k + +queryZvksh :: Maybe (Dict HasZvksh) +queryZvksh = case sZvksh of STrue -> unsafeAssumeZvksh (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvksh #-} + +unsafeAssumeZvkt :: (HasZvkt => a) -> a +unsafeAssumeZvkt k = case unsafeCoerce Refl :: Zvkt :~: True of Refl -> k + +queryZvkt :: Maybe (Dict HasZvkt) +queryZvkt = case sZvkt of STrue -> unsafeAssumeZvkt (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvkt #-} + +unsafeAssumeZfh :: (HasZfh => a) -> a +unsafeAssumeZfh k = case unsafeCoerce Refl :: Zfh :~: True of Refl -> k + +queryZfh :: Maybe (Dict HasZfh) +queryZfh = case sZfh of STrue -> unsafeAssumeZfh (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZfh #-} + +unsafeAssumeZfhmin :: (HasZfhmin => a) -> a +unsafeAssumeZfhmin k = case unsafeCoerce Refl :: Zfhmin :~: True of Refl -> k + +queryZfhmin :: Maybe (Dict HasZfhmin) +queryZfhmin = case sZfhmin of STrue -> unsafeAssumeZfhmin (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZfhmin #-} + +unsafeAssumeZihintntl :: (HasZihintntl => a) -> a +unsafeAssumeZihintntl k = case unsafeCoerce Refl :: Zihintntl :~: True of Refl -> k + +queryZihintntl :: Maybe (Dict HasZihintntl) +queryZihintntl = case sZihintntl of STrue -> unsafeAssumeZihintntl (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZihintntl #-} + +unsafeAssumeZvfh :: (HasZvfh => a) -> a +unsafeAssumeZvfh k = case unsafeCoerce Refl :: Zvfh :~: True of Refl -> k + +queryZvfh :: Maybe (Dict HasZvfh) +queryZvfh = case sZvfh of STrue -> unsafeAssumeZvfh (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvfh #-} + +unsafeAssumeZvfhmin :: (HasZvfhmin => a) -> a +unsafeAssumeZvfhmin k = case unsafeCoerce Refl :: Zvfhmin :~: True of Refl -> k + +queryZvfhmin :: Maybe (Dict HasZvfhmin) +queryZvfhmin = case sZvfhmin of STrue -> unsafeAssumeZvfhmin (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvfhmin #-} + +unsafeAssumeZfa :: (HasZfa => a) -> a +unsafeAssumeZfa k = case unsafeCoerce Refl :: Zfa :~: True of Refl -> k + +queryZfa :: Maybe (Dict HasZfa) +queryZfa = case sZfa of STrue -> unsafeAssumeZfa (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZfa #-} + +unsafeAssumeZtso :: (HasZtso => a) -> a +unsafeAssumeZtso k = case unsafeCoerce Refl :: Ztso :~: True of Refl -> k + +queryZtso :: Maybe (Dict HasZtso) +queryZtso = case sZtso of STrue -> unsafeAssumeZtso (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZtso #-} + +unsafeAssumeZacas :: (HasZacas => a) -> a +unsafeAssumeZacas k = case unsafeCoerce Refl :: Zacas :~: True of Refl -> k + +queryZacas :: Maybe (Dict HasZacas) +queryZacas = case sZacas of STrue -> unsafeAssumeZacas (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZacas #-} + +unsafeAssumeZicntr :: (HasZicntr => a) -> a +unsafeAssumeZicntr k = case unsafeCoerce Refl :: Zicntr :~: True of Refl -> k + +queryZicntr :: Maybe (Dict HasZicntr) +queryZicntr = case sZicntr of STrue -> unsafeAssumeZicntr (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZicntr #-} + +unsafeAssumeZicond :: (HasZicond => a) -> a +unsafeAssumeZicond k = case unsafeCoerce Refl :: Zicond :~: True of Refl -> k + +queryZicond :: Maybe (Dict HasZicond) +queryZicond = case sZicond of STrue -> unsafeAssumeZicond (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZicond #-} + +unsafeAssumeZihintpause :: (HasZihintpause => a) -> a +unsafeAssumeZihintpause k = case unsafeCoerce Refl :: Zihintpause :~: True of Refl -> k + +queryZihintpause :: Maybe (Dict HasZihintpause) +queryZihintpause = case sZihintpause of STrue -> unsafeAssumeZihintpause (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZihintpause #-} + +unsafeAssumeZihpm :: (HasZihpm => a) -> a +unsafeAssumeZihpm k = case unsafeCoerce Refl :: Zihpm :~: True of Refl -> k + +queryZihpm :: Maybe (Dict HasZihpm) +queryZihpm = case sZihpm of STrue -> unsafeAssumeZihpm (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZihpm #-} + +unsafeAssumeZve32x :: (HasZve32x => a) -> a +unsafeAssumeZve32x k = case unsafeCoerce Refl :: Zve32x :~: True of Refl -> k + +queryZve32x :: Maybe (Dict HasZve32x) +queryZve32x = case sZve32x of STrue -> unsafeAssumeZve32x (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZve32x #-} + +unsafeAssumeZve32f :: (HasZve32f => a) -> a +unsafeAssumeZve32f k = case unsafeCoerce Refl :: Zve32f :~: True of Refl -> k + +queryZve32f :: Maybe (Dict HasZve32f) +queryZve32f = case sZve32f of STrue -> unsafeAssumeZve32f (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZve32f #-} + +unsafeAssumeZve64x :: (HasZve64x => a) -> a +unsafeAssumeZve64x k = case unsafeCoerce Refl :: Zve64x :~: True of Refl -> k + +queryZve64x :: Maybe (Dict HasZve64x) +queryZve64x = case sZve64x of STrue -> unsafeAssumeZve64x (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZve64x #-} + +unsafeAssumeZve64f :: (HasZve64f => a) -> a +unsafeAssumeZve64f k = case unsafeCoerce Refl :: Zve64f :~: True of Refl -> k + +queryZve64f :: Maybe (Dict HasZve64f) +queryZve64f = case sZve64f of STrue -> unsafeAssumeZve64f (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZve64f #-} + +unsafeAssumeZve64d :: (HasZve64d => a) -> a +unsafeAssumeZve64d k = case unsafeCoerce Refl :: Zve64d :~: True of Refl -> k + +queryZve64d :: Maybe (Dict HasZve64d) +queryZve64d = case sZve64d of STrue -> unsafeAssumeZve64d (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZve64d #-} + +unsafeAssumeZimop :: (HasZimop => a) -> a +unsafeAssumeZimop k = case unsafeCoerce Refl :: Zimop :~: True of Refl -> k + +queryZimop :: Maybe (Dict HasZimop) +queryZimop = case sZimop of STrue -> unsafeAssumeZimop (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZimop #-} + +unsafeAssumeZca :: (HasZca => a) -> a +unsafeAssumeZca k = case unsafeCoerce Refl :: Zca :~: True of Refl -> k + +queryZca :: Maybe (Dict HasZca) +queryZca = case sZca of STrue -> unsafeAssumeZca (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZca #-} + +unsafeAssumeZcb :: (HasZcb => a) -> a +unsafeAssumeZcb k = case unsafeCoerce Refl :: Zcb :~: True of Refl -> k + +queryZcb :: Maybe (Dict HasZcb) +queryZcb = case sZcb of STrue -> unsafeAssumeZcb (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZcb #-} + +unsafeAssumeZcd :: (HasZcd => a) -> a +unsafeAssumeZcd k = case unsafeCoerce Refl :: Zcd :~: True of Refl -> k + +queryZcd :: Maybe (Dict HasZcd) +queryZcd = case sZcd of STrue -> unsafeAssumeZcd (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZcd #-} + +unsafeAssumeZcf :: (HasZcf => a) -> a +unsafeAssumeZcf k = case unsafeCoerce Refl :: Zcf :~: True of Refl -> k + +queryZcf :: Maybe (Dict HasZcf) +queryZcf = case sZcf of STrue -> unsafeAssumeZcf (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZcf #-} + +unsafeAssumeZcmop :: (HasZcmop => a) -> a +unsafeAssumeZcmop k = case unsafeCoerce Refl :: Zcmop :~: True of Refl -> k + +queryZcmop :: Maybe (Dict HasZcmop) +queryZcmop = case sZcmop of STrue -> unsafeAssumeZcmop (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZcmop #-} + +unsafeAssumeZawrs :: (HasZawrs => a) -> a +unsafeAssumeZawrs k = case unsafeCoerce Refl :: Zawrs :~: True of Refl -> k + +queryZawrs :: Maybe (Dict HasZawrs) +queryZawrs = case sZawrs of STrue -> unsafeAssumeZawrs (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZawrs #-} + +unsafeAssumeZaamo :: (HasZaamo => a) -> a +unsafeAssumeZaamo k = case unsafeCoerce Refl :: Zaamo :~: True of Refl -> k + +queryZaamo :: Maybe (Dict HasZaamo) +queryZaamo = case sZaamo of STrue -> unsafeAssumeZaamo (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZaamo #-} + +unsafeAssumeZalrsc :: (HasZalrsc => a) -> a +unsafeAssumeZalrsc k = case unsafeCoerce Refl :: Zalrsc :~: True of Refl -> k + +queryZalrsc :: Maybe (Dict HasZalrsc) +queryZalrsc = case sZalrsc of STrue -> unsafeAssumeZalrsc (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZalrsc #-} + +unsafeAssumeSupm :: (HasSupm => a) -> a +unsafeAssumeSupm k = case unsafeCoerce Refl :: Supm :~: True of Refl -> k + +querySupm :: Maybe (Dict HasSupm) +querySupm = case sSupm of STrue -> unsafeAssumeSupm (Just Dict); SFalse -> Nothing +{-# NOINLINE querySupm #-} + +unsafeAssumeZfbfmin :: (HasZfbfmin => a) -> a +unsafeAssumeZfbfmin k = case unsafeCoerce Refl :: Zfbfmin :~: True of Refl -> k + +queryZfbfmin :: Maybe (Dict HasZfbfmin) +queryZfbfmin = case sZfbfmin of STrue -> unsafeAssumeZfbfmin (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZfbfmin #-} + +unsafeAssumeZvfbfmin :: (HasZvfbfmin => a) -> a +unsafeAssumeZvfbfmin k = case unsafeCoerce Refl :: Zvfbfmin :~: True of Refl -> k + +queryZvfbfmin :: Maybe (Dict HasZvfbfmin) +queryZvfbfmin = case sZvfbfmin of STrue -> unsafeAssumeZvfbfmin (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvfbfmin #-} + +unsafeAssumeZvfbfwma :: (HasZvfbfwma => a) -> a +unsafeAssumeZvfbfwma k = case unsafeCoerce Refl :: Zvfbfwma :~: True of Refl -> k + +queryZvfbfwma :: Maybe (Dict HasZvfbfwma) +queryZvfbfwma = case sZvfbfwma of STrue -> unsafeAssumeZvfbfwma (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZvfbfwma #-} + +unsafeAssumeZicbom :: (HasZicbom => a) -> a +unsafeAssumeZicbom k = case unsafeCoerce Refl :: Zicbom :~: True of Refl -> k + +queryZicbom :: Maybe (Dict HasZicbom) +queryZicbom = case sZicbom of STrue -> unsafeAssumeZicbom (Just Dict); SFalse -> Nothing +{-# NOINLINE queryZicbom #-} diff --git a/src/System/CPUFeatures/RISCV/TypeBool.hs b/src/System/CPUFeatures/RISCV/TypeBool.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/RISCV/TypeBool.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{- | +Description: RISC-V features as type-level booleans + +This module provides the type-level interface to detect CPU features. +You can mark your function with @\ ~ True =>@ to indicate that +it requires a specific CPU feature. +You can detect the availability and get the constraint @\ ~ True@ +by pattern-matching on the variable @s\@. + +Example: + +> -- This function requires the Vector extension +> someFunction :: V ~ True => ... +> +> case sV of +> STrue -> {- In this branch, V is True -} someFunction +> SFalse -> {- In this branch, V is False -} error "Vector extension not available" +-} +module System.CPUFeatures.RISCV.TypeBool + (C, sC + ,V, sV + ,Zba, sZba + ,Zbb, sZbb + ,Zbs, sZbs + ,Zicboz, sZicboz + ,Zbc, sZbc + ,Zbkb, sZbkb + ,Zbkc, sZbkc + ,Zbkx, sZbkx + ,Zknd, sZknd + ,Zkne, sZkne + ,Zknh, sZknh + ,Zksed, sZksed + ,Zksh, sZksh + ,Zkt, sZkt + ,Zvbb, sZvbb + ,Zvbc, sZvbc + ,Zvkb, sZvkb + ,Zvkg, sZvkg + ,Zvkned, sZvkned + ,Zvknha, sZvknha + ,Zvknhb, sZvknhb + ,Zvksed, sZvksed + ,Zvksh, sZvksh + ,Zvkt, sZvkt + ,Zfh, sZfh + ,Zfhmin, sZfhmin + ,Zihintntl, sZihintntl + ,Zvfh, sZvfh + ,Zvfhmin, sZvfhmin + ,Zfa, sZfa + ,Ztso, sZtso + ,Zacas, sZacas + ,Zicntr, sZicntr + ,Zicond, sZicond + ,Zihintpause, sZihintpause + ,Zihpm, sZihpm + ,Zve32x, sZve32x + ,Zve32f, sZve32f + ,Zve64x, sZve64x + ,Zve64f, sZve64f + ,Zve64d, sZve64d + ,Zimop, sZimop + ,Zca, sZca + ,Zcb, sZcb + ,Zcd, sZcd + ,Zcf, sZcf + ,Zcmop, sZcmop + ,Zawrs, sZawrs + ,Zaamo, sZaamo + ,Zalrsc, sZalrsc + ,Supm, sSupm + ,Zfbfmin, sZfbfmin + ,Zvfbfmin, sZvfbfmin + ,Zvfbfwma, sZvfbfwma + ,Zicbom, sZicbom + ,SBool(..) + ) where +import System.CPUFeatures.RISCV.Bool +import System.CPUFeatures.Util + +type family C :: Bool +type family V :: Bool +type family Zba :: Bool +type family Zbb :: Bool +type family Zbs :: Bool +type family Zicboz :: Bool +type family Zbc :: Bool +type family Zbkb :: Bool +type family Zbkc :: Bool +type family Zbkx :: Bool +type family Zknd :: Bool +type family Zkne :: Bool +type family Zknh :: Bool +type family Zksed :: Bool +type family Zksh :: Bool +type family Zkt :: Bool +type family Zvbb :: Bool +type family Zvbc :: Bool +type family Zvkb :: Bool +type family Zvkg :: Bool +type family Zvkned :: Bool +type family Zvknha :: Bool +type family Zvknhb :: Bool +type family Zvksed :: Bool +type family Zvksh :: Bool +type family Zvkt :: Bool +type family Zfh :: Bool +type family Zfhmin :: Bool +type family Zihintntl :: Bool +type family Zvfh :: Bool +type family Zvfhmin :: Bool +type family Zfa :: Bool +type family Ztso :: Bool +type family Zacas :: Bool +type family Zicntr :: Bool +type family Zicond :: Bool +type family Zihintpause :: Bool +type family Zihpm :: Bool +type family Zve32x :: Bool +type family Zve32f :: Bool +type family Zve64x :: Bool +type family Zve64f :: Bool +type family Zve64d :: Bool +type family Zimop :: Bool +type family Zca :: Bool +type family Zcb :: Bool +type family Zcd :: Bool +type family Zcf :: Bool +type family Zcmop :: Bool +type family Zawrs :: Bool +type family Zaamo :: Bool +type family Zalrsc :: Bool +type family Supm :: Bool +type family Zfbfmin :: Bool +type family Zvfbfmin :: Bool +type family Zvfbfwma :: Bool +type family Zicbom :: Bool + +sC :: SBool C +sC = unsafeBoolToSBool bC + +sV :: SBool V +sV = unsafeBoolToSBool bV + +sZba :: SBool Zba +sZba = unsafeBoolToSBool bZba + +sZbb :: SBool Zbb +sZbb = unsafeBoolToSBool bZbb + +sZbs :: SBool Zbs +sZbs = unsafeBoolToSBool bZbs + +sZicboz :: SBool Zicboz +sZicboz = unsafeBoolToSBool bZicboz + +sZbc :: SBool Zbc +sZbc = unsafeBoolToSBool bZbc + +sZbkb :: SBool Zbkb +sZbkb = unsafeBoolToSBool bZbkb + +sZbkc :: SBool Zbkc +sZbkc = unsafeBoolToSBool bZbkc + +sZbkx :: SBool Zbkx +sZbkx = unsafeBoolToSBool bZbkx + +sZknd :: SBool Zknd +sZknd = unsafeBoolToSBool bZknd + +sZkne :: SBool Zkne +sZkne = unsafeBoolToSBool bZkne + +sZknh :: SBool Zknh +sZknh = unsafeBoolToSBool bZknh + +sZksed :: SBool Zksed +sZksed = unsafeBoolToSBool bZksed + +sZksh :: SBool Zksh +sZksh = unsafeBoolToSBool bZksh + +sZkt :: SBool Zkt +sZkt = unsafeBoolToSBool bZkt + +sZvbb :: SBool Zvbb +sZvbb = unsafeBoolToSBool bZvbb + +sZvbc :: SBool Zvbc +sZvbc = unsafeBoolToSBool bZvbc + +sZvkb :: SBool Zvkb +sZvkb = unsafeBoolToSBool bZvkb + +sZvkg :: SBool Zvkg +sZvkg = unsafeBoolToSBool bZvkg + +sZvkned :: SBool Zvkned +sZvkned = unsafeBoolToSBool bZvkned + +sZvknha :: SBool Zvknha +sZvknha = unsafeBoolToSBool bZvknha + +sZvknhb :: SBool Zvknhb +sZvknhb = unsafeBoolToSBool bZvknhb + +sZvksed :: SBool Zvksed +sZvksed = unsafeBoolToSBool bZvksed + +sZvksh :: SBool Zvksh +sZvksh = unsafeBoolToSBool bZvksh + +sZvkt :: SBool Zvkt +sZvkt = unsafeBoolToSBool bZvkt + +sZfh :: SBool Zfh +sZfh = unsafeBoolToSBool bZfh + +sZfhmin :: SBool Zfhmin +sZfhmin = unsafeBoolToSBool bZfhmin + +sZihintntl :: SBool Zihintntl +sZihintntl = unsafeBoolToSBool bZihintntl + +sZvfh :: SBool Zvfh +sZvfh = unsafeBoolToSBool bZvfh + +sZvfhmin :: SBool Zvfhmin +sZvfhmin = unsafeBoolToSBool bZvfhmin + +sZfa :: SBool Zfa +sZfa = unsafeBoolToSBool bZfa + +sZtso :: SBool Ztso +sZtso = unsafeBoolToSBool bZtso + +sZacas :: SBool Zacas +sZacas = unsafeBoolToSBool bZacas + +sZicntr :: SBool Zicntr +sZicntr = unsafeBoolToSBool bZicntr + +sZicond :: SBool Zicond +sZicond = unsafeBoolToSBool bZicond + +sZihintpause :: SBool Zihintpause +sZihintpause = unsafeBoolToSBool bZihintpause + +sZihpm :: SBool Zihpm +sZihpm = unsafeBoolToSBool bZihpm + +sZve32x :: SBool Zve32x +sZve32x = unsafeBoolToSBool bZve32x + +sZve32f :: SBool Zve32f +sZve32f = unsafeBoolToSBool bZve32f + +sZve64x :: SBool Zve64x +sZve64x = unsafeBoolToSBool bZve64x + +sZve64f :: SBool Zve64f +sZve64f = unsafeBoolToSBool bZve64f + +sZve64d :: SBool Zve64d +sZve64d = unsafeBoolToSBool bZve64d + +sZimop :: SBool Zimop +sZimop = unsafeBoolToSBool bZimop + +sZca :: SBool Zca +sZca = unsafeBoolToSBool bZca + +sZcb :: SBool Zcb +sZcb = unsafeBoolToSBool bZcb + +sZcd :: SBool Zcd +sZcd = unsafeBoolToSBool bZcd + +sZcf :: SBool Zcf +sZcf = unsafeBoolToSBool bZcf + +sZcmop :: SBool Zcmop +sZcmop = unsafeBoolToSBool bZcmop + +sZawrs :: SBool Zawrs +sZawrs = unsafeBoolToSBool bZawrs + +sZaamo :: SBool Zaamo +sZaamo = unsafeBoolToSBool bZaamo + +sZalrsc :: SBool Zalrsc +sZalrsc = unsafeBoolToSBool bZalrsc + +sSupm :: SBool Supm +sSupm = unsafeBoolToSBool bSupm + +sZfbfmin :: SBool Zfbfmin +sZfbfmin = unsafeBoolToSBool bZfbfmin + +sZvfbfmin :: SBool Zvfbfmin +sZvfbfmin = unsafeBoolToSBool bZvfbfmin + +sZvfbfwma :: SBool Zvfbfwma +sZvfbfwma = unsafeBoolToSBool bZvfbfwma + +sZicbom :: SBool Zicbom +sZicbom = unsafeBoolToSBool bZicbom + diff --git a/src/System/CPUFeatures/Util.hs b/src/System/CPUFeatures/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/Util.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +module System.CPUFeatures.Util where +import Data.Kind +import Unsafe.Coerce + +type SBool :: Bool -> Type +data SBool x where + STrue :: SBool True + SFalse :: SBool False + +unsafeBoolToSBool :: Bool -> SBool a +unsafeBoolToSBool True = unsafeCoerce STrue +unsafeBoolToSBool False = unsafeCoerce SFalse + +type Dict :: Constraint -> Type +data Dict c = c => Dict diff --git a/src/System/CPUFeatures/X86.hs b/src/System/CPUFeatures/X86.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/X86.hs @@ -0,0 +1,4 @@ +module System.CPUFeatures.X86 + (module System.CPUFeatures.X86.Bool + ) where +import System.CPUFeatures.X86.Bool diff --git a/src/System/CPUFeatures/X86/Bool.hs b/src/System/CPUFeatures/X86/Bool.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/X86/Bool.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{- | +Description: Detect x86 features at runtime + +This module provides the basic interface to detect CPU features. +The availability is indicated by a boolean variable (@b\@). +-} +module System.CPUFeatures.X86.Bool + (bAESNI + ,bAMX_BF16 + ,bAMX_FP16 + ,bAMX_INT8 + ,bAMX_TILE + ,bAVX + ,bAVX_VNNI + ,bAVX10_1 + ,bAVX10_2 + ,bAVX2 + ,bAVX512_BF16 + ,bAVX512_BITALG + ,bAVX512_FP16 + ,bAVX512_IFMA + ,bAVX512_VBMI + ,bAVX512_VBMI2 + ,bAVX512_VNNI + ,bAVX512_VPOPCNTDQ + ,bAVX512BW + ,bAVX512CD + ,bAVX512DQ + ,bAVX512F + ,bAVX512VL + ,bBMI1 + ,bBMI2 + ,bF16C + ,bFMA + ,bGFNI + ,bPCLMULQDQ + ,bPOPCNT + ,bRDRAND + ,bSHA + ,bSSE3 + ,bSSE4_1 + ,bSSE4_2 + ,bSSSE3 + ,bVAES + ,bVPCLMULQDQ + ,mAVX10 + ) where +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) +import System.CPUFeatures.X86.Cpuid +import Data.Bits +-- import Data.Maybe (isJust) +#if defined(darwin_HOST_OS) +import GHC.Exts (Addr#) +#endif +#endif + +bAESNI :: Bool +bAMX_BF16 :: Bool +bAMX_FP16 :: Bool +bAMX_INT8 :: Bool +bAMX_TILE :: Bool +bAVX :: Bool +bAVX_VNNI :: Bool +bAVX10_1 :: Bool +bAVX10_2 :: Bool +bAVX2 :: Bool +bAVX512_BF16 :: Bool +bAVX512_BITALG :: Bool +bAVX512_FP16 :: Bool +bAVX512_IFMA :: Bool +bAVX512_VBMI :: Bool +bAVX512_VBMI2 :: Bool +bAVX512_VNNI :: Bool +bAVX512_VPOPCNTDQ :: Bool +bAVX512BW :: Bool +bAVX512CD :: Bool +bAVX512DQ :: Bool +bAVX512F :: Bool +bAVX512VL :: Bool +bBMI1 :: Bool +bBMI2 :: Bool +bF16C :: Bool +bFMA :: Bool +bGFNI :: Bool +bPCLMULQDQ :: Bool +bPOPCNT :: Bool +bRDRAND :: Bool +bSHA :: Bool +bSSE3 :: Bool +bSSE4_1 :: Bool +bSSE4_2 :: Bool +bSSSE3 :: Bool +bVAES :: Bool +bVPCLMULQDQ :: Bool + +mAVX10 :: Maybe Int + +#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) + +{-# NOINLINE cpuid_01 #-} +cpuid_01 :: CpuidResult +cpuid_01 = cpuid 0x1 0 + +{-# NOINLINE cpuid_07_0 #-} +cpuid_07_0 :: CpuidResult +cpuid_07_0 = cpuid 0x7 0 + +{-# NOINLINE cpuid_07_1 #-} +cpuid_07_1 :: CpuidResult +cpuid_07_1 = cpuid 0x7 1 + +{-# NOINLINE cpuid_24_0 #-} +cpuid_24_0 :: CpuidResult +cpuid_24_0 = cpuid 0x24 0 + +-- May be used by future AVX10 +-- {-# NOINLINE cpuid_24_1 #-} +-- cpuid_24_1 :: CpuidResult +-- cpuid_24_1 = cpuid 0x24 1 + +#if defined(darwin_HOST_OS) +foreign import ccall unsafe hs_cpu_features_sysctl :: Addr# -> Bool +#endif + +{-# NOINLINE mAVX10 #-} +mAVX10 | testBit (edx cpuid_07_1) 19 + , testBit (ecx cpuid_01) 27 -- OSXSAVE + , (xgetbv 0 .&. 0xe6) == 0xe6 -- opmask, upper ZMM[0-15], ZMM[16-31], XMM, YMM + , testBit (ebx cpuid_24_0) 17 -- AVX10/256 + = let !version = fromIntegral (ebx cpuid_24_0 .&. 0xff) + in Just version + | otherwise = Nothing + +bAESNI = testBit (ecx cpuid_01) 25 +bAMX_BF16 = testBit (edx cpuid_07_0) 22 +bAMX_FP16 = testBit (eax cpuid_07_1) 21 +bAMX_INT8 = testBit (edx cpuid_07_0) 25 +bAMX_TILE = testBit (edx cpuid_07_0) 24 +{-# NOINLINE bAVX #-} +bAVX = (ecx cpuid_01 .&. (bit 27 .|. bit 28)) == bit 27 .|. bit 28 && (xgetbv 0 .&. 6) == 6 -- bit 27: OSXSAVE, bit 28: AVX +bAVX_VNNI = testBit (eax cpuid_07_1) 4 +bAVX10_1 = mAVX10 >= Just 1 +bAVX10_2 = mAVX10 >= Just 2 +-- bAVX10_VL256 = isJust mAVX10 -- mAVX10 checks for VL256 +-- bAVX10_VL512 = isJust mAVX10 && testBit (ebx cpuid_24_0) 18 +bAVX2 = bAVX && testBit (ebx cpuid_07_0) 5 +bAVX512_BF16 = bAVX512F && testBit (eax cpuid_07_1) 5 +bAVX512_BITALG = bAVX512F && testBit (ecx cpuid_07_0) 12 +bAVX512_FP16 = bAVX512F && testBit (edx cpuid_07_0) 23 +bAVX512_IFMA = bAVX512F && testBit (ebx cpuid_07_0) 21 +bAVX512_VBMI = bAVX512F && testBit (ecx cpuid_07_0) 1 +bAVX512_VBMI2 = bAVX512F && testBit (ecx cpuid_07_0) 6 +bAVX512_VNNI = bAVX512F && testBit (ecx cpuid_07_0) 11 +-- bAVX512_VP2INTERSECT = bAVX512F && testBit (edx cpuid_07_0) 8 +bAVX512_VPOPCNTDQ = bAVX512F && testBit (ecx cpuid_07_0) 14 +bAVX512BW = bAVX512F && testBit (ebx cpuid_07_0) 30 +bAVX512CD = bAVX512F && testBit (ebx cpuid_07_0) 28 +bAVX512DQ = bAVX512F && testBit (ebx cpuid_07_0) 17 +{-# NOINLINE bAVX512F #-} +#if defined(darwin_HOST_OS) +bAVX512F = hs_cpu_features_sysctl "hw.optional.avx512f"# -- AVX-512 support on macOS is on-demand, that is, XCR0 is cleared by default. +#else +bAVX512F = testBit (ecx cpuid_01) 27 && (xgetbv 0 .&. 0xe6) == 0xe6 && testBit (ebx cpuid_07_0) 16 -- CPUID.1:ECX[bit 27]: OSXSAVE +#endif +bAVX512VL = testBit (ebx cpuid_07_0) 31 +bBMI1 = testBit (ebx cpuid_07_0) 3 +bBMI2 = testBit (ebx cpuid_07_0) 8 +bF16C = bAVX && testBit (ecx cpuid_01) 29 +bFMA = bAVX && testBit (ecx cpuid_01) 12 +bGFNI = testBit (ecx cpuid_07_0) 8 +bPCLMULQDQ = testBit (ecx cpuid_01) 1 +bPOPCNT = testBit (ecx cpuid_01) 23 +bRDRAND = testBit (ecx cpuid_01) 30 +bSHA = testBit (ebx cpuid_07_0) 29 +bSSE3 = testBit (ecx cpuid_01) 0 +bSSE4_1 = testBit (ecx cpuid_01) 19 +bSSE4_2 = testBit (ecx cpuid_01) 20 +bSSSE3 = testBit (ecx cpuid_01) 9 +bVAES = testBit (ecx cpuid_07_0) 9 +bVPCLMULQDQ = testBit (ecx cpuid_07_0) 10 + +#else + +{-# INLINE bAESNI #-} +bAESNI = False + +{-# INLINE bAMX_BF16 #-} +bAMX_BF16 = False + +{-# INLINE bAMX_FP16 #-} +bAMX_FP16 = False + +{-# INLINE bAMX_INT8 #-} +bAMX_INT8 = False + +{-# INLINE bAMX_TILE #-} +bAMX_TILE = False + +{-# INLINE bAVX #-} +bAVX = False + +{-# INLINE bAVX_VNNI #-} +bAVX_VNNI = False + +{-# INLINE bAVX10_1 #-} +bAVX10_1 = False + +{-# INLINE bAVX10_2 #-} +bAVX10_2 = False + +{-# INLINE bAVX2 #-} +bAVX2 = False + +{-# INLINE bAVX512_BF16 #-} +bAVX512_BF16 = False + +{-# INLINE bAVX512_BITALG #-} +bAVX512_BITALG = False + +{-# INLINE bAVX512_FP16 #-} +bAVX512_FP16 = False + +{-# INLINE bAVX512_IFMA #-} +bAVX512_IFMA = False + +{-# INLINE bAVX512_VBMI #-} +bAVX512_VBMI = False + +{-# INLINE bAVX512_VBMI2 #-} +bAVX512_VBMI2 = False + +{-# INLINE bAVX512_VNNI #-} +bAVX512_VNNI = False + +{-# INLINE bAVX512_VPOPCNTDQ #-} +bAVX512_VPOPCNTDQ = False + +{-# INLINE bAVX512BW #-} +bAVX512BW = False + +{-# INLINE bAVX512CD #-} +bAVX512CD = False + +{-# INLINE bAVX512DQ #-} +bAVX512DQ = False + +{-# INLINE bAVX512F #-} +bAVX512F = False + +{-# INLINE bAVX512VL #-} +bAVX512VL = False + +{-# INLINE bBMI1 #-} +bBMI1 = False + +{-# INLINE bBMI2 #-} +bBMI2 = False + +{-# INLINE bF16C #-} +bF16C = False + +{-# INLINE bFMA #-} +bFMA = False + +{-# INLINE bGFNI #-} +bGFNI = False + +{-# INLINE bPCLMULQDQ #-} +bPCLMULQDQ = False + +{-# INLINE bPOPCNT #-} +bPOPCNT = False + +{-# INLINE bRDRAND #-} +bRDRAND = False + +{-# INLINE bSHA #-} +bSHA = False + +{-# INLINE bSSE3 #-} +bSSE3 = False + +{-# INLINE bSSE4_1 #-} +bSSE4_1 = False + +{-# INLINE bSSE4_2 #-} +bSSE4_2 = False + +{-# INLINE bSSSE3 #-} +bSSSE3 = False + +{-# INLINE bVAES #-} +bVAES = False + +{-# INLINE bVPCLMULQDQ #-} +bVPCLMULQDQ = False + +{-# INLINE mAVX10 #-} +mAVX10 = Nothing + +#endif diff --git a/src/System/CPUFeatures/X86/Constraint.hs b/src/System/CPUFeatures/X86/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/X86/Constraint.hs @@ -0,0 +1,60 @@ +{- | +Description: x86 features as nullary constraints + +This module provides the constraint interface to detect CPU features. +You can mark your function with @Has\ =>@ to indicate that +it requires a specific CPU feature. +You can detect the availability and get the constraint @Has\@ +by pattern-matching on the variable @query\@. + +Example: + +> -- This function requires AVX2 +> someFunction :: HasAVX2 => ... +> +> case queryAVX2 of +> Just Dict -> {- In this branch, HasAVX2 is available -} someFunction +> Nothing -> {- In this branch, HasAVX2 is not available -} error "AVX2 not available" +-} +module System.CPUFeatures.X86.Constraint + (HasAESNI, queryAESNI + ,HasAMX_BF16, queryAMX_BF16 + ,HasAMX_FP16, queryAMX_FP16 + ,HasAMX_INT8, queryAMX_INT8 + ,HasAMX_TILE, queryAMX_TILE + ,HasAVX, queryAVX + ,HasAVX_VNNI, queryAVX_VNNI + ,HasAVX10_1, queryAVX10_1 + ,HasAVX10_2, queryAVX10_2 + ,HasAVX2, queryAVX2 + ,HasAVX512_BF16, queryAVX512_BF16 + ,HasAVX512_BITALG, queryAVX512_BITALG + ,HasAVX512_FP16, queryAVX512_FP16 + ,HasAVX512_IFMA, queryAVX512_IFMA + ,HasAVX512_VBMI, queryAVX512_VBMI + ,HasAVX512_VBMI2, queryAVX512_VBMI2 + ,HasAVX512_VNNI, queryAVX512_VNNI + ,HasAVX512_VPOPCNTDQ, queryAVX512_VPOPCNTDQ + ,HasAVX512BW, queryAVX512BW + ,HasAVX512CD, queryAVX512CD + ,HasAVX512DQ, queryAVX512DQ + ,HasAVX512F, queryAVX512F + ,HasAVX512VL, queryAVX512VL + ,HasBMI1, queryBMI1 + ,HasBMI2, queryBMI2 + ,HasF16C, queryF16C + ,HasFMA, queryFMA + ,HasGFNI, queryGFNI + ,HasPCLMULQDQ, queryPCLMULQDQ + ,HasPOPCNT, queryPOPCNT + ,HasRDRAND, queryRDRAND + ,HasSHA, querySHA + ,HasSSE3, querySSE3 + ,HasSSE4_1, querySSE4_1 + ,HasSSE4_2, querySSE4_2 + ,HasSSSE3, querySSSE3 + ,HasVAES, queryVAES + ,HasVPCLMULQDQ, queryVPCLMULQDQ + ,Dict(Dict) + ) where +import System.CPUFeatures.X86.Constraint.Unsafe diff --git a/src/System/CPUFeatures/X86/Constraint/Unsafe.hs b/src/System/CPUFeatures/X86/Constraint/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/X86/Constraint/Unsafe.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module System.CPUFeatures.X86.Constraint.Unsafe + ( module System.CPUFeatures.X86.Constraint.Unsafe + , Dict (Dict) + ) where +import Data.Type.Equality ((:~:)(Refl)) +import System.CPUFeatures.Util +import System.CPUFeatures.X86.TypeBool +import Unsafe.Coerce (unsafeCoerce) + +class AESNI ~ True => HasAESNI +instance AESNI ~ True => HasAESNI + +class BMI1 ~ True => HasBMI1 +instance BMI1 ~ True => HasBMI1 + +class BMI2 ~ True => HasBMI2 +instance BMI2 ~ True => HasBMI2 + +class GFNI ~ True => HasGFNI +instance GFNI ~ True => HasGFNI + +class PCLMULQDQ ~ True => HasPCLMULQDQ +instance PCLMULQDQ ~ True => HasPCLMULQDQ + +class POPCNT ~ True => HasPOPCNT +instance POPCNT ~ True => HasPOPCNT + +class RDRAND ~ True => HasRDRAND +instance RDRAND ~ True => HasRDRAND + +class SHA ~ True => HasSHA +instance SHA ~ True => HasSHA + +class SSE3 ~ True => HasSSE3 +instance SSE3 ~ True => HasSSE3 + +class (SSSE3 ~ True, HasSSE3) => HasSSSE3 +instance (SSSE3 ~ True, HasSSE3) => HasSSSE3 + +class (SSE4_1 ~ True, HasSSSE3) => HasSSE4_1 +instance (SSE4_1 ~ True, HasSSSE3) => HasSSE4_1 + +class (SSE4_2 ~ True, HasSSE4_1) => HasSSE4_2 +instance (SSE4_2 ~ True, HasSSE4_1) => HasSSE4_2 + +class (AVX ~ True, HasSSE4_2) => HasAVX +instance (AVX ~ True, HasSSE4_2) => HasAVX + +class (AVX2 ~ True, HasAVX) => HasAVX2 +instance (AVX2 ~ True, HasAVX) => HasAVX2 + +class (F16C ~ True, HasAVX) => HasF16C +instance (F16C ~ True, HasAVX) => HasF16C + +class (FMA ~ True, HasAVX) => HasFMA +instance (FMA ~ True, HasAVX) => HasFMA + +class (AVX_VNNI ~ True, HasAVX2) => HasAVX_VNNI +instance (AVX_VNNI ~ True, HasAVX2) => HasAVX_VNNI + +class (AVX512F ~ True, HasAVX2, HasF16C, HasFMA) => HasAVX512F +instance (AVX512F ~ True, HasAVX2, HasF16C, HasFMA) => HasAVX512F + +class (AVX512VL ~ True, HasAVX512F) => HasAVX512VL +instance (AVX512VL ~ True, HasAVX512F) => HasAVX512VL + +class (AVX512BW ~ True, HasAVX512F) => HasAVX512BW +instance (AVX512BW ~ True, HasAVX512F) => HasAVX512BW + +class (AVX512DQ ~ True, HasAVX512F) => HasAVX512DQ +instance (AVX512DQ ~ True, HasAVX512F) => HasAVX512DQ + +class (AVX512CD ~ True, HasAVX512F) => HasAVX512CD +instance (AVX512CD ~ True, HasAVX512F) => HasAVX512CD + +class (AVX512_BF16 ~ True, HasAVX512BW) => HasAVX512_BF16 +instance (AVX512_BF16 ~ True, HasAVX512BW) => HasAVX512_BF16 + +class (AVX512_BITALG ~ True, HasAVX512BW) => HasAVX512_BITALG +instance (AVX512_BITALG ~ True, HasAVX512BW) => HasAVX512_BITALG + +class (AVX512_FP16 ~ True, HasAVX512BW) => HasAVX512_FP16 +instance (AVX512_FP16 ~ True, HasAVX512BW) => HasAVX512_FP16 + +class (AVX512_IFMA ~ True, HasAVX512F) => HasAVX512_IFMA +instance (AVX512_IFMA ~ True, HasAVX512F) => HasAVX512_IFMA + +class (AVX512_VBMI ~ True, HasAVX512BW) => HasAVX512_VBMI +instance (AVX512_VBMI ~ True, HasAVX512BW) => HasAVX512_VBMI + +class (AVX512_VBMI2 ~ True, HasAVX512BW) => HasAVX512_VBMI2 +instance (AVX512_VBMI2 ~ True, HasAVX512BW) => HasAVX512_VBMI2 + +class (AVX512_VNNI ~ True, HasAVX512F) => HasAVX512_VNNI +instance (AVX512_VNNI ~ True, HasAVX512F) => HasAVX512_VNNI + +class (AVX512_VPOPCNTDQ ~ True, HasAVX512F) => HasAVX512_VPOPCNTDQ +instance (AVX512_VPOPCNTDQ ~ True, HasAVX512F) => HasAVX512_VPOPCNTDQ + +class (AVX10_1 ~ True, HasAVX2, HasF16C, HasFMA) => HasAVX10_1 +instance (AVX10_1 ~ True, HasAVX2, HasF16C, HasFMA) => HasAVX10_1 + +class (AVX10_2 ~ True, HasAVX10_1) => HasAVX10_2 +instance (AVX10_2 ~ True, HasAVX10_1) => HasAVX10_2 + +class (VAES ~ True, HasAVX2, HasAESNI) => HasVAES +instance (VAES ~ True, HasAVX2, HasAESNI) => HasVAES + +class (VPCLMULQDQ ~ True, HasAVX, HasPCLMULQDQ) => HasVPCLMULQDQ +instance (VPCLMULQDQ ~ True, HasAVX, HasPCLMULQDQ) => HasVPCLMULQDQ + +class AMX_TILE ~ True => HasAMX_TILE +instance AMX_TILE ~ True => HasAMX_TILE + +class (AMX_BF16 ~ True, HasAMX_TILE) => HasAMX_BF16 +instance (AMX_BF16 ~ True, HasAMX_TILE) => HasAMX_BF16 + +class (AMX_FP16 ~ True, HasAMX_TILE) => HasAMX_FP16 +instance (AMX_FP16 ~ True, HasAMX_TILE) => HasAMX_FP16 + +class (AMX_INT8 ~ True, HasAMX_TILE) => HasAMX_INT8 +instance (AMX_INT8 ~ True, HasAMX_TILE) => HasAMX_INT8 + +unsafeAssumeAESNI :: (HasAESNI => a) -> a +unsafeAssumeAESNI k = case unsafeCoerce Refl :: AESNI :~: True of Refl -> k + +queryAESNI :: Maybe (Dict HasAESNI) +queryAESNI = case sAESNI of STrue -> unsafeAssumeAESNI (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAESNI #-} + +unsafeAssumeBMI1 :: (HasBMI1 => a) -> a +unsafeAssumeBMI1 k = case unsafeCoerce Refl :: BMI1 :~: True of Refl -> k + +queryBMI1 :: Maybe (Dict HasBMI1) +queryBMI1 = case sBMI1 of STrue -> unsafeAssumeBMI1 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryBMI1 #-} + +unsafeAssumeBMI2 :: (HasBMI2 => a) -> a +unsafeAssumeBMI2 k = case unsafeCoerce Refl :: BMI2 :~: True of Refl -> k + +queryBMI2 :: Maybe (Dict HasBMI2) +queryBMI2 = case sBMI2 of STrue -> unsafeAssumeBMI2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryBMI2 #-} + +unsafeAssumeGFNI :: (HasGFNI => a) -> a +unsafeAssumeGFNI k = case unsafeCoerce Refl :: GFNI :~: True of Refl -> k + +queryGFNI :: Maybe (Dict HasGFNI) +queryGFNI = case sGFNI of STrue -> unsafeAssumeGFNI (Just Dict); SFalse -> Nothing +{-# NOINLINE queryGFNI #-} + +unsafeAssumePCLMULQDQ :: (HasPCLMULQDQ => a) -> a +unsafeAssumePCLMULQDQ k = case unsafeCoerce Refl :: PCLMULQDQ :~: True of Refl -> k + +queryPCLMULQDQ :: Maybe (Dict HasPCLMULQDQ) +queryPCLMULQDQ = case sPCLMULQDQ of STrue -> unsafeAssumePCLMULQDQ (Just Dict); SFalse -> Nothing +{-# NOINLINE queryPCLMULQDQ #-} + +unsafeAssumePOPCNT :: (HasPOPCNT => a) -> a +unsafeAssumePOPCNT k = case unsafeCoerce Refl :: POPCNT :~: True of Refl -> k + +queryPOPCNT :: Maybe (Dict HasPOPCNT) +queryPOPCNT = case sPOPCNT of STrue -> unsafeAssumePOPCNT (Just Dict); SFalse -> Nothing +{-# NOINLINE queryPOPCNT #-} + +unsafeAssumeRDRAND :: (HasRDRAND => a) -> a +unsafeAssumeRDRAND k = case unsafeCoerce Refl :: RDRAND :~: True of Refl -> k + +queryRDRAND :: Maybe (Dict HasRDRAND) +queryRDRAND = case sRDRAND of STrue -> unsafeAssumeRDRAND (Just Dict); SFalse -> Nothing +{-# NOINLINE queryRDRAND #-} + +unsafeAssumeSHA :: (HasSHA => a) -> a +unsafeAssumeSHA k = case unsafeCoerce Refl :: SHA :~: True of Refl -> k + +querySHA :: Maybe (Dict HasSHA) +querySHA = case sSHA of STrue -> unsafeAssumeSHA (Just Dict); SFalse -> Nothing +{-# NOINLINE querySHA #-} + +unsafeAssumeSSE3 :: (HasSSE3 => a) -> a +unsafeAssumeSSE3 k = case unsafeCoerce Refl :: SSE3 :~: True of Refl -> k + +querySSE3 :: Maybe (Dict HasSSE3) +querySSE3 = case sSSE3 of STrue -> unsafeAssumeSSE3 (Just Dict); SFalse -> Nothing +{-# NOINLINE querySSE3 #-} + +unsafeAssumeSSSE3 :: (HasSSSE3 => a) -> a +unsafeAssumeSSSE3 k = case unsafeCoerce Refl :: SSSE3 :~: True of Refl -> unsafeAssumeSSE3 k + +querySSSE3 :: Maybe (Dict HasSSSE3) +querySSSE3 = case sSSSE3 of STrue -> unsafeAssumeSSSE3 (Just Dict); SFalse -> Nothing +{-# NOINLINE querySSSE3 #-} + +unsafeAssumeSSE4_1 :: (HasSSE4_1 => a) -> a +unsafeAssumeSSE4_1 k = case unsafeCoerce Refl :: SSE4_1 :~: True of Refl -> unsafeAssumeSSSE3 k + +querySSE4_1 :: Maybe (Dict HasSSE4_1) +querySSE4_1 = case sSSE4_1 of STrue -> unsafeAssumeSSE4_1 (Just Dict); SFalse -> Nothing +{-# NOINLINE querySSE4_1 #-} + +unsafeAssumeSSE4_2 :: (HasSSE4_2 => a) -> a +unsafeAssumeSSE4_2 k = case unsafeCoerce Refl :: SSE4_2 :~: True of Refl -> unsafeAssumeSSE4_1 k + +querySSE4_2 :: Maybe (Dict HasSSE4_2) +querySSE4_2 = case sSSE4_2 of STrue -> unsafeAssumeSSE4_2 (Just Dict); SFalse -> Nothing +{-# NOINLINE querySSE4_2 #-} + +unsafeAssumeAVX :: (HasAVX => a) -> a +unsafeAssumeAVX k = case unsafeCoerce Refl :: AVX :~: True of Refl -> unsafeAssumeSSE4_2 k + +queryAVX :: Maybe (Dict HasAVX) +queryAVX = case sAVX of STrue -> unsafeAssumeAVX (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX #-} + +unsafeAssumeAVX2 :: (HasAVX2 => a) -> a +unsafeAssumeAVX2 k = case unsafeCoerce Refl :: AVX2 :~: True of Refl -> unsafeAssumeAVX k + +queryAVX2 :: Maybe (Dict HasAVX2) +queryAVX2 = case sAVX2 of STrue -> unsafeAssumeAVX2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX2 #-} + +unsafeAssumeF16C :: (HasF16C => a) -> a +unsafeAssumeF16C k = case unsafeCoerce Refl :: F16C :~: True of Refl -> unsafeAssumeAVX k + +queryF16C :: Maybe (Dict HasF16C) +queryF16C = case sF16C of STrue -> unsafeAssumeF16C (Just Dict); SFalse -> Nothing +{-# NOINLINE queryF16C #-} + +unsafeAssumeFMA :: (HasFMA => a) -> a +unsafeAssumeFMA k = case unsafeCoerce Refl :: FMA :~: True of Refl -> unsafeAssumeAVX k + +queryFMA :: Maybe (Dict HasFMA) +queryFMA = case sFMA of STrue -> unsafeAssumeFMA (Just Dict); SFalse -> Nothing +{-# NOINLINE queryFMA #-} + +unsafeAssumeAVX_VNNI :: (HasAVX_VNNI => a) -> a +unsafeAssumeAVX_VNNI k = case unsafeCoerce Refl :: AVX_VNNI :~: True of Refl -> unsafeAssumeAVX2 k + +queryAVX_VNNI :: Maybe (Dict HasAVX_VNNI) +queryAVX_VNNI = case sAVX_VNNI of STrue -> unsafeAssumeAVX_VNNI (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX_VNNI #-} + +unsafeAssumeAVX512F :: (HasAVX512F => a) -> a +unsafeAssumeAVX512F k = case unsafeCoerce Refl :: AVX512F :~: True of Refl -> unsafeAssumeFMA (unsafeAssumeF16C (unsafeAssumeAVX2 k)) + +queryAVX512F :: Maybe (Dict HasAVX512F) +queryAVX512F = case sAVX512F of STrue -> unsafeAssumeAVX512F (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512F #-} + +unsafeAssumeAVX512VL :: (HasAVX512VL => a) -> a +unsafeAssumeAVX512VL k = case unsafeCoerce Refl :: AVX512VL :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512VL :: Maybe (Dict HasAVX512VL) +queryAVX512VL = case sAVX512VL of STrue -> unsafeAssumeAVX512VL (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512VL #-} + +unsafeAssumeAVX512BW :: (HasAVX512BW => a) -> a +unsafeAssumeAVX512BW k = case unsafeCoerce Refl :: AVX512BW :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512BW :: Maybe (Dict HasAVX512BW) +queryAVX512BW = case sAVX512BW of STrue -> unsafeAssumeAVX512BW (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512BW #-} + +unsafeAssumeAVX512DQ :: (HasAVX512DQ => a) -> a +unsafeAssumeAVX512DQ k = case unsafeCoerce Refl :: AVX512DQ :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512DQ :: Maybe (Dict HasAVX512DQ) +queryAVX512DQ = case sAVX512DQ of STrue -> unsafeAssumeAVX512DQ (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512DQ #-} + +unsafeAssumeAVX512CD :: (HasAVX512CD => a) -> a +unsafeAssumeAVX512CD k = case unsafeCoerce Refl :: AVX512CD :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512CD :: Maybe (Dict HasAVX512CD) +queryAVX512CD = case sAVX512CD of STrue -> unsafeAssumeAVX512CD (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512CD #-} + +unsafeAssumeAVX512_BF16 :: (HasAVX512_BF16 => a) -> a +unsafeAssumeAVX512_BF16 k = case unsafeCoerce Refl :: AVX512_BF16 :~: True of Refl -> unsafeAssumeAVX512BW k + +queryAVX512_BF16 :: Maybe (Dict HasAVX512_BF16) +queryAVX512_BF16 = case sAVX512_BF16 of STrue -> unsafeAssumeAVX512_BF16 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_BF16 #-} + +unsafeAssumeAVX512_BITALG :: (HasAVX512_BITALG => a) -> a +unsafeAssumeAVX512_BITALG k = case unsafeCoerce Refl :: AVX512_BITALG :~: True of Refl -> unsafeAssumeAVX512BW k + +queryAVX512_BITALG :: Maybe (Dict HasAVX512_BITALG) +queryAVX512_BITALG = case sAVX512_BITALG of STrue -> unsafeAssumeAVX512_BITALG (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_BITALG #-} + +unsafeAssumeAVX512_FP16 :: (HasAVX512_FP16 => a) -> a +unsafeAssumeAVX512_FP16 k = case unsafeCoerce Refl :: AVX512_FP16 :~: True of Refl -> unsafeAssumeAVX512BW k + +queryAVX512_FP16 :: Maybe (Dict HasAVX512_FP16) +queryAVX512_FP16 = case sAVX512_FP16 of STrue -> unsafeAssumeAVX512_FP16 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_FP16 #-} + +unsafeAssumeAVX512_IFMA :: (HasAVX512_IFMA => a) -> a +unsafeAssumeAVX512_IFMA k = case unsafeCoerce Refl :: AVX512_IFMA :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512_IFMA :: Maybe (Dict HasAVX512_IFMA) +queryAVX512_IFMA = case sAVX512_IFMA of STrue -> unsafeAssumeAVX512_IFMA (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_IFMA #-} + +unsafeAssumeAVX512_VBMI :: (HasAVX512_VBMI => a) -> a +unsafeAssumeAVX512_VBMI k = case unsafeCoerce Refl :: AVX512_VBMI :~: True of Refl -> unsafeAssumeAVX512BW k + +queryAVX512_VBMI :: Maybe (Dict HasAVX512_VBMI) +queryAVX512_VBMI = case sAVX512_VBMI of STrue -> unsafeAssumeAVX512_VBMI (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_VBMI #-} + +unsafeAssumeAVX512_VBMI2 :: (HasAVX512_VBMI2 => a) -> a +unsafeAssumeAVX512_VBMI2 k = case unsafeCoerce Refl :: AVX512_VBMI2 :~: True of Refl -> unsafeAssumeAVX512BW k + +queryAVX512_VBMI2 :: Maybe (Dict HasAVX512_VBMI2) +queryAVX512_VBMI2 = case sAVX512_VBMI2 of STrue -> unsafeAssumeAVX512_VBMI2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_VBMI2 #-} + +unsafeAssumeAVX512_VNNI :: (HasAVX512_VNNI => a) -> a +unsafeAssumeAVX512_VNNI k = case unsafeCoerce Refl :: AVX512_VNNI :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512_VNNI :: Maybe (Dict HasAVX512_VNNI) +queryAVX512_VNNI = case sAVX512_VNNI of STrue -> unsafeAssumeAVX512_VNNI (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_VNNI #-} + +unsafeAssumeAVX512_VPOPCNTDQ :: (HasAVX512_VPOPCNTDQ => a) -> a +unsafeAssumeAVX512_VPOPCNTDQ k = case unsafeCoerce Refl :: AVX512_VPOPCNTDQ :~: True of Refl -> unsafeAssumeAVX512F k + +queryAVX512_VPOPCNTDQ :: Maybe (Dict HasAVX512_VPOPCNTDQ) +queryAVX512_VPOPCNTDQ = case sAVX512_VPOPCNTDQ of STrue -> unsafeAssumeAVX512_VPOPCNTDQ (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX512_VPOPCNTDQ #-} + +unsafeAssumeAVX10_1 :: (HasAVX10_1 => a) -> a +unsafeAssumeAVX10_1 k = case unsafeCoerce Refl :: AVX10_1 :~: True of Refl -> unsafeAssumeFMA (unsafeAssumeF16C (unsafeAssumeAVX2 k)) + +queryAVX10_1 :: Maybe (Dict HasAVX10_1) +queryAVX10_1 = case sAVX10_1 of STrue -> unsafeAssumeAVX10_1 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX10_1 #-} + +unsafeAssumeAVX10_2 :: (HasAVX10_2 => a) -> a +unsafeAssumeAVX10_2 k = case unsafeCoerce Refl :: AVX10_2 :~: True of Refl -> unsafeAssumeAVX10_1 k + +queryAVX10_2 :: Maybe (Dict HasAVX10_2) +queryAVX10_2 = case sAVX10_2 of STrue -> unsafeAssumeAVX10_2 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAVX10_2 #-} + +unsafeAssumeVAES :: (HasVAES => a) -> a +unsafeAssumeVAES k = case unsafeCoerce Refl :: VAES :~: True of Refl -> unsafeAssumeAESNI (unsafeAssumeAVX2 k) + +queryVAES :: Maybe (Dict HasVAES) +queryVAES = case sVAES of STrue -> unsafeAssumeVAES (Just Dict); SFalse -> Nothing +{-# NOINLINE queryVAES #-} + +unsafeAssumeVPCLMULQDQ :: (HasVPCLMULQDQ => a) -> a +unsafeAssumeVPCLMULQDQ k = case unsafeCoerce Refl :: VPCLMULQDQ :~: True of Refl -> unsafeAssumePCLMULQDQ (unsafeAssumeAVX k) + +queryVPCLMULQDQ :: Maybe (Dict HasVPCLMULQDQ) +queryVPCLMULQDQ = case sVPCLMULQDQ of STrue -> unsafeAssumeVPCLMULQDQ (Just Dict); SFalse -> Nothing +{-# NOINLINE queryVPCLMULQDQ #-} + +unsafeAssumeAMX_TILE :: (HasAMX_TILE => a) -> a +unsafeAssumeAMX_TILE k = case unsafeCoerce Refl :: AMX_TILE :~: True of Refl -> k + +queryAMX_TILE :: Maybe (Dict HasAMX_TILE) +queryAMX_TILE = case sAMX_TILE of STrue -> unsafeAssumeAMX_TILE (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAMX_TILE #-} + +unsafeAssumeAMX_BF16 :: (HasAMX_BF16 => a) -> a +unsafeAssumeAMX_BF16 k = case unsafeCoerce Refl :: AMX_BF16 :~: True of Refl -> unsafeAssumeAMX_TILE k + +queryAMX_BF16 :: Maybe (Dict HasAMX_BF16) +queryAMX_BF16 = case sAMX_BF16 of STrue -> unsafeAssumeAMX_BF16 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAMX_BF16 #-} + +unsafeAssumeAMX_FP16 :: (HasAMX_FP16 => a) -> a +unsafeAssumeAMX_FP16 k = case unsafeCoerce Refl :: AMX_FP16 :~: True of Refl -> unsafeAssumeAMX_TILE k + +queryAMX_FP16 :: Maybe (Dict HasAMX_FP16) +queryAMX_FP16 = case sAMX_FP16 of STrue -> unsafeAssumeAMX_FP16 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAMX_FP16 #-} + +unsafeAssumeAMX_INT8 :: (HasAMX_INT8 => a) -> a +unsafeAssumeAMX_INT8 k = case unsafeCoerce Refl :: AMX_INT8 :~: True of Refl -> unsafeAssumeAMX_TILE k + +queryAMX_INT8 :: Maybe (Dict HasAMX_INT8) +queryAMX_INT8 = case sAMX_INT8 of STrue -> unsafeAssumeAMX_INT8 (Just Dict); SFalse -> Nothing +{-# NOINLINE queryAMX_INT8 #-} diff --git a/src/System/CPUFeatures/X86/Cpuid.hs b/src/System/CPUFeatures/X86/Cpuid.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/X86/Cpuid.hs @@ -0,0 +1,62 @@ +{-# 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 { eax :: !Word32, ebx :: !Word32, ecx :: !Word32, edx :: !Word32 } deriving 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 X86Cpuid where + cpuid !initialEax !initialEcx = unsafePerformIO $ allocaBytes (4 * 4) $ \ptr -> do + hs_cpu_features_cpuid initialEax initialEcx ptr + a <- peek ptr + b <- peekElemOff ptr 1 + c <- peekElemOff ptr 2 + d <- peekElemOff ptr 3 + pure $ CpuidResult a b c d + xgetbv = hs_cpu_features_xgetbv + +queryCpuid = Just Dict + +getManufacturerString = case cpuid 0 0 of + CpuidResult _ b c d -> wordToChars b $ wordToChars d $ wordToChars c "" + where + bchr = chr . fromIntegral + wordToChars x s = bchr (fromIntegral $ x .&. 0xFF) : bchr ((x `unsafeShiftR` 8) .&. 0xFF) : bchr ((x `unsafeShiftR` 16) .&. 0xFF) : bchr ((x `unsafeShiftR` 24) .&. 0xFF) : s + +#else + +queryCpuid = Nothing +getManufacturerString = undefined + +#endif diff --git a/src/System/CPUFeatures/X86/TypeBool.hs b/src/System/CPUFeatures/X86/TypeBool.hs new file mode 100644 --- /dev/null +++ b/src/System/CPUFeatures/X86/TypeBool.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{- | +Description: x86 features as type-level booleans + +This module provides the type-level interface to detect CPU features. +You can mark your function with @\ ~ True =>@ to indicate that +it requires a specific CPU feature. +You can detect the availability and get the constraint @\ ~ True@ +by pattern-matching on the variable @s\@. + +Example: + +> -- This function requires AVX2 +> someFunction :: AVX2 ~ True => ... +> +> case sAVX2 of +> STrue -> {- In this branch, AVX2 is True -} someFunction +> SFalse -> {- In this branch, AVX2 is False -} error "AVX2 not available" +-} +module System.CPUFeatures.X86.TypeBool + (AESNI, sAESNI + ,AMX_BF16, sAMX_BF16 + ,AMX_FP16, sAMX_FP16 + ,AMX_INT8, sAMX_INT8 + ,AMX_TILE, sAMX_TILE + ,AVX, sAVX + ,AVX_VNNI, sAVX_VNNI + ,AVX10_1, sAVX10_1 + ,AVX10_2, sAVX10_2 + ,AVX2, sAVX2 + ,AVX512_BF16, sAVX512_BF16 + ,AVX512_BITALG, sAVX512_BITALG + ,AVX512_FP16, sAVX512_FP16 + ,AVX512_IFMA, sAVX512_IFMA + ,AVX512_VBMI, sAVX512_VBMI + ,AVX512_VBMI2, sAVX512_VBMI2 + ,AVX512_VNNI, sAVX512_VNNI + ,AVX512_VPOPCNTDQ, sAVX512_VPOPCNTDQ + ,AVX512BW, sAVX512BW + ,AVX512CD, sAVX512CD + ,AVX512DQ, sAVX512DQ + ,AVX512F, sAVX512F + ,AVX512VL, sAVX512VL + ,BMI1, sBMI1 + ,BMI2, sBMI2 + ,F16C, sF16C + ,FMA, sFMA + ,GFNI, sGFNI + ,PCLMULQDQ, sPCLMULQDQ + ,POPCNT, sPOPCNT + ,RDRAND, sRDRAND + ,SHA, sSHA + ,SSE3, sSSE3 + ,SSE4_1, sSSE4_1 + ,SSE4_2, sSSE4_2 + ,SSSE3, sSSSE3 + ,VAES, sVAES + ,VPCLMULQDQ, sVPCLMULQDQ + ,SBool(..) + ) where +import System.CPUFeatures.X86.Bool +import System.CPUFeatures.Util + +type family AESNI :: Bool +type family AMX_BF16 :: Bool +type family AMX_FP16 :: Bool +type family AMX_INT8 :: Bool +type family AMX_TILE :: Bool +type family AVX :: Bool +type family AVX_VNNI :: Bool +type family AVX10_1 :: Bool +type family AVX10_2 :: Bool +type family AVX2 :: Bool +type family AVX512_BF16 :: Bool +type family AVX512_BITALG :: Bool +type family AVX512_FP16 :: Bool +type family AVX512_IFMA :: Bool +type family AVX512_VBMI :: Bool +type family AVX512_VBMI2 :: Bool +type family AVX512_VNNI :: Bool +type family AVX512_VPOPCNTDQ :: Bool +type family AVX512BW :: Bool +type family AVX512CD :: Bool +type family AVX512DQ :: Bool +type family AVX512F :: Bool +type family AVX512VL :: Bool +type family BMI1 :: Bool +type family BMI2 :: Bool +type family F16C :: Bool +type family FMA :: Bool +type family GFNI :: Bool +type family PCLMULQDQ :: Bool +type family POPCNT :: Bool +type family RDRAND :: Bool +type family SHA :: Bool +type family SSE3 :: Bool +type family SSE4_1 :: Bool +type family SSE4_2 :: Bool +type family SSSE3 :: Bool +type family VAES :: Bool +type family VPCLMULQDQ :: Bool + +sAESNI :: SBool AESNI +sAMX_BF16 :: SBool AMX_BF16 +sAMX_FP16 :: SBool AMX_FP16 +sAMX_INT8 :: SBool AMX_INT8 +sAMX_TILE :: SBool AMX_TILE +sAVX :: SBool AVX +sAVX_VNNI :: SBool AVX_VNNI +sAVX10_1 :: SBool AVX10_1 +sAVX10_2 :: SBool AVX10_2 +sAVX2 :: SBool AVX2 +sAVX512_BF16 :: SBool AVX512_BF16 +sAVX512_BITALG :: SBool AVX512_BITALG +sAVX512_FP16 :: SBool AVX512_FP16 +sAVX512_IFMA :: SBool AVX512_IFMA +sAVX512_VBMI :: SBool AVX512_VBMI +sAVX512_VBMI2 :: SBool AVX512_VBMI2 +sAVX512_VNNI :: SBool AVX512_VNNI +sAVX512_VPOPCNTDQ :: SBool AVX512_VPOPCNTDQ +sAVX512BW :: SBool AVX512BW +sAVX512CD :: SBool AVX512CD +sAVX512DQ :: SBool AVX512DQ +sAVX512F :: SBool AVX512F +sAVX512VL :: SBool AVX512VL +sBMI1 :: SBool BMI1 +sBMI2 :: SBool BMI2 +sF16C :: SBool F16C +sFMA :: SBool FMA +sGFNI :: SBool GFNI +sPCLMULQDQ :: SBool PCLMULQDQ +sPOPCNT :: SBool POPCNT +sRDRAND :: SBool RDRAND +sSHA :: SBool SHA +sSSE3 :: SBool SSE3 +sSSE4_1 :: SBool SSE4_1 +sSSE4_2 :: SBool SSE4_2 +sSSSE3 :: SBool SSSE3 +sVAES :: SBool VAES +sVPCLMULQDQ :: SBool VPCLMULQDQ + +sAESNI = unsafeBoolToSBool bAESNI +sAMX_BF16 = unsafeBoolToSBool bAMX_BF16 +sAMX_FP16 = unsafeBoolToSBool bAMX_FP16 +sAMX_INT8 = unsafeBoolToSBool bAMX_INT8 +sAMX_TILE = unsafeBoolToSBool bAMX_TILE +sAVX = unsafeBoolToSBool bAVX +sAVX_VNNI = unsafeBoolToSBool bAVX_VNNI +sAVX10_1 = unsafeBoolToSBool bAVX10_1 +sAVX10_2 = unsafeBoolToSBool bAVX10_2 +sAVX2 = unsafeBoolToSBool bAVX2 +sAVX512_BF16 = unsafeBoolToSBool bAVX512_BF16 +sAVX512_BITALG = unsafeBoolToSBool bAVX512_BITALG +sAVX512_FP16 = unsafeBoolToSBool bAVX512_FP16 +sAVX512_IFMA = unsafeBoolToSBool bAVX512_IFMA +sAVX512_VBMI = unsafeBoolToSBool bAVX512_VBMI +sAVX512_VBMI2 = unsafeBoolToSBool bAVX512_VBMI2 +sAVX512_VNNI = unsafeBoolToSBool bAVX512_VNNI +sAVX512_VPOPCNTDQ = unsafeBoolToSBool bAVX512_VPOPCNTDQ +sAVX512BW = unsafeBoolToSBool bAVX512BW +sAVX512CD = unsafeBoolToSBool bAVX512CD +sAVX512DQ = unsafeBoolToSBool bAVX512DQ +sAVX512F = unsafeBoolToSBool bAVX512F +sAVX512VL = unsafeBoolToSBool bAVX512VL +sBMI1 = unsafeBoolToSBool bBMI1 +sBMI2 = unsafeBoolToSBool bBMI2 +sF16C = unsafeBoolToSBool bF16C +sFMA = unsafeBoolToSBool bFMA +sGFNI = unsafeBoolToSBool bGFNI +sPCLMULQDQ = unsafeBoolToSBool bPCLMULQDQ +sPOPCNT = unsafeBoolToSBool bPOPCNT +sRDRAND = unsafeBoolToSBool bRDRAND +sSHA = unsafeBoolToSBool bSHA +sSSE3 = unsafeBoolToSBool bSSE3 +sSSE4_1 = unsafeBoolToSBool bSSE4_1 +sSSE4_2 = unsafeBoolToSBool bSSE4_2 +sSSSE3 = unsafeBoolToSBool bSSSE3 +sVAES = unsafeBoolToSBool bVAES +sVPCLMULQDQ = unsafeBoolToSBool bVPCLMULQDQ diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."