mlkem 0.2.2.0 → 0.2.3.0

raw patch · 12 files changed

+137/−48 lines, 12 filesdep +filelockPVP ok

version bump matches the API change (PVP)

Dependencies added: filelock

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• mlkem.cabal +7/−3
• src/Auxiliary.hs +31/−6
• src/Block.hs +1/−4
• src/BlockN.hs +8/−7
• src/Crypto.hs +15/−4
• src/Endian.hs +43/−0
• src/Fusion.hs +2/−2
• src/Machine.hs +3/−18
• src/ScrubbedBlock.hs +1/−1
• tests/Tests.hs +17/−2
• tests/get-vectors.sh +1/−1

@@ -1,5 +1,13 @@ # Changelog for `mlkem` +## 0.2.3.0 - 2026-08-16++* Improve performance of modular reduction with the NCG++* Use `finally` instead of masking asynchronous exceptions++* Refresh the test vectors+ ## 0.2.2.0 - 2026-06-28  * Clearing buffers containing secrets is more resilient and takes into account

@@ -1,15 +1,15 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.39.1.+-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack  name:           mlkem-version:        0.2.2.0+version:        0.2.3.0 synopsis:       Module-Lattice-based Key-Encapsulation Mechanism description:    Module-Lattice-based Key-Encapsulation Mechanism (ML-KEM) implemented in                 Haskell.-category:       Crypto+category:       Cryptography homepage:       https://codeberg.org/ocheron/hs-mlkem#readme bug-reports:    https://codeberg.org/ocheron/hs-mlkem/issues author:         Olivier Chéron@@ -44,6 +44,7 @@       Builder       ByteArrayST       Crypto+      Endian       Equality       Fusion       Internal@@ -97,6 +98,7 @@     , bytestring     , deepseq     , directory+    , filelock     , mlkem     , primitive >=0.7.2     , process@@ -127,6 +129,7 @@       ByteArrayST       Crypto       Crypto.PubKey.ML_KEM+      Endian       Equality       Fusion       Internal@@ -158,6 +161,7 @@     , bytestring     , deepseq     , directory+    , filelock     , primitive >=0.7.2     , process     , tasty

@@ -38,7 +38,9 @@ import Control.Monad.ST  import Data.Bits+#ifdef __GLASGOW_HASKELL_LLVM__ import Data.Int+#endif import Data.Proxy import Data.Word @@ -91,17 +93,40 @@     (b `unsafeShiftR` 1 .&. 1) `unsafeShiftL` 5 .|.     (b .&. 1) `unsafeShiftL` 6 -unsafeShiftIR :: Word16 -> Int -> Word16-unsafeShiftIR x s = fromIntegral ((fromIntegral x :: Int16) `unsafeShiftR` s)-{-# INLINE unsafeShiftIR #-}- -- Reduction 𝑥 mod 𝑞 for 0 ≤ 𝑥 < 2𝑞 reduceSimple :: Word16 -> Word16-reduceSimple x = (mask .&. x) .|. (complement mask .&. subtracted)+#ifdef __GLASGOW_HASKELL_LLVM__+reduceSimple = reduceSimpleLLVM+#else+reduceSimple = fromIntegral . reduceSimpleNCG . fromIntegral+#endif+{-# INLINE reduceSimple #-}++#ifdef __GLASGOW_HASKELL_LLVM__+-- LLVM operates more efficiently on Word16 directly+reduceSimpleLLVM :: Word16 -> Word16+reduceSimpleLLVM x = (mask .&. x) .|. (complement mask .&. subtracted)   where     subtracted = x - q16     mask = subtracted `unsafeShiftIR` 15-{-# INLINE reduceSimple #-}++    unsafeShiftIR :: Word16 -> Int -> Word16+    unsafeShiftIR w s = fromIntegral ((fromIntegral w :: Int16) `unsafeShiftR` s)+#else+-- NCG code performance is better with full machine words, as this removes+-- conversion instructions at several intermediate steps+reduceSimpleNCG :: Word -> Word+reduceSimpleNCG x = (mask .&. x) .|. (complement mask .&. subtracted)+  where+    subtracted = x - qW+    mask = subtracted `unsafeShiftIR` (finiteBitSize qW - 1)++    unsafeShiftIR :: Word -> Int -> Word+    unsafeShiftIR w s = fromIntegral ((fromIntegral w :: Int) `unsafeShiftR` s)++    qW :: Word+    qW = fromInteger q+#endif  -- Reduction 𝑥 mod 𝑞 for 0 ≤ 𝑥 < 2𝑞² + 𝑞 reduce :: Word32 -> Word16

