commit 65a5b45a04b287245bd60fb897a43853fb2d92ea
parent 01d5579b614c49d690e970f4cd7d7e67f9655199
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 31 Oct 2026 13:11:59 +0400
lib: rename the Arm module and kernel to Native
Crypto.Hash.SHA256.Arm becomes Crypto.Hash.SHA256.Native, and
cbits/sha256_arm.c becomes cbits/sha256_native.c, exporting
sha256_block_native and sha256_native_available. Nothing in the
Haskell module is specific to ARM beyond the FFI symbol it binds, so
the same driver can sit over a block function for another
architecture.
Diffstat:
6 files changed, 483 insertions(+), 483 deletions(-)
diff --git a/cbits/sha256_arm.c b/cbits/sha256_arm.c
@@ -1,209 +0,0 @@
-#include <stdint.h>
-#include <string.h>
-
-#if defined(__aarch64__)
-
-#include <arm_neon.h>
-
-#if defined(__linux__)
-#include <sys/auxv.h>
-#ifndef HWCAP_SHA2
-#define HWCAP_SHA2 (1UL << 6)
-#endif
-#endif
-
-static const uint32_t K[64] = {
- 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,
- 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
- 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,
- 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
- 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,
- 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
- 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,
- 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
- 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,
- 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
- 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,
- 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
- 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,
- 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
- 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,
- 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
-};
-
-/*
- * Process one 64-byte block using ARM SHA256 crypto instructions.
- *
- * state: pointer to 8 uint32_t words (a,b,c,d,e,f,g,h)
- * block: pointer to 16 uint32_t words (already native endian)
- *
- * The state is updated in place.
- *
- * Compiled for the SHA2 extension only; callers must first check
- * 'sha256_arm_available'.
- */
-__attribute__((target("+sha2")))
-void sha256_block_arm(uint32_t *state, const uint32_t *block) {
- /* Load current hash state */
- uint32x4_t abcd = vld1q_u32(&state[0]);
- uint32x4_t efgh = vld1q_u32(&state[4]);
-
- /* Save original for final addition */
- uint32x4_t abcd_orig = abcd;
- uint32x4_t efgh_orig = efgh;
-
- /* Load message (already native endian) */
- uint32x4_t m0 = vld1q_u32(&block[0]);
- uint32x4_t m1 = vld1q_u32(&block[4]);
- uint32x4_t m2 = vld1q_u32(&block[8]);
- uint32x4_t m3 = vld1q_u32(&block[12]);
-
- uint32x4_t tmp, tmp2;
-
- /* Rounds 0-3 */
- tmp = vaddq_u32(m0, vld1q_u32(&K[0]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m0 = vsha256su1q_u32(vsha256su0q_u32(m0, m1), m2, m3);
-
- /* Rounds 4-7 */
- tmp = vaddq_u32(m1, vld1q_u32(&K[4]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m1 = vsha256su1q_u32(vsha256su0q_u32(m1, m2), m3, m0);
-
- /* Rounds 8-11 */
- tmp = vaddq_u32(m2, vld1q_u32(&K[8]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m2 = vsha256su1q_u32(vsha256su0q_u32(m2, m3), m0, m1);
-
- /* Rounds 12-15 */
- tmp = vaddq_u32(m3, vld1q_u32(&K[12]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m3 = vsha256su1q_u32(vsha256su0q_u32(m3, m0), m1, m2);
-
- /* Rounds 16-19 */
- tmp = vaddq_u32(m0, vld1q_u32(&K[16]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m0 = vsha256su1q_u32(vsha256su0q_u32(m0, m1), m2, m3);
-
- /* Rounds 20-23 */
- tmp = vaddq_u32(m1, vld1q_u32(&K[20]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m1 = vsha256su1q_u32(vsha256su0q_u32(m1, m2), m3, m0);
-
- /* Rounds 24-27 */
- tmp = vaddq_u32(m2, vld1q_u32(&K[24]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m2 = vsha256su1q_u32(vsha256su0q_u32(m2, m3), m0, m1);
-
- /* Rounds 28-31 */
- tmp = vaddq_u32(m3, vld1q_u32(&K[28]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m3 = vsha256su1q_u32(vsha256su0q_u32(m3, m0), m1, m2);
-
- /* Rounds 32-35 */
- tmp = vaddq_u32(m0, vld1q_u32(&K[32]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m0 = vsha256su1q_u32(vsha256su0q_u32(m0, m1), m2, m3);
-
- /* Rounds 36-39 */
- tmp = vaddq_u32(m1, vld1q_u32(&K[36]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m1 = vsha256su1q_u32(vsha256su0q_u32(m1, m2), m3, m0);
-
- /* Rounds 40-43 */
- tmp = vaddq_u32(m2, vld1q_u32(&K[40]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m2 = vsha256su1q_u32(vsha256su0q_u32(m2, m3), m0, m1);
-
- /* Rounds 44-47 */
- tmp = vaddq_u32(m3, vld1q_u32(&K[44]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
- m3 = vsha256su1q_u32(vsha256su0q_u32(m3, m0), m1, m2);
-
- /* Rounds 48-51 */
- tmp = vaddq_u32(m0, vld1q_u32(&K[48]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
-
- /* Rounds 52-55 */
- tmp = vaddq_u32(m1, vld1q_u32(&K[52]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
-
- /* Rounds 56-59 */
- tmp = vaddq_u32(m2, vld1q_u32(&K[56]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
-
- /* Rounds 60-63 */
- tmp = vaddq_u32(m3, vld1q_u32(&K[60]));
- tmp2 = abcd;
- abcd = vsha256hq_u32(abcd, efgh, tmp);
- efgh = vsha256h2q_u32(efgh, tmp2, tmp);
-
- /* Add original state back */
- abcd = vaddq_u32(abcd, abcd_orig);
- efgh = vaddq_u32(efgh, efgh_orig);
-
- /* Store result */
- vst1q_u32(&state[0], abcd);
- vst1q_u32(&state[4], efgh);
-}
-
-/*
- * Return 1 if the CPU implements the ARM SHA2 extension, 0 otherwise.
- * Every Apple arm64 core implements it. Elsewhere we only know how to
- * ask Linux, and report 0 (selecting the pure Haskell fallback) on
- * any other OS.
- */
-int sha256_arm_available(void) {
-#if defined(__APPLE__)
- return 1;
-#elif defined(__linux__)
- return (getauxval(AT_HWCAP) & HWCAP_SHA2) != 0;
-#else
- return 0;
-#endif
-}
-
-#else
-
-/* Stub implementations for non-aarch64 builds */
-void sha256_block_arm(uint32_t *state, const uint32_t *block) {
- (void)state;
- (void)block;
- /* Should never be called - use pure Haskell fallback */
-}
-
-int sha256_arm_available(void) {
- return 0;
-}
-
-#endif
diff --git a/cbits/sha256_native.c b/cbits/sha256_native.c
@@ -0,0 +1,209 @@
+#include <stdint.h>
+#include <string.h>
+
+#if defined(__aarch64__)
+
+#include <arm_neon.h>
+
+#if defined(__linux__)
+#include <sys/auxv.h>
+#ifndef HWCAP_SHA2
+#define HWCAP_SHA2 (1UL << 6)
+#endif
+#endif
+
+static const uint32_t K[64] = {
+ 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,
+ 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
+ 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,
+ 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
+ 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,
+ 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
+ 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,
+ 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
+ 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,
+ 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
+ 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,
+ 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
+ 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,
+ 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
+ 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,
+ 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
+};
+
+/*
+ * Process one 64-byte block using ARM SHA256 crypto instructions.
+ *
+ * state: pointer to 8 uint32_t words (a,b,c,d,e,f,g,h)
+ * block: pointer to 16 uint32_t words (already native endian)
+ *
+ * The state is updated in place.
+ *
+ * Compiled for the SHA2 extension only; callers must first check
+ * 'sha256_native_available'.
+ */
+__attribute__((target("+sha2")))
+void sha256_block_native(uint32_t *state, const uint32_t *block) {
+ /* Load current hash state */
+ uint32x4_t abcd = vld1q_u32(&state[0]);
+ uint32x4_t efgh = vld1q_u32(&state[4]);
+
+ /* Save original for final addition */
+ uint32x4_t abcd_orig = abcd;
+ uint32x4_t efgh_orig = efgh;
+
+ /* Load message (already native endian) */
+ uint32x4_t m0 = vld1q_u32(&block[0]);
+ uint32x4_t m1 = vld1q_u32(&block[4]);
+ uint32x4_t m2 = vld1q_u32(&block[8]);
+ uint32x4_t m3 = vld1q_u32(&block[12]);
+
+ uint32x4_t tmp, tmp2;
+
+ /* Rounds 0-3 */
+ tmp = vaddq_u32(m0, vld1q_u32(&K[0]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m0 = vsha256su1q_u32(vsha256su0q_u32(m0, m1), m2, m3);
+
+ /* Rounds 4-7 */
+ tmp = vaddq_u32(m1, vld1q_u32(&K[4]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m1 = vsha256su1q_u32(vsha256su0q_u32(m1, m2), m3, m0);
+
+ /* Rounds 8-11 */
+ tmp = vaddq_u32(m2, vld1q_u32(&K[8]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m2 = vsha256su1q_u32(vsha256su0q_u32(m2, m3), m0, m1);
+
+ /* Rounds 12-15 */
+ tmp = vaddq_u32(m3, vld1q_u32(&K[12]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m3 = vsha256su1q_u32(vsha256su0q_u32(m3, m0), m1, m2);
+
+ /* Rounds 16-19 */
+ tmp = vaddq_u32(m0, vld1q_u32(&K[16]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m0 = vsha256su1q_u32(vsha256su0q_u32(m0, m1), m2, m3);
+
+ /* Rounds 20-23 */
+ tmp = vaddq_u32(m1, vld1q_u32(&K[20]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m1 = vsha256su1q_u32(vsha256su0q_u32(m1, m2), m3, m0);
+
+ /* Rounds 24-27 */
+ tmp = vaddq_u32(m2, vld1q_u32(&K[24]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m2 = vsha256su1q_u32(vsha256su0q_u32(m2, m3), m0, m1);
+
+ /* Rounds 28-31 */
+ tmp = vaddq_u32(m3, vld1q_u32(&K[28]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m3 = vsha256su1q_u32(vsha256su0q_u32(m3, m0), m1, m2);
+
+ /* Rounds 32-35 */
+ tmp = vaddq_u32(m0, vld1q_u32(&K[32]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m0 = vsha256su1q_u32(vsha256su0q_u32(m0, m1), m2, m3);
+
+ /* Rounds 36-39 */
+ tmp = vaddq_u32(m1, vld1q_u32(&K[36]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m1 = vsha256su1q_u32(vsha256su0q_u32(m1, m2), m3, m0);
+
+ /* Rounds 40-43 */
+ tmp = vaddq_u32(m2, vld1q_u32(&K[40]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m2 = vsha256su1q_u32(vsha256su0q_u32(m2, m3), m0, m1);
+
+ /* Rounds 44-47 */
+ tmp = vaddq_u32(m3, vld1q_u32(&K[44]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+ m3 = vsha256su1q_u32(vsha256su0q_u32(m3, m0), m1, m2);
+
+ /* Rounds 48-51 */
+ tmp = vaddq_u32(m0, vld1q_u32(&K[48]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+
+ /* Rounds 52-55 */
+ tmp = vaddq_u32(m1, vld1q_u32(&K[52]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+
+ /* Rounds 56-59 */
+ tmp = vaddq_u32(m2, vld1q_u32(&K[56]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+
+ /* Rounds 60-63 */
+ tmp = vaddq_u32(m3, vld1q_u32(&K[60]));
+ tmp2 = abcd;
+ abcd = vsha256hq_u32(abcd, efgh, tmp);
+ efgh = vsha256h2q_u32(efgh, tmp2, tmp);
+
+ /* Add original state back */
+ abcd = vaddq_u32(abcd, abcd_orig);
+ efgh = vaddq_u32(efgh, efgh_orig);
+
+ /* Store result */
+ vst1q_u32(&state[0], abcd);
+ vst1q_u32(&state[4], efgh);
+}
+
+/*
+ * Return 1 if the CPU implements the ARM SHA2 extension, 0 otherwise.
+ * Every Apple arm64 core implements it. Elsewhere we only know how to
+ * ask Linux, and report 0 (selecting the pure Haskell fallback) on
+ * any other OS.
+ */
+int sha256_native_available(void) {
+#if defined(__APPLE__)
+ return 1;
+#elif defined(__linux__)
+ return (getauxval(AT_HWCAP) & HWCAP_SHA2) != 0;
+#else
+ return 0;
+#endif
+}
+
+#else
+
+/* Stub implementations for non-aarch64 builds */
+void sha256_block_native(uint32_t *state, const uint32_t *block) {
+ (void)state;
+ (void)block;
+ /* Should never be called - use pure Haskell fallback */
+}
+
+int sha256_native_available(void) {
+ return 0;
+}
+
+#endif
diff --git a/lib/Crypto/Hash/SHA256.hs b/lib/Crypto/Hash/SHA256.hs
@@ -33,7 +33,7 @@ module Crypto.Hash.SHA256 (
import qualified Data.ByteString as BS
import Data.Word (Word8, Word32)
import Foreign.Ptr (Ptr)
-import qualified Crypto.Hash.SHA256.Arm as Arm
+import qualified Crypto.Hash.SHA256.Native as Native
import Crypto.Hash.SHA256.Internal (MAC(..), Registers)
import qualified Crypto.Hash.SHA256.Lazy as Lazy
import qualified Crypto.Hash.SHA256.Pure as Pure
@@ -49,7 +49,7 @@ import qualified Crypto.Hash.SHA256.Pure as Pure
-- "<strict 256-bit message digest>"
hash :: BS.ByteString -> BS.ByteString
hash m
- | Arm.sha256_arm_available = Arm.hash m
+ | Native.sha256_native_available = Native.hash m
| otherwise = Pure.hash m
{-# INLINABLE hash #-}
@@ -67,7 +67,7 @@ hash m
-- "<strict 256-bit MAC>"
hmac :: BS.ByteString -> BS.ByteString -> MAC
hmac k m
- | Arm.sha256_arm_available = MAC (Arm.hmac k m)
+ | Native.sha256_native_available = MAC (Native.hmac k m)
| otherwise = MAC (Pure.hmac k m)
{-# INLINABLE hmac #-}
@@ -84,7 +84,7 @@ _hmac_rr
-> Registers -- ^ message
-> IO ()
_hmac_rr rp bp k m
- | Arm.sha256_arm_available = Arm._hmac_rr rp bp k m
+ | Native.sha256_native_available = Native._hmac_rr rp bp k m
| otherwise = Pure._hmac_rr rp bp k m
{-# INLINABLE _hmac_rr #-}
@@ -102,6 +102,6 @@ _hmac_rsb
-> BS.ByteString -- ^ data
-> IO ()
_hmac_rsb rp bp k v sep dat
- | Arm.sha256_arm_available = Arm._hmac_rsb rp bp k v sep dat
+ | Native.sha256_native_available = Native._hmac_rsb rp bp k v sep dat
| otherwise = Pure._hmac_rsb rp bp k v sep dat
{-# INLINABLE _hmac_rsb #-}
diff --git a/lib/Crypto/Hash/SHA256/Arm.hs b/lib/Crypto/Hash/SHA256/Arm.hs
@@ -1,267 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE UnboxedTuples #-}
-
--- |
--- Module: Crypto.Hash.SHA256.Arm
--- Copyright: (c) 2024 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- ARM crypto extension support for SHA-256.
-
-module Crypto.Hash.SHA256.Arm (
- sha256_arm_available
- , hash
- , hmac
- , _hmac_rr
- , _hmac_rsb
- ) where
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Internal as BI
-import qualified Data.ByteString.Unsafe as BU
-import Data.Word (Word8, Word32, Word64)
-import Foreign.C.Types (CInt(..))
-import Foreign.Marshal.Alloc (allocaBytes)
-import Foreign.Ptr (Ptr)
-import qualified GHC.Exts as Exts
-import qualified GHC.IO (IO(..))
-import qualified GHC.Ptr
-import Crypto.Hash.SHA256.Internal hiding (update)
-import System.IO.Unsafe (unsafeDupablePerformIO)
-
--- ffi ------------------------------------------------------------------------
-
-foreign import ccall unsafe "sha256_block_arm"
- c_sha256_block :: Ptr Word32 -> Ptr Word32 -> IO ()
-
-foreign import ccall unsafe "sha256_arm_available"
- c_sha256_arm_available :: IO CInt
-
--- utilities ------------------------------------------------------------------
-
-fi :: (Integral a, Num b) => a -> b
-fi = fromIntegral
-{-# INLINE fi #-}
-
-peek_registers
- :: Ptr Word32
- -> Registers
-peek_registers (GHC.Ptr.Ptr addr) = R
- (Exts.indexWord32OffAddr# addr 0#)
- (Exts.indexWord32OffAddr# addr 1#)
- (Exts.indexWord32OffAddr# addr 2#)
- (Exts.indexWord32OffAddr# addr 3#)
- (Exts.indexWord32OffAddr# addr 4#)
- (Exts.indexWord32OffAddr# addr 5#)
- (Exts.indexWord32OffAddr# addr 6#)
- (Exts.indexWord32OffAddr# addr 7#)
-{-# INLINE peek_registers #-}
-
-poke_block :: Ptr Word32 -> Block -> IO ()
-poke_block
- (GHC.Ptr.Ptr addr)
- (B w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15)
- = GHC.IO.IO $ \s00 ->
- case Exts.writeWord32OffAddr# addr 00# w00 s00 of { s01 ->
- case Exts.writeWord32OffAddr# addr 01# w01 s01 of { s02 ->
- case Exts.writeWord32OffAddr# addr 02# w02 s02 of { s03 ->
- case Exts.writeWord32OffAddr# addr 03# w03 s03 of { s04 ->
- case Exts.writeWord32OffAddr# addr 04# w04 s04 of { s05 ->
- case Exts.writeWord32OffAddr# addr 05# w05 s05 of { s06 ->
- case Exts.writeWord32OffAddr# addr 06# w06 s06 of { s07 ->
- case Exts.writeWord32OffAddr# addr 07# w07 s07 of { s08 ->
- case Exts.writeWord32OffAddr# addr 08# w08 s08 of { s09 ->
- case Exts.writeWord32OffAddr# addr 09# w09 s09 of { s10 ->
- case Exts.writeWord32OffAddr# addr 10# w10 s10 of { s11 ->
- case Exts.writeWord32OffAddr# addr 11# w11 s11 of { s12 ->
- case Exts.writeWord32OffAddr# addr 12# w12 s12 of { s13 ->
- case Exts.writeWord32OffAddr# addr 13# w13 s13 of { s14 ->
- case Exts.writeWord32OffAddr# addr 14# w14 s14 of { s15 ->
- case Exts.writeWord32OffAddr# addr 15# w15 s15 of { s16 ->
- (# s16, () #) }}}}}}}}}}}}}}}}
-{-# INLINE poke_block #-}
-
--- update ---------------------------------------------------------------------
-
-update :: Ptr Word32 -> Ptr Word32 -> Block -> IO ()
-update rp bp block = do
- poke_block bp block
- c_sha256_block rp bp
-{-# INLINE update #-}
-
--- api -----------------------------------------------------------------------
-
--- | Are ARM +sha2 extensions available?
-sha256_arm_available :: Bool
-sha256_arm_available = unsafeDupablePerformIO c_sha256_arm_available /= 0
-{-# NOINLINE sha256_arm_available #-}
-
-hash
- :: BS.ByteString
- -> BS.ByteString
-hash m = unsafeDupablePerformIO $
- allocaBytes 32 $ \rp ->
- allocaBytes 64 $ \bp -> do
- poke_registers rp (iv ())
- _hash rp bp 0 m
- let !rs = peek_registers rp
- pure (cat rs)
-
-_hash
- :: Ptr Word32 -- ^ register state
- -> Ptr Word32 -- ^ block state
- -> Word64 -- ^ extra prefix length, for padding calculation
- -> BS.ByteString -- ^ input
- -> IO ()
-_hash rp bp el m@(BI.PS _ _ l) = do
- hash_blocks rp bp m
- let !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 64) m
- !total = el + fi l
- if ll < 56
- then do
- let !ult = parse_pad1 fin total
- update rp bp ult
- else do
- let !(# pen, ult #) = parse_pad2 fin total
- update rp bp pen
- update rp bp ult
-{-# INLINABLE _hash #-}
-
-hash_blocks
- :: Ptr Word32 -- ^ register state
- -> Ptr Word32 -- ^ block state
- -> BS.ByteString -- ^ input
- -> IO ()
-hash_blocks rp bp m@(BI.PS _ _ l) = loop 0 where
- loop !j
- | j + 64 > l = pure ()
- | otherwise = do
- let !block = parse m j
- update rp bp block
- loop (j + 64)
-{-# INLINE hash_blocks #-}
-
--- hmac ------------------------------------------------------------------------
-
-hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString
-hmac k m = unsafeDupablePerformIO $
- allocaBytes 32 $ \rp ->
- allocaBytes 64 $ \bp -> do
- _hmac rp bp (prep_key k) m
- pure (cat (peek_registers rp))
-
-prep_key :: BS.ByteString -> Block
-prep_key k@(BI.PS _ _ l)
- | l > 64 = parse_key (hash k)
- | otherwise = parse_key k
-{-# INLINABLE prep_key #-}
-
--- assume padded key as block.
-_hmac
- :: Ptr Word32 -- ^ register state
- -> Ptr Word32 -- ^ block state
- -> Block -- ^ padded key
- -> BS.ByteString -- ^ message
- -> IO ()
-_hmac rp bp k m = do
- poke_registers rp (iv ())
- update rp bp (xor k (Exts.wordToWord32# 0x36363636##))
- _hash rp bp 64 m
- let !block = pad_registers_with_length (peek_registers rp)
- poke_registers rp (iv ())
- update rp bp (xor k (Exts.wordToWord32# 0x5C5C5C5C##))
- update rp bp block
-{-# NOINLINE _hmac #-}
-
-_hmac_rr
- :: Ptr Word32 -- ^ register state
- -> Ptr Word32 -- ^ block state
- -> Registers -- ^ key
- -> Registers -- ^ message
- -> IO ()
-_hmac_rr rp bp k m = do
- let !key = pad_registers k
- !block = pad_registers_with_length m
- _hmac_bb rp bp key block
-{-# INLINABLE _hmac_rr #-}
-
-_hmac_bb
- :: Ptr Word32 -- ^ register state
- -> Ptr Word32 -- ^ block state
- -> Block -- ^ padded key
- -> Block -- ^ padded message
- -> IO ()
-_hmac_bb rp bp k m = do
- poke_registers rp (iv ())
- update rp bp (xor k (Exts.wordToWord32# 0x36363636##))
- update rp bp m
- let !inner = pad_registers_with_length (peek_registers rp)
- poke_registers rp (iv ())
- update rp bp (xor k (Exts.wordToWord32# 0x5C5C5C5C##))
- update rp bp inner
-{-# INLINABLE _hmac_bb #-}
-
--- | HMAC(key, v || sep || data) using ARM crypto extensions.
--- Writes result to destination pointer.
-_hmac_rsb
- :: Ptr Word32 -- ^ destination (8 Word32s)
- -> Ptr Word32 -- ^ scratch block buffer (16 Word32s)
- -> Registers -- ^ key
- -> Registers -- ^ v
- -> Word8 -- ^ separator byte
- -> BS.ByteString -- ^ data
- -> IO ()
-_hmac_rsb rp bp k v sep dat = do
- poke_registers rp (iv ())
- let !key = pad_registers k
- update rp bp (xor key (Exts.wordToWord32# 0x36363636##))
- _hash_vsb rp bp 64 v sep dat
- let !inner = pad_registers_with_length (peek_registers rp)
- poke_registers rp (iv ())
- update rp bp (xor key (Exts.wordToWord32# 0x5C5C5C5C##))
- update rp bp inner
-{-# INLINABLE _hmac_rsb #-}
-
--- | Hash (v || sep || dat) with ARM crypto extensions.
--- Assumes register state already initialized at rp.
-_hash_vsb
- :: Ptr Word32 -- ^ register state
- -> Ptr Word32 -- ^ block buffer
- -> Word64 -- ^ extra prefix length
- -> Registers -- ^ v
- -> Word8 -- ^ sep
- -> BS.ByteString -- ^ dat
- -> IO ()
-_hash_vsb rp bp el v sep dat@(BI.PS _ _ l)
- | l >= 31 = do
- -- first block is complete: v || sep || dat[0:31]
- let !b0 = parse_vsb v sep dat
- update rp bp b0
- -- hash remaining complete blocks from dat[31:]
- let !rest = BU.unsafeDrop 31 dat
- !restLen = l - 31
- hash_blocks rp bp rest
- -- handle final padding
- let !finLen = restLen `rem` 64
- !fin = BU.unsafeDrop (restLen - finLen) rest
- !total = el + 33 + fi l
- if finLen < 56
- then update rp bp (parse_pad1 fin total)
- else do
- let !(# pen, ult #) = parse_pad2 fin total
- update rp bp pen
- update rp bp ult
- | otherwise = do
- -- message < 64 bytes total, straight to padding
- let !total = el + 33 + fi l
- if 33 + l < 56
- then update rp bp (parse_pad1_vsb v sep dat total)
- else do
- let !(# pen, ult #) = parse_pad2_vsb v sep dat total
- update rp bp pen
- update rp bp ult
-{-# INLINABLE _hash_vsb #-}
diff --git a/lib/Crypto/Hash/SHA256/Native.hs b/lib/Crypto/Hash/SHA256/Native.hs
@@ -0,0 +1,267 @@
+{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-- |
+-- Module: Crypto.Hash.SHA256.Native
+-- Copyright: (c) 2024 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- ARM crypto extension support for SHA-256.
+
+module Crypto.Hash.SHA256.Native (
+ sha256_native_available
+ , hash
+ , hmac
+ , _hmac_rr
+ , _hmac_rsb
+ ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BI
+import qualified Data.ByteString.Unsafe as BU
+import Data.Word (Word8, Word32, Word64)
+import Foreign.C.Types (CInt(..))
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Ptr (Ptr)
+import qualified GHC.Exts as Exts
+import qualified GHC.IO (IO(..))
+import qualified GHC.Ptr
+import Crypto.Hash.SHA256.Internal hiding (update)
+import System.IO.Unsafe (unsafeDupablePerformIO)
+
+-- ffi ------------------------------------------------------------------------
+
+foreign import ccall unsafe "sha256_block_native"
+ c_sha256_block :: Ptr Word32 -> Ptr Word32 -> IO ()
+
+foreign import ccall unsafe "sha256_native_available"
+ c_sha256_native_available :: IO CInt
+
+-- utilities ------------------------------------------------------------------
+
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+{-# INLINE fi #-}
+
+peek_registers
+ :: Ptr Word32
+ -> Registers
+peek_registers (GHC.Ptr.Ptr addr) = R
+ (Exts.indexWord32OffAddr# addr 0#)
+ (Exts.indexWord32OffAddr# addr 1#)
+ (Exts.indexWord32OffAddr# addr 2#)
+ (Exts.indexWord32OffAddr# addr 3#)
+ (Exts.indexWord32OffAddr# addr 4#)
+ (Exts.indexWord32OffAddr# addr 5#)
+ (Exts.indexWord32OffAddr# addr 6#)
+ (Exts.indexWord32OffAddr# addr 7#)
+{-# INLINE peek_registers #-}
+
+poke_block :: Ptr Word32 -> Block -> IO ()
+poke_block
+ (GHC.Ptr.Ptr addr)
+ (B w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15)
+ = GHC.IO.IO $ \s00 ->
+ case Exts.writeWord32OffAddr# addr 00# w00 s00 of { s01 ->
+ case Exts.writeWord32OffAddr# addr 01# w01 s01 of { s02 ->
+ case Exts.writeWord32OffAddr# addr 02# w02 s02 of { s03 ->
+ case Exts.writeWord32OffAddr# addr 03# w03 s03 of { s04 ->
+ case Exts.writeWord32OffAddr# addr 04# w04 s04 of { s05 ->
+ case Exts.writeWord32OffAddr# addr 05# w05 s05 of { s06 ->
+ case Exts.writeWord32OffAddr# addr 06# w06 s06 of { s07 ->
+ case Exts.writeWord32OffAddr# addr 07# w07 s07 of { s08 ->
+ case Exts.writeWord32OffAddr# addr 08# w08 s08 of { s09 ->
+ case Exts.writeWord32OffAddr# addr 09# w09 s09 of { s10 ->
+ case Exts.writeWord32OffAddr# addr 10# w10 s10 of { s11 ->
+ case Exts.writeWord32OffAddr# addr 11# w11 s11 of { s12 ->
+ case Exts.writeWord32OffAddr# addr 12# w12 s12 of { s13 ->
+ case Exts.writeWord32OffAddr# addr 13# w13 s13 of { s14 ->
+ case Exts.writeWord32OffAddr# addr 14# w14 s14 of { s15 ->
+ case Exts.writeWord32OffAddr# addr 15# w15 s15 of { s16 ->
+ (# s16, () #) }}}}}}}}}}}}}}}}
+{-# INLINE poke_block #-}
+
+-- update ---------------------------------------------------------------------
+
+update :: Ptr Word32 -> Ptr Word32 -> Block -> IO ()
+update rp bp block = do
+ poke_block bp block
+ c_sha256_block rp bp
+{-# INLINE update #-}
+
+-- api -----------------------------------------------------------------------
+
+-- | Are hardware SHA-256 instructions available?
+sha256_native_available :: Bool
+sha256_native_available = unsafeDupablePerformIO c_sha256_native_available /= 0
+{-# NOINLINE sha256_native_available #-}
+
+hash
+ :: BS.ByteString
+ -> BS.ByteString
+hash m = unsafeDupablePerformIO $
+ allocaBytes 32 $ \rp ->
+ allocaBytes 64 $ \bp -> do
+ poke_registers rp (iv ())
+ _hash rp bp 0 m
+ let !rs = peek_registers rp
+ pure (cat rs)
+
+_hash
+ :: Ptr Word32 -- ^ register state
+ -> Ptr Word32 -- ^ block state
+ -> Word64 -- ^ extra prefix length, for padding calculation
+ -> BS.ByteString -- ^ input
+ -> IO ()
+_hash rp bp el m@(BI.PS _ _ l) = do
+ hash_blocks rp bp m
+ let !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 64) m
+ !total = el + fi l
+ if ll < 56
+ then do
+ let !ult = parse_pad1 fin total
+ update rp bp ult
+ else do
+ let !(# pen, ult #) = parse_pad2 fin total
+ update rp bp pen
+ update rp bp ult
+{-# INLINABLE _hash #-}
+
+hash_blocks
+ :: Ptr Word32 -- ^ register state
+ -> Ptr Word32 -- ^ block state
+ -> BS.ByteString -- ^ input
+ -> IO ()
+hash_blocks rp bp m@(BI.PS _ _ l) = loop 0 where
+ loop !j
+ | j + 64 > l = pure ()
+ | otherwise = do
+ let !block = parse m j
+ update rp bp block
+ loop (j + 64)
+{-# INLINE hash_blocks #-}
+
+-- hmac ------------------------------------------------------------------------
+
+hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString
+hmac k m = unsafeDupablePerformIO $
+ allocaBytes 32 $ \rp ->
+ allocaBytes 64 $ \bp -> do
+ _hmac rp bp (prep_key k) m
+ pure (cat (peek_registers rp))
+
+prep_key :: BS.ByteString -> Block
+prep_key k@(BI.PS _ _ l)
+ | l > 64 = parse_key (hash k)
+ | otherwise = parse_key k
+{-# INLINABLE prep_key #-}
+
+-- assume padded key as block.
+_hmac
+ :: Ptr Word32 -- ^ register state
+ -> Ptr Word32 -- ^ block state
+ -> Block -- ^ padded key
+ -> BS.ByteString -- ^ message
+ -> IO ()
+_hmac rp bp k m = do
+ poke_registers rp (iv ())
+ update rp bp (xor k (Exts.wordToWord32# 0x36363636##))
+ _hash rp bp 64 m
+ let !block = pad_registers_with_length (peek_registers rp)
+ poke_registers rp (iv ())
+ update rp bp (xor k (Exts.wordToWord32# 0x5C5C5C5C##))
+ update rp bp block
+{-# NOINLINE _hmac #-}
+
+_hmac_rr
+ :: Ptr Word32 -- ^ register state
+ -> Ptr Word32 -- ^ block state
+ -> Registers -- ^ key
+ -> Registers -- ^ message
+ -> IO ()
+_hmac_rr rp bp k m = do
+ let !key = pad_registers k
+ !block = pad_registers_with_length m
+ _hmac_bb rp bp key block
+{-# INLINABLE _hmac_rr #-}
+
+_hmac_bb
+ :: Ptr Word32 -- ^ register state
+ -> Ptr Word32 -- ^ block state
+ -> Block -- ^ padded key
+ -> Block -- ^ padded message
+ -> IO ()
+_hmac_bb rp bp k m = do
+ poke_registers rp (iv ())
+ update rp bp (xor k (Exts.wordToWord32# 0x36363636##))
+ update rp bp m
+ let !inner = pad_registers_with_length (peek_registers rp)
+ poke_registers rp (iv ())
+ update rp bp (xor k (Exts.wordToWord32# 0x5C5C5C5C##))
+ update rp bp inner
+{-# INLINABLE _hmac_bb #-}
+
+-- | HMAC(key, v || sep || data) using hardware SHA-256 instructions.
+-- Writes result to destination pointer.
+_hmac_rsb
+ :: Ptr Word32 -- ^ destination (8 Word32s)
+ -> Ptr Word32 -- ^ scratch block buffer (16 Word32s)
+ -> Registers -- ^ key
+ -> Registers -- ^ v
+ -> Word8 -- ^ separator byte
+ -> BS.ByteString -- ^ data
+ -> IO ()
+_hmac_rsb rp bp k v sep dat = do
+ poke_registers rp (iv ())
+ let !key = pad_registers k
+ update rp bp (xor key (Exts.wordToWord32# 0x36363636##))
+ _hash_vsb rp bp 64 v sep dat
+ let !inner = pad_registers_with_length (peek_registers rp)
+ poke_registers rp (iv ())
+ update rp bp (xor key (Exts.wordToWord32# 0x5C5C5C5C##))
+ update rp bp inner
+{-# INLINABLE _hmac_rsb #-}
+
+-- | Hash (v || sep || dat) with hardware SHA-256 instructions.
+-- Assumes register state already initialized at rp.
+_hash_vsb
+ :: Ptr Word32 -- ^ register state
+ -> Ptr Word32 -- ^ block buffer
+ -> Word64 -- ^ extra prefix length
+ -> Registers -- ^ v
+ -> Word8 -- ^ sep
+ -> BS.ByteString -- ^ dat
+ -> IO ()
+_hash_vsb rp bp el v sep dat@(BI.PS _ _ l)
+ | l >= 31 = do
+ -- first block is complete: v || sep || dat[0:31]
+ let !b0 = parse_vsb v sep dat
+ update rp bp b0
+ -- hash remaining complete blocks from dat[31:]
+ let !rest = BU.unsafeDrop 31 dat
+ !restLen = l - 31
+ hash_blocks rp bp rest
+ -- handle final padding
+ let !finLen = restLen `rem` 64
+ !fin = BU.unsafeDrop (restLen - finLen) rest
+ !total = el + 33 + fi l
+ if finLen < 56
+ then update rp bp (parse_pad1 fin total)
+ else do
+ let !(# pen, ult #) = parse_pad2 fin total
+ update rp bp pen
+ update rp bp ult
+ | otherwise = do
+ -- message < 64 bytes total, straight to padding
+ let !total = el + 33 + fi l
+ if 33 + l < 56
+ then update rp bp (parse_pad1_vsb v sep dat total)
+ else do
+ let !(# pen, ult #) = parse_pad2_vsb v sep dat total
+ update rp bp pen
+ update rp bp ult
+{-# INLINABLE _hash_vsb #-}
diff --git a/ppad-sha256.cabal b/ppad-sha256.cabal
@@ -41,13 +41,13 @@ library
Crypto.Hash.SHA256.Lazy
Crypto.Hash.SHA256.Pure
other-modules:
- Crypto.Hash.SHA256.Arm
+ Crypto.Hash.SHA256.Native
Data.Barrier
build-depends:
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
c-sources:
- cbits/sha256_arm.c
+ cbits/sha256_native.c
if flag(sanitize)
cc-options: -fsanitize=address,undefined -fno-omit-frame-pointer
ghc-options: -optl=-fsanitize=address,undefined
