Arm.hs (8467B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE PatternSynonyms #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 7 -- | 8 -- Module: Crypto.Hash.SHA512.Arm 9 -- Copyright: (c) 2024 Jared Tobin 10 -- License: MIT 11 -- Maintainer: Jared Tobin <jared@ppad.tech> 12 -- 13 -- ARM crypto extension support for SHA-512. 14 15 module Crypto.Hash.SHA512.Arm ( 16 sha512_arm_available 17 , hash 18 , hmac 19 , _hmac_rr 20 , _hmac_rsb 21 ) where 22 23 import qualified Data.ByteString as BS 24 import qualified Data.ByteString.Internal as BI 25 import qualified Data.ByteString.Unsafe as BU 26 import Data.Word (Word8, Word64) 27 import Foreign.Marshal.Alloc (allocaBytes) 28 import Foreign.Ptr (Ptr) 29 import qualified GHC.Exts as Exts 30 import qualified GHC.IO (IO(..)) 31 import qualified GHC.Ptr 32 import Crypto.Hash.SHA512.Internal hiding (update) 33 import System.IO.Unsafe (unsafeDupablePerformIO) 34 35 -- ffi ------------------------------------------------------------------------ 36 37 foreign import ccall unsafe "sha512_block_arm" 38 c_sha512_block :: Ptr Word64 -> Ptr Word64 -> IO () 39 40 foreign import ccall unsafe "sha512_arm_available" 41 c_sha512_arm_available :: IO Int 42 43 -- utilities ------------------------------------------------------------------ 44 45 fi :: (Integral a, Num b) => a -> b 46 fi = fromIntegral 47 {-# INLINE fi #-} 48 49 peek_registers 50 :: Ptr Word64 51 -> Registers 52 peek_registers (GHC.Ptr.Ptr addr) = R 53 (Exts.indexWord64OffAddr# addr 0#) 54 (Exts.indexWord64OffAddr# addr 1#) 55 (Exts.indexWord64OffAddr# addr 2#) 56 (Exts.indexWord64OffAddr# addr 3#) 57 (Exts.indexWord64OffAddr# addr 4#) 58 (Exts.indexWord64OffAddr# addr 5#) 59 (Exts.indexWord64OffAddr# addr 6#) 60 (Exts.indexWord64OffAddr# addr 7#) 61 {-# INLINE peek_registers #-} 62 63 poke_block :: Ptr Word64 -> Block -> IO () 64 poke_block 65 (GHC.Ptr.Ptr addr) 66 (B w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15) 67 = GHC.IO.IO $ \s00 -> 68 case Exts.writeWord64OffAddr# addr 00# w00 s00 of { s01 -> 69 case Exts.writeWord64OffAddr# addr 01# w01 s01 of { s02 -> 70 case Exts.writeWord64OffAddr# addr 02# w02 s02 of { s03 -> 71 case Exts.writeWord64OffAddr# addr 03# w03 s03 of { s04 -> 72 case Exts.writeWord64OffAddr# addr 04# w04 s04 of { s05 -> 73 case Exts.writeWord64OffAddr# addr 05# w05 s05 of { s06 -> 74 case Exts.writeWord64OffAddr# addr 06# w06 s06 of { s07 -> 75 case Exts.writeWord64OffAddr# addr 07# w07 s07 of { s08 -> 76 case Exts.writeWord64OffAddr# addr 08# w08 s08 of { s09 -> 77 case Exts.writeWord64OffAddr# addr 09# w09 s09 of { s10 -> 78 case Exts.writeWord64OffAddr# addr 10# w10 s10 of { s11 -> 79 case Exts.writeWord64OffAddr# addr 11# w11 s11 of { s12 -> 80 case Exts.writeWord64OffAddr# addr 12# w12 s12 of { s13 -> 81 case Exts.writeWord64OffAddr# addr 13# w13 s13 of { s14 -> 82 case Exts.writeWord64OffAddr# addr 14# w14 s14 of { s15 -> 83 case Exts.writeWord64OffAddr# addr 15# w15 s15 of { s16 -> 84 (# s16, () #) }}}}}}}}}}}}}}}} 85 {-# INLINE poke_block #-} 86 87 -- update --------------------------------------------------------------------- 88 89 update :: Ptr Word64 -> Ptr Word64 -> Block -> IO () 90 update rp bp block = do 91 poke_block bp block 92 c_sha512_block rp bp 93 {-# INLINE update #-} 94 95 -- api ----------------------------------------------------------------------- 96 97 -- | Are ARM +sha512 extensions available? 98 sha512_arm_available :: Bool 99 sha512_arm_available = unsafeDupablePerformIO c_sha512_arm_available /= 0 100 {-# NOINLINE sha512_arm_available #-} 101 102 hash 103 :: BS.ByteString 104 -> BS.ByteString 105 hash m = unsafeDupablePerformIO $ 106 allocaBytes 64 $ \rp -> 107 allocaBytes 128 $ \bp -> do 108 poke_registers rp (iv ()) 109 _hash rp bp 0 m 110 let !rs = peek_registers rp 111 pure (cat rs) 112 113 _hash 114 :: Ptr Word64 -- ^ register state 115 -> Ptr Word64 -- ^ block state 116 -> Word64 -- ^ extra prefix length, for padding calculation 117 -> BS.ByteString -- ^ input 118 -> IO () 119 _hash rp bp el m@(BI.PS _ _ l) = do 120 hash_blocks rp bp m 121 let !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 128) m 122 !total = el + fi l 123 if ll < 112 124 then do 125 let !ult = parse_pad1 fin total 126 update rp bp ult 127 else do 128 let !(# pen, ult #) = parse_pad2 fin total 129 update rp bp pen 130 update rp bp ult 131 {-# INLINABLE _hash #-} 132 133 hash_blocks 134 :: Ptr Word64 -- ^ register state 135 -> Ptr Word64 -- ^ block state 136 -> BS.ByteString -- ^ input 137 -> IO () 138 hash_blocks rp bp m@(BI.PS _ _ l) = loop 0 where 139 loop !j 140 | j + 128 > l = pure () 141 | otherwise = do 142 let !block = parse m j 143 update rp bp block 144 loop (j + 128) 145 {-# INLINE hash_blocks #-} 146 147 -- hmac ----------------------------------------------------------------------- 148 149 hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString 150 hmac k m = unsafeDupablePerformIO $ 151 allocaBytes 64 $ \rp -> 152 allocaBytes 128 $ \bp -> do 153 _hmac rp bp (prep_key k) m 154 pure (cat (peek_registers rp)) 155 156 prep_key :: BS.ByteString -> Block 157 prep_key k@(BI.PS _ _ l) 158 | l > 128 = parse_key (hash k) 159 | otherwise = parse_key k 160 {-# INLINABLE prep_key #-} 161 162 -- assume padded key as block. 163 _hmac 164 :: Ptr Word64 -- ^ register state 165 -> Ptr Word64 -- ^ block state 166 -> Block -- ^ padded key 167 -> BS.ByteString -- ^ message 168 -> IO () 169 _hmac rp bp k m = do 170 poke_registers rp (iv ()) 171 update rp bp (xor k (Exts.wordToWord64# 0x3636363636363636##)) 172 _hash rp bp 128 m 173 let !block = pad_registers_with_length (peek_registers rp) 174 poke_registers rp (iv ()) 175 update rp bp (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 176 update rp bp block 177 {-# NOINLINE _hmac #-} 178 179 _hmac_rr 180 :: Ptr Word64 -- ^ register state 181 -> Ptr Word64 -- ^ block state 182 -> Registers -- ^ key 183 -> Registers -- ^ message 184 -> IO () 185 _hmac_rr rp bp k m = do 186 let !key = pad_registers k 187 !block = pad_registers_with_length m 188 _hmac_bb rp bp key block 189 {-# INLINABLE _hmac_rr #-} 190 191 _hmac_bb 192 :: Ptr Word64 -- ^ register state 193 -> Ptr Word64 -- ^ block state 194 -> Block -- ^ padded key 195 -> Block -- ^ padded message 196 -> IO () 197 _hmac_bb rp bp k m = do 198 poke_registers rp (iv ()) 199 update rp bp (xor k (Exts.wordToWord64# 0x3636363636363636##)) 200 update rp bp m 201 let !inner = pad_registers_with_length (peek_registers rp) 202 poke_registers rp (iv ()) 203 update rp bp (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 204 update rp bp inner 205 {-# INLINABLE _hmac_bb #-} 206 207 -- | HMAC(key, v || sep || data) using ARM crypto extensions. 208 -- Writes result to destination pointer. 209 _hmac_rsb 210 :: Ptr Word64 -- ^ destination (8 Word64s) 211 -> Ptr Word64 -- ^ scratch block buffer (16 Word64s) 212 -> Registers -- ^ key 213 -> Registers -- ^ v 214 -> Word8 -- ^ separator byte 215 -> BS.ByteString -- ^ data 216 -> IO () 217 _hmac_rsb rp bp k v sep dat = do 218 poke_registers rp (iv ()) 219 let !key = pad_registers k 220 update rp bp (xor key (Exts.wordToWord64# 0x3636363636363636##)) 221 _hash_vsb rp bp 128 v sep dat 222 let !inner = pad_registers_with_length (peek_registers rp) 223 poke_registers rp (iv ()) 224 update rp bp (xor key (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 225 update rp bp inner 226 {-# INLINABLE _hmac_rsb #-} 227 228 -- | Hash (v || sep || dat) with ARM crypto extensions. 229 -- Assumes register state already initialized at rp. 230 _hash_vsb 231 :: Ptr Word64 -- ^ register state 232 -> Ptr Word64 -- ^ block buffer 233 -> Word64 -- ^ extra prefix length 234 -> Registers -- ^ v 235 -> Word8 -- ^ sep 236 -> BS.ByteString -- ^ dat 237 -> IO () 238 _hash_vsb rp bp el v sep dat@(BI.PS _ _ l) 239 | l >= 63 = do 240 -- first block is complete: v || sep || dat[0:63] 241 let !b0 = parse_vsb v sep dat 242 update rp bp b0 243 -- hash remaining complete blocks from dat[63:] 244 let !rest = BU.unsafeDrop 63 dat 245 !restLen = l - 63 246 hash_blocks rp bp rest 247 -- handle final padding 248 let !finLen = restLen `rem` 128 249 !fin = BU.unsafeDrop (restLen - finLen) rest 250 !total = el + 65 + fi l 251 if finLen < 112 252 then update rp bp (parse_pad1 fin total) 253 else do 254 let !(# pen, ult #) = parse_pad2 fin total 255 update rp bp pen 256 update rp bp ult 257 | otherwise = do 258 -- message < 128 bytes total, straight to padding 259 let !total = el + 65 + fi l 260 if 65 + l < 112 261 then update rp bp (parse_pad1_vsb v sep dat total) 262 else do 263 let !(# pen, ult #) = parse_pad2_vsb v sep dat total 264 update rp bp pen 265 update rp bp ult 266 {-# INLINABLE _hash_vsb #-} 267