@@ -13,7 +13,7 @@     ( Block, MutableBlock, blockIndex, blockRead, blockWrite     , foldZipWith, Block.length, mutableContents, getMutableLength     , Block.new, Block.newPinned, Block.thaw, thawPinned-    , Block.unsafeCast, unsafeCastMut, Block.unsafeFreeze, Block.unsafeThaw+    , Block.unsafeCast, unsafeCastMut, Block.unsafeFreeze #ifdef ML_KEM_TESTING     , Block.toList #endif@@ -109,6 +109,3 @@  unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty) unsafeFreeze = unsafeFreezePrimArray--unsafeThaw :: PrimMonad prim => Block ty -> prim (MutableBlock ty (PrimState prim))-unsafeThaw = unsafeThawPrimArray

@@ -77,7 +77,7 @@ index :: PrimType a => BlockN marking n a -> Offset a -> a index = SecureBlock.index . unBlockN -replicate :: forall marking n a. (Classified marking, KnownNat n, PrimType a) => a -> BlockN marking n a+replicate :: (Classified marking, KnownNat n, PrimType a) => a -> BlockN marking n a replicate = create . const  #ifdef ML_KEM_TESTING@@ -96,15 +96,16 @@ toList = SecureBlock.toList . unBlockN #endif -create :: forall marking n ty. (Classified marking, KnownNat n, PrimType ty)+create :: (Classified marking, KnownNat n, PrimType ty)        => (Offset ty -> ty)        -> BlockN marking n ty-create initializer = runNew (Proxy :: Proxy marking) $ iterSet initializer+create initializer = runNew Proxy $ iterSet initializer {-# INLINE create #-}  map :: (Classified marking, KnownNat n, PrimType a, PrimType b)     => (a -> b) -> BlockN marking n a -> BlockN marking n b-map f (BlockN !a) = create $ \(Offset i) -> f (SecureBlock.index a (Offset i))+map f (BlockN a) = BlockN.seq a $+    create $ \(Offset i) -> f (SecureBlock.index a (Offset i)) {-# INLINE [2] map #-}  mapEndo :: (Classified marking, KnownNat n, PrimType a)@@ -151,8 +152,8 @@  zipWith :: (Classified mc, KnownNat n, PrimType a, PrimType b, PrimType c)         => (a -> b -> c) -> BlockN ma n a -> BlockN mb n b -> BlockN mc n c-zipWith f (BlockN !a) (BlockN !b) =-    create $ \(Offset i) ->+zipWith f (BlockN a) (BlockN b) =+    BlockN.seq a $ BlockN.seq b $ create $ \(Offset i) ->         f (SecureBlock.index a (Offset i)) (SecureBlock.index b (Offset i)) {-# INLINE [2] zipWith #-} @@ -220,7 +221,7 @@ iterMapIxContext :: (EqPrimSize a b, Classified marking, KnownNat n) => (Int -> a -> b) -> Context (BlockN marking n a) -> Context (BlockN marking n b) iterMapIxContext f = mapContext m   where m = MapF { mapUpdate = unsafeMapIx f-                 , mapInit = \x -> newF >>= \mb -> Prelude.seq x (iterSet (g x) mb) >> return mb+                 , mapInit = \x -> newF >>= \mb -> mb <$ Prelude.seq x (iterSet (g x) mb)                  }         g x (Offset i) = f i (index x (Offset i)) {-# INLINE [1] iterMapIxContext #-}

@@ -20,7 +20,7 @@ import Crypto.Hash.Algorithms import Crypto.Hash.IO -import Control.Exception (assert, mask_)+import Control.Exception (assert, finally) import Control.Monad import Control.Monad.ST @@ -95,17 +95,21 @@     constEqW a b         | Block.length a /= Block.length b = falseW         | otherwise = Block.foldZipWith (\mask x y -> mask `andW` eqW x y) trueW a b+    {-# NOINLINE constEqW #-}  instance ConstEqW (ScrubbedBlock Word) where     constEqW a b         | ScrubbedBlock.length a /= ScrubbedBlock.length b = falseW         | otherwise = ScrubbedBlock.foldZipWith (\mask x y -> mask `andW` eqW x y) trueW a b+    {-# NOINLINE constEqW #-}  instance ConstEqW Bytes where     constEqW = bytesConstEqW+    {-# NOINLINE constEqW #-}  instance ConstEqW ScrubbedBytes where     constEqW = bytesConstEqW+    {-# NOINLINE constEqW #-}  bytesConstEqW :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> BoolW bytesConstEqW a b@@ -149,6 +153,7 @@ constSelectBytes :: BoolW -> ScrubbedBytes -> ScrubbedBytes -> ScrubbedBytes constSelectBytes (BoolW !mask) = Crypto.zipWith f   where f yes no = (mask .&. yes) .|. (complement mask .&. no)+{-# NOINLINE constSelectBytes #-}  -- This version of snoc accepts a more general input and uses internally a call -- to copyByteArrayToPtr, so it does not need a trampoline when the input is@@ -227,8 +232,14 @@  hashWith :: forall marking a ba. (HashAlgorithm a, ByteArrayAccess ba) => a -> ba -> Builder marking hashWith a ba = Builder.unsafeCreate (hashDigestSize a) $ \dig ->-    hashMutableInit >>= \ctx -> mask_ $ do+    withScrubbedContext a $ \ctx -> do         hashMutableUpdate (ctx :: MutableContext a) ba-        B.withByteArray ctx $ \pctx -> do+        B.withByteArray ctx $ \pctx ->             hashInternalFinalize (castPtr pctx :: Ptr (Context a)) dig-            fillBytes pctx 0 (B.length ctx)++withScrubbedContext :: HashAlgorithm a => a -> (MutableContext a -> IO b) -> IO b+withScrubbedContext _ f =+    hashMutableInit >>= \ctx -> f ctx `finally` eraseBytes ctx++eraseBytes :: ByteArrayAccess ba => ba -> IO ()+eraseBytes ctx = B.withByteArray ctx $ \p -> fillBytes p 0 (B.length ctx)

@@ -0,0 +1,43 @@+-- |+-- Module      : Endian+-- License     : BSD-3-Clause+-- Copyright   : (c) 2026 Olivier Chéron+--+-- Endianness utilities+--+{-# LANGUAGE CPP #-}+module Endian+    ( B.BE, B.LE, fromLE, toLE+    ) where++#include "MachDeps.h"++-- Little-endian conversion in `memory` / `ram` is avoided at compile+-- time only for AMD/Intel, here we will short circuit on ARM too+#if (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) \+    && !defined(WORDS_BIGENDIAN)+#define MLKEM_FORCE_LITTLE_ENDIAN_ARCH 1+#endif++#ifdef MLKEM_FORCE_LITTLE_ENDIAN_ARCH+#else+import Data.Memory.Endian (ByteSwap)+#endif++import qualified Data.Memory.Endian as B++#ifdef MLKEM_FORCE_LITTLE_ENDIAN_ARCH+fromLE :: B.LE a -> a+fromLE = B.unLE  -- unwrap constructor with no byte swapping+#else+fromLE :: ByteSwap a => B.LE a -> a+fromLE = B.fromLE  -- byte swap if necessary+#endif++#ifdef MLKEM_FORCE_LITTLE_ENDIAN_ARCH+toLE :: a -> B.LE a+toLE = B.LE  -- wrap constructor with no byte swapping+#else+toLE :: ByteSwap a => a -> B.LE a+toLE = B.toLE  -- byte swap if necessary+#endif

@@ -51,10 +51,10 @@  thawContext :: Fusion a => a -> Context a thawContext a = Context $ thawF a-{-# INLINE [0] thawContext #-}+{-# INLINE CONLIKE [0] thawContext #-}  modifyContext :: (forall s. Mut a s -> ST s ()) -> Context a -> Context a-modifyContext f = bindContext $ \ma -> f ma >> return ma+modifyContext f = bindContext $ \ma -> ma <$ f ma  mapContext :: MapF a b -> Context a -> Context b mapContext m = bindContext (mapUpdate m)

@@ -22,19 +22,12 @@     || defined(powerpc64le_HOST_ARCH) #define MLKEM_ALLOW_UNALIGNED_OP 1 --- Little-endian conversion in `memory` / `ram` is avoided at compile--- time only for AMD/Intel, here we will short circuit on ARM too-#if (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) \-    && !defined(WORDS_BIGENDIAN)-#define MLKEM_FORCE_LITTLE_ENDIAN_ARCH 1 #endif -#endif- import Control.Exception (assert)  #ifdef MLKEM_ALLOW_UNALIGNED_OP-import qualified Data.Memory.Endian as B+import qualified Endian as B #endif  import Data.Bits@@ -52,18 +45,10 @@ type WordLE = B.LE WordM  fromLE :: WordLE -> WordM-#ifdef MLKEM_FORCE_LITTLE_ENDIAN_ARCH-fromLE = B.unLE  -- unwrap constructor with no byte swapping-#else-fromLE = B.fromLE  -- byte swap if necessary-#endif+fromLE = B.fromLE  toLE :: WordM -> WordLE-#ifdef MLKEM_FORCE_LITTLE_ENDIAN_ARCH-toLE = B.LE  -- wrap constructor with no byte swapping-#else-toLE = B.toLE  -- byte swap if necessary-#endif+toLE = B.toLE  #else 

@@ -72,7 +72,7 @@ checkPinned b = assertPinned b (ScrubbedBlock b)  scrubbed :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (MutableBlock ty (PrimState prim))-scrubbed b = unsafePrimFromIO (scheduleBlockScrubbing b >> return b)+scrubbed b = unsafePrimFromIO (b <$ scheduleBlockScrubbing b)  wakeUpAfterInception :: MutableBlock ty s -> MutableBlock ty RealWorld wakeUpAfterInception = unsafeCoerce  -- sometimes disappointing

@@ -24,6 +24,7 @@ import GHC.IO.Exception (IOErrorType(..))  import System.Directory (doesFileExist)+import System.FileLock (FileLock, SharedExclusive(..), unlockFile, withFileLock) import System.IO.Error (catchIOError, mkIOError) import System.Process (readProcess) @@ -180,16 +181,30 @@   where     scriptPath = "tests/get-vectors.sh"     free _ = return ()-    alloc = do+    whenNeeded action = do         keyGenExists <- doesFileExist "tests/keyGen.json.gz"         encapDecapExists <- doesFileExist "tests/encapDecap.json.gz"-        unless (keyGenExists && encapDecapExists) $ catchIOError+        unless (keyGenExists && encapDecapExists) action+    alloc = withTestLock Shared $ \lock -> whenNeeded $ do+        unlockFile lock  -- sanity before lock upgrade+        withTestLock Exclusive $ \_ -> whenNeeded $ catchIOError             (void $ readProcess "/bin/sh" [scriptPath] "")             (\e ->                 let msg = "Could not download test vectors, you will need to run the script `" ++                             scriptPath ++ "' manually. Script failure was: " ++ show e                  in ioError (mkIOError OtherError msg Nothing Nothing)             )++withTestLock :: SharedExclusive -> (FileLock -> IO a) -> IO a+withTestLock mode what = do+    -- locking a hidden file in the directory prevents a race condition between+    -- two instances of the test suite trying both to download the test vectors+    -- (otherwise one instance may try to run with files not fully downloaded+    -- yet by the other instance)+    let path = "tests/.lock"+    exists <- doesFileExist path+    unless exists $ writeFile path "DO NOT DELETE"+    withFileLock path mode what  keyGenVectors :: (String -> IO ()) -> Assertion keyGenVectors step = do

@@ -2,7 +2,7 @@  DESTDIR="`dirname "$0"`" -REF=commit/cbb097019deb25eb966932ee293d89417482d8bc+REF=commit/9d33b0c138bee155d78a3feae3bf3d8d79057652 CURL=curl  for KEY in keyGen encapDecap; do