Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-mlkem for openSUSE:Factory checked in at 2026-11-06 19:49:18 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-mlkem (Old) and /work/SRC/openSUSE:Factory/.ghc-mlkem.new.3759290 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-mlkem" Fri Nov 6 19:49:18 2026 rev:2 rq:1395544 version:0.2.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-mlkem/ghc-mlkem.changes 2026-06-22 17:43:54.812196979 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-mlkem.new.3759290/ghc-mlkem.changes 2026-11-06 19:56:06.459486759 +0100 @@ -1,0 +2,28 @@ +Sun Aug 16 07:27:54 UTC 2026 - Peter Simons <[email protected]> + +- Update mlkem to version 0.2.3.0. + ## 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 + +------------------------------------------------------------------- +Sun Jun 28 08:56:43 UTC 2026 - Peter Simons <[email protected]> + +- Update mlkem to version 0.2.2.0. + ## 0.2.2.0 - 2026-06-28 + + * Clearing buffers containing secrets is more resilient and takes into account + the possibility of asynchronous exceptions + + * Improve optimizations a bit more. Sometimes vector rewrite rules were not + triggered early enough to fuse polynomial allocations at element level. + + * Modular reduction and constant-time selection now use an arithmetic shift + instead of a logical shift. This makes no difference with LLVM but saves one + instruction with the NCG. + +------------------------------------------------------------------- Old: ---- mlkem-0.2.1.0.tar.gz New: ---- mlkem-0.2.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-mlkem.spec ++++++ --- /var/tmp/diff_new_pack.pfbPiI/_old 2026-11-06 19:56:08.354566108 +0100 +++ /var/tmp/diff_new_pack.pfbPiI/_new 2026-11-06 19:56:08.357566233 +0100 @@ -20,7 +20,7 @@ %global pkgver %{pkg_name}-%{version} %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.1.0 +Version: 0.2.3.0 Release: 0 Summary: Module-Lattice-based Key-Encapsulation Mechanism License: BSD-3-Clause @@ -46,6 +46,8 @@ BuildRequires: ghc-bytestring-prof BuildRequires: ghc-directory-devel BuildRequires: ghc-directory-prof +BuildRequires: ghc-filelock-devel +BuildRequires: ghc-filelock-prof BuildRequires: ghc-process-devel BuildRequires: ghc-process-prof BuildRequires: ghc-tasty-devel ++++++ mlkem-0.2.1.0.tar.gz -> mlkem-0.2.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/CHANGELOG.md new/mlkem-0.2.3.0/CHANGELOG.md --- old/mlkem-0.2.1.0/CHANGELOG.md 2026-05-27 22:09:56.000000000 +0200 +++ new/mlkem-0.2.3.0/CHANGELOG.md 2026-08-16 08:42:39.000000000 +0200 @@ -1,5 +1,25 @@ # 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 + the possibility of asynchronous exceptions + +* Improve optimizations a bit more. Sometimes vector rewrite rules were not + triggered early enough to fuse polynomial allocations at element level. + +* Modular reduction and constant-time selection now use an arithmetic shift + instead of a logical shift. This makes no difference with LLVM but saves one + instruction with the NCG. + ## 0.2.1.0 - 2026-05-28 * Function `generateOpen` is added to return not only the key pair but also the diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/mlkem.cabal new/mlkem-0.2.3.0/mlkem.cabal --- old/mlkem-0.2.1.0/mlkem.cabal 2026-05-27 22:10:46.000000000 +0200 +++ new/mlkem-0.2.3.0/mlkem.cabal 2026-08-15 15:08:30.000000000 +0200 @@ -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.1.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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Auxiliary.hs new/mlkem-0.2.3.0/src/Auxiliary.hs --- old/mlkem-0.2.1.0/src/Auxiliary.hs 2026-05-05 16:40:46.000000000 +0200 +++ new/mlkem-0.2.3.0/src/Auxiliary.hs 2026-08-15 09:30:03.000000000 +0200 @@ -38,6 +38,9 @@ import Control.Monad.ST import Data.Bits +#ifdef __GLASGOW_HASKELL_LLVM__ +import Data.Int +#endif import Data.Proxy import Data.Word @@ -92,11 +95,38 @@ -- 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 = negate (subtracted `unsafeShiftR` 15) -{-# INLINE reduceSimple #-} + mask = subtracted `unsafeShiftIR` 15 + + 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 @@ -403,12 +433,12 @@ -- Compress a polynomial with π < 12 rcompress :: Classified marking => Int -> Rq marking -> BlockN marking N Word16 -rcompress !d (Rq a) = BlockN.mapEqPrimSize (compress d) a +rcompress d (Rq a) = BlockN.seq d $ BlockN.mapEqPrimSize (compress d) a {-# INLINE rcompress #-} -- Decompress a polynomial with π < 12 rdecompress :: Classified marking => Int -> BlockN marking N Word16 -> Rq marking -rdecompress !d = Rq . BlockN.mapEqPrimSize (decompress d) +rdecompress d = Rq . BlockN.seq d . BlockN.mapEqPrimSize (decompress d) {-# INLINE rdecompress #-} -- Generates a pseudorandom element of Tπ from a seed and two indices diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Block.hs new/mlkem-0.2.3.0/src/Block.hs --- old/mlkem-0.2.1.0/src/Block.hs 2026-05-26 06:40:40.000000000 +0200 +++ new/mlkem-0.2.3.0/src/Block.hs 2026-07-29 07:19:42.000000000 +0200 @@ -11,9 +11,9 @@ {-# LANGUAGE CPP #-} module Block ( Block, MutableBlock, blockIndex, blockRead, blockWrite - , foldZipWith, Block.length, mutableContents + , 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 @@ -68,6 +68,9 @@ length :: PrimType ty => Block ty -> CountOf ty length = CountOf . sizeofPrimArray +getMutableLength :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> prim (CountOf ty) +getMutableLength = fmap CountOf . getSizeofMutablePrimArray + mutableContents :: MutableBlock ty s -> Ptr ty mutableContents = mutablePrimArrayContents -- pinned only @@ -106,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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/BlockN.hs new/mlkem-0.2.3.0/src/BlockN.hs --- old/mlkem-0.2.1.0/src/BlockN.hs 2026-05-26 06:41:33.000000000 +0200 +++ new/mlkem-0.2.3.0/src/BlockN.hs 2026-08-12 12:33:50.000000000 +0200 @@ -13,7 +13,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module BlockN ( BlockN, MutableBlockN, index, iterModify, mapEqPrimSize - , BlockN.read, runNew, runThaw, runFold, BlockN.unsafeCast + , BlockN.read, runNew, runThaw, runFold, BlockN.seq, BlockN.unsafeCast , BlockN.write, BlockN.zipWith #ifdef ML_KEM_TESTING , create, BlockN.fromList, BlockN.replicate, BlockN.toList @@ -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 #-} @@ -188,6 +189,10 @@ runFold a f = runContext . foldContext f (thawContext a) {-# INLINE runFold #-} +seq :: (Classified marking, KnownNat n, PrimType a) => b -> BlockN marking n a -> BlockN marking n a +seq b a = runContext (seqContext b (thawContext a)) +{-# INLINE seq #-} + thaw :: (Classified marking, PrimMonad prim) => BlockN marking n a -> prim (MutableBlockN marking n a (PrimState prim)) thaw = fmap MutableBlockN . SecureBlock.thaw . unBlockN @@ -216,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 -> 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 #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Crypto.hs new/mlkem-0.2.3.0/src/Crypto.hs --- old/mlkem-0.2.1.0/src/Crypto.hs 2026-04-02 20:04:54.000000000 +0200 +++ new/mlkem-0.2.3.0/src/Crypto.hs 2026-08-12 08:06:43.000000000 +0200 @@ -20,7 +20,7 @@ import Crypto.Hash.Algorithms import Crypto.Hash.IO -import Control.Exception (assert) +import Control.Exception (assert, finally) import Control.Monad import Control.Monad.ST @@ -47,6 +47,10 @@ import qualified ScrubbedBlock import qualified Vector +unsafeShiftIR :: Word -> Int -> Word +unsafeShiftIR x s = fromIntegral ((fromIntegral x :: Int) `unsafeShiftR` s) +{-# INLINE unsafeShiftIR #-} + newtype BoolW = BoolW Word #ifdef ML_KEM_TESTING @@ -74,7 +78,7 @@ eqW a b = isZeroW (a `xor` b) where isZeroW x = BoolW $ msbW (complement x .&. (x - 1)) - msbW x = negate (x `unsafeShiftR` (bitsW - 1)) + msbW x = x `unsafeShiftIR` (bitsW - 1) assertMultW :: Int -> a -> a assertMultW n = assert (n .&. mask == 0) @@ -91,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 @@ -145,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 @@ -222,9 +231,15 @@ hashToBlock = BlockDigest . Builder.runToBlock . hashWith (undefined :: a) hashWith :: forall marking a ba. (HashAlgorithm a, ByteArrayAccess ba) => a -> ba -> Builder marking -hashWith a ba = Builder.unsafeCreate (hashDigestSize a) $ \dig -> do - ctx <- hashMutableInit - hashMutableUpdate (ctx :: MutableContext a) ba - B.withByteArray ctx $ \pctx -> do - hashInternalFinalize (castPtr pctx :: Ptr (Context a)) dig - fillBytes pctx 0 (B.length ctx) +hashWith a ba = Builder.unsafeCreate (hashDigestSize a) $ \dig -> + withScrubbedContext a $ \ctx -> do + hashMutableUpdate (ctx :: MutableContext a) ba + B.withByteArray ctx $ \pctx -> + hashInternalFinalize (castPtr pctx :: Ptr (Context a)) dig + +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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Endian.hs new/mlkem-0.2.3.0/src/Endian.hs --- old/mlkem-0.2.1.0/src/Endian.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/mlkem-0.2.3.0/src/Endian.hs 2026-08-13 08:47:53.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Fusion.hs new/mlkem-0.2.3.0/src/Fusion.hs --- old/mlkem-0.2.1.0/src/Fusion.hs 2026-04-19 14:33:37.000000000 +0200 +++ new/mlkem-0.2.3.0/src/Fusion.hs 2026-08-12 12:33:50.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/K_PKE.hs new/mlkem-0.2.3.0/src/K_PKE.hs --- old/mlkem-0.2.1.0/src/K_PKE.hs 2026-04-20 19:17:06.000000000 +0200 +++ new/mlkem-0.2.3.0/src/K_PKE.hs 2026-08-12 12:33:50.000000000 +0200 @@ -100,11 +100,12 @@ view384 (Offset i) = B.view input (384 * i) 384 createMatrix :: KnownNat k => Bytes -> Vector k (Vector k (Tq Pub)) -createMatrix !rho = Matrix.create $ \(Offset i) (Offset j) -> +createMatrix rho = Vector.seq rho $ Matrix.create $ \(Offset i) (Offset j) -> Aux.sampleNTT rho (fromIntegral j) (fromIntegral i) createVector :: (KnownNat k, ByteArrayAccess s) => Word -> s -> Int -> Vector k (Rq Sec) -createVector !eta !s !j = Vector.create $ \(Offset i) -> sample eta s (i + j) +createVector eta s j = Vector.seq eta $ Vector.seq s $ Vector.seq j $ + Vector.create $ \(Offset i) -> sample eta s (i + j) {-# INLINE createVector #-} sample :: ByteArrayAccess s => Word -> s -> Int -> Rq Sec diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Machine.hs new/mlkem-0.2.3.0/src/Machine.hs --- old/mlkem-0.2.1.0/src/Machine.hs 2026-03-23 08:06:20.000000000 +0100 +++ new/mlkem-0.2.3.0/src/Machine.hs 2026-08-13 08:47:53.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Matrix.hs new/mlkem-0.2.3.0/src/Matrix.hs --- old/mlkem-0.2.1.0/src/Matrix.hs 2026-04-19 14:33:37.000000000 +0200 +++ new/mlkem-0.2.3.0/src/Matrix.hs 2026-07-29 07:19:42.000000000 +0200 @@ -6,7 +6,6 @@ -- A matrix here is simply a vector of vectors. The module also implements -- two utility functions 'mulw' and 'muly' that multiply a matrix and a vector. -- -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Matrix ( create, mulw, muly @@ -27,13 +26,16 @@ index :: Vector m (Vector n ty) -> Offset ty -> Offset (Vector n ty) -> ty index a i j = Vector.index (Vector.index a j) i -mulw :: (KnownNat n, BiMulAdd b a) => Vector m (Vector n b) -> Vector m a -> Vector n a -> Vector n a -mulw a !u !b = Vector.create $ \(Offset i) -> - Vector.biMulFoldIndexWith (\(Offset j) vu -> (index a (Offset i) (Offset j), vu)) (Vector.index b (Offset i)) u +mulw :: BiMulAdd b a => Vector m (Vector n b) -> Vector m a -> Vector n a -> Vector n a +mulw a u b = Vector.seq u (Vector.mapIx f b) + where + f (Offset i) bv = + let g (Offset j) vu = (index a (Offset i) (Offset j), vu) + in Vector.biMulFoldIndexWith g bv u {-# INLINE mulw #-} muly :: BiMulAdd b a => Vector m (Vector n b) -> Vector n a -> Vector m a -muly a !u = fmap (`Vector.dot` u) a +muly a u = Vector.seq u (fmap (`Vector.dot` u) a) {-# INLINE muly #-} #ifdef ML_KEM_TESTING diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/ScrubbedBlock.hs new/mlkem-0.2.3.0/src/ScrubbedBlock.hs --- old/mlkem-0.2.1.0/src/ScrubbedBlock.hs 2026-05-26 06:40:40.000000000 +0200 +++ new/mlkem-0.2.3.0/src/ScrubbedBlock.hs 2026-07-29 07:19:42.000000000 +0200 @@ -7,6 +7,17 @@ -- finalizer when not referenced anymore. Same pattern as ScrubbedBytes from -- package memory but for blocks. -- +-- A complication here is that we distinguish between mutable and immutable +-- values. And for resiliency against asynchronous exceptions, we need to +-- schedule block scrubbing with a finalizer right at the beginning when the +-- block is still in mutable form. Fortunately, for the perspective of the GC, +-- ByteArray# and MutableByteArray# are really the same heap object in disguise +-- and unsafeFreezeByteArray# is a true no-op. So the finalizer set on the +-- initial MutableByteArray# value gets transferred transparently to the final +-- ByteArray# form. +-- +-- See GHC note [primOpEffect of unsafe freezes and thaws] +-- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} module ScrubbedBlock @@ -21,6 +32,8 @@ import Data.Word +import Unsafe.Coerce + import Base import Block (Block, MutableBlock) import qualified Block @@ -41,13 +54,13 @@ length (ScrubbedBlock b) = Block.length b new :: (PrimType ty, PrimMonad prim) => CountOf ty -> prim (MutableBlock ty (PrimState prim)) -new = Block.newPinned -- always pinned +new n = Block.newPinned n >>= scrubbed -- always pinned thaw :: PrimMonad m => ScrubbedBlock ty -> m (MutableBlock ty (PrimState m)) -thaw (ScrubbedBlock b) = Block.thawPinned b -- always pinned +thaw (ScrubbedBlock b) = Block.thawPinned b >>= scrubbed -- always pinned unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (ScrubbedBlock ty) -unsafeFreeze mb = Block.unsafeFreeze mb >>= scrubbed +unsafeFreeze mb = checkPinned <$> Block.unsafeFreeze mb {- internal -} @@ -55,21 +68,26 @@ assertPinned :: Block ty -> a -> a assertPinned mb = assert (Block.isPrimArrayPinned mb) -scrubbed :: PrimMonad prim => Block ty -> prim (ScrubbedBlock ty) -scrubbed b = assertPinned b $ unsafePrimFromIO $ - scheduleBlockScrubbing b >> return (ScrubbedBlock b) +checkPinned :: Block ty -> ScrubbedBlock ty +checkPinned b = assertPinned b (ScrubbedBlock b) -scheduleBlockScrubbing :: Block ty -> IO () -scheduleBlockScrubbing b = addBlockFinalizer b (scrub $ Block.unsafeCast b) +scrubbed :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (MutableBlock ty (PrimState prim)) +scrubbed b = unsafePrimFromIO (b <$ scheduleBlockScrubbing b) + +wakeUpAfterInception :: MutableBlock ty s -> MutableBlock ty RealWorld +wakeUpAfterInception = unsafeCoerce -- sometimes disappointing + +scheduleBlockScrubbing :: MutableBlock ty s -> IO () +scheduleBlockScrubbing b = addBlockFinalizer b (scrub $ Block.unsafeCastMut b') + where b' = wakeUpAfterInception b {-# NOINLINE scheduleBlockScrubbing #-} -scrub :: Block Word8 -> IO () -scrub b = Block.unsafeThaw b >>= erase len - where CountOf len = Block.length b - -addBlockFinalizer :: Block ty -> IO () -> IO () -addBlockFinalizer (Block.PrimArray barr) (IO finalizer) = IO $ \s -> - case mkWeak# barr () finalizer s of { (# s1, _ #) -> (# s1, () #) } +scrub :: MutableBlock Word8 RealWorld -> IO () +scrub b = Block.getMutableLength b >>= \(CountOf len) -> erase len b + +addBlockFinalizer :: MutableBlock ty s -> IO () -> IO () +addBlockFinalizer (Block.MutablePrimArray mbarr) (IO finalizer) = IO $ \s -> + case mkWeak# mbarr () finalizer s of { (# s1, _ #) -> (# s1, () #) } erase :: Int -> MutableBlock Word8 RealWorld -> IO () erase (I# len) (Block.MutablePrimArray mbarr) = IO $ \s1 -> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/src/Vector.hs new/mlkem-0.2.3.0/src/Vector.hs --- old/mlkem-0.2.1.0/src/Vector.hs 2026-04-19 14:33:37.000000000 +0200 +++ new/mlkem-0.2.3.0/src/Vector.hs 2026-07-29 07:19:42.000000000 +0200 @@ -14,7 +14,7 @@ module Vector ( Vector, Vector.concatMap, Vector.dot , Vector.fold1ZipWith, Vector.biMulFoldIndexWith, Vector.toNormalForm - , Vector.create, Vector.index + , Vector.create, Vector.index, mapIx, Vector.seq #ifdef ML_KEM_TESTING , Vector.replicateM #endif @@ -72,8 +72,9 @@ arrayLength :: Array ty -> CountOf ty arrayLength = CountOf . sizeofSmallArray -arrayMap :: (a -> b) -> Array a -> Array b -arrayMap f a = arrayCreate (CountOf sz) $ \(Offset i) -> f $ arrayIndex a (Offset i) +arrayMapIx :: (Offset a -> a -> b) -> Array a -> Array b +arrayMapIx f a = arrayCreate (CountOf sz) $ \(Offset i) -> + let off = Offset i in f off (arrayIndex a off) where CountOf sz = arrayLength a arrayNew :: PrimMonad prim => CountOf ty -> prim (MArray ty (PrimState prim)) @@ -81,25 +82,21 @@ where placeholder = error "arrayNew: unexpected evaluation" create :: forall n a. KnownNat n => (Offset a -> a) -> Vector n a -create = genericCreate -{-# INLINE create #-} - -genericCreate :: forall n a a'. KnownNat n => (Offset a' -> a) -> Vector n a -genericCreate f = Vector $ arrayCreate (CountOf sz) (\(Offset !i) -> f (Offset i)) +create f = Vector $ arrayCreate (CountOf sz) (\(Offset !i) -> f (Offset i)) where !sz = fromIntegral $ natVal (Proxy :: Proxy n) -{-# INLINE [0] genericCreate #-} +{-# INLINE [2] create #-} -genericCreateZipLeft :: KnownNat n => (a -> b -> c) -> (Offset a' -> a) -> Vector n b -> Vector n c -genericCreateZipLeft f g a = genericCreate $ \off@(Offset i) -> f (g off) (index a (Offset i)) -{-# INLINE [0] genericCreateZipLeft #-} - -genericCreateZipRight :: KnownNat n => (a -> b -> c) -> (Offset b' -> b) -> Vector n a -> Vector n c -genericCreateZipRight f g a = genericCreate $ \off@(Offset i) -> f (index a (Offset i)) (g off) -{-# INLINE [0] genericCreateZipRight #-} +mapIx :: (Offset a -> a -> b) -> Vector n a -> Vector n b +mapIx = mapVectorIx +{-# INLINE [2] mapIx #-} mapVector :: (a -> b) -> Vector n a -> Vector n b -mapVector f = Vector <$> arrayMap f . unVector -{-# INLINE [0] mapVector #-} +mapVector f = mapVectorIx $ \_ x -> f x +{-# INLINE [2] mapVector #-} + +mapVectorIx :: (Offset a -> a -> b) -> Vector n a -> Vector n b +mapVectorIx f = Vector <$> arrayMapIx f . unVector +{-# INLINE [1] mapVectorIx #-} arrayIndex :: Array a -> Offset a -> a #ifdef ML_KEM_TESTING @@ -124,13 +121,14 @@ mapToList f (Vector a) = Prelude.map (f . arrayIndex a . Offset) (offsets sa) where CountOf sa = arrayLength a +seq :: b -> Vector n a -> Vector n a +seq = Prelude.seq +{-# INLINE [1] seq #-} + zipWith :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c -zipWith f (Vector a) (Vector !b) = Vector $ - arrayCreate (CountOf sa) $ \(Offset i) -> - f (arrayIndex a (Offset i)) (arrayIndex b (Offset i)) - where - CountOf sa = arrayLength a -{-# INLINE [0] zipWith #-} +zipWith f a (Vector !b) = mapVectorIx g a + where g (Offset i) x = f x $ arrayIndex b (Offset i) +{-# INLINE [2] zipWith #-} fold1ZipWith :: (c -> a -> b -> c) -> (a -> b -> c) -> Vector n a -> Vector n b -> c fold1ZipWith f g (Vector a) (Vector !b) = @@ -158,18 +156,47 @@ {-# INLINE dot #-} toNormalForm :: NFData a => Vector n a -> () -toNormalForm = foldl' (\acc x -> acc `seq` rnf x) () . unVector +toNormalForm = foldl' (\acc x -> acc `Prelude.seq` rnf x) () . unVector + + +-- Rewrite rules +-- +-- A first set of rules before Phase 2 performs simplifications between the four +-- main functions: create, mapVector, mapIx, and zipWith. +-- +-- During Phase 2, the functions are then inlined. While function create +-- is replaced with its final form as call to arrayCreate, the three other +-- functions mapVector, mapIx, and zipWith all become calls to mapVectorIx. +-- Then, nested calls to mapVectorIx can further be simplified using rule +-- "mapVectorIx/mapVectorIx". +-- +-- Finally at Phase 1 the function mapVectorIx is replaced with a call to +-- arrayCreate. +-- +-- Both layers of rules have transformations that push calls to Vector.seq +-- outwards. Normal 'Prelude.seq' or the use of bang patterns would prevent +-- rewrite rules from firing. {-# RULES -"mapVector/mapVector" [~0] forall f g a. mapVector f (mapVector g a) = mapVector (f . g) a -"mapVector/genericCreate" [~0] forall f g. mapVector f (genericCreate g) = genericCreate (f . g) -"zipWith/genericCreate left" [~0] forall f g b. Vector.zipWith f (genericCreate g) b = genericCreateZipLeft f g b -"zipWith/genericCreate right" [~0] forall f g a. Vector.zipWith f a (genericCreate g) = genericCreateZipRight f g a -"genericCreateZipLeft/mapVector" [~0] forall f g h b. genericCreateZipLeft f g (mapVector h b) = genericCreateZipLeft (\aa bb -> f aa (h bb)) g b -"genericCreateZipRight/mapVector" [~0] forall f g h a. genericCreateZipRight f g (mapVector h a) = genericCreateZipRight (f . h) g a -"genericCreateZipLeft/genericCreate" [~0] forall f g h. genericCreateZipLeft f g (genericCreate h) = genericCreate $ \(Offset i) -> f (g (Offset i)) (h (Offset i)) -"genericCreateZipRight/genericCreate" [~0] forall f g h. genericCreateZipRight f g (genericCreate h) = genericCreate $ \(Offset i) -> f (h (Offset i)) (g (Offset i)) -"zipWith/mapVector left" [~0] forall f g a. Vector.zipWith f (mapVector g a) = Vector.zipWith (f . g) a -"zipWith/mapVector right" [~0] forall f g a b. Vector.zipWith f a (mapVector g b) = Vector.zipWith (\aa bb -> f aa (g bb)) a b -"mapVector/zipWith" [~0] forall f g a b. mapVector f (Vector.zipWith g a b) = Vector.zipWith (\aa bb -> f (g aa bb)) a b +"mapVector/mapVector" [~2] forall f g a. mapVector f (mapVector g a) = mapVector (f . g) a +"mapVector/mapIx" [~2] forall f g a. mapVector f (mapIx g a) = mapIx (\i -> f . g i) a +"mapVector/create" [~2] forall f g. mapVector f (create g) = create (\(Offset i) -> f (g (Offset i))) +"mapVector/zipWith" [~2] forall f g a b. mapVector f (Vector.zipWith g a b) = Vector.zipWith (\x -> f . g x) a b +"mapVector/seq" [~2] forall f a b. mapVector f (Vector.seq b a) = Vector.seq b (mapVector f a) + +"zipWith/mapVector left" [~2] forall f g a. Vector.zipWith f (mapVector g a) = Vector.zipWith (f . g) a +"zipWith/mapVector right" [~2] forall f g a b. Vector.zipWith f a (mapVector g b) = Vector.zipWith (\aa bb -> f aa (g bb)) a b +"zipWith/create left" [~2] forall f g. Vector.zipWith f (create g) = mapIx (\(Offset i) -> f (g (Offset i))) +"zipWith/create right" [~2] forall f g a. Vector.zipWith f a (create g) = mapIx (\(Offset i) x -> f x (g (Offset i))) a +"zipWith/zipWith right" [~2] forall f g a b c. Vector.zipWith f a (Vector.zipWith g b c) = Vector.zipWith (flip f) (Vector.zipWith g b c) a +"zipWith/seq left" [~2] forall f a b c. Vector.zipWith f (Vector.seq c a) b = Vector.seq c (Vector.zipWith f a b) +"zipWith/seq right" [~2] forall f a b c. Vector.zipWith f a (Vector.seq c b) = Vector.seq c (Vector.zipWith f a b) + +"mapIx/mapVector" [~2] forall f g a. mapIx f (mapVector g a) = mapIx (\(Offset i) -> f (Offset i) . g) a +"mapIx/mapIx" [~2] forall f g a. mapIx f (mapIx g a) = mapIx (\(Offset i) -> f (Offset i) . g (Offset i)) a +"mapIx/create" [~2] forall f g. mapIx f (create g) = create (\(Offset i) -> f (Offset i) (g (Offset i))) +"mapIx/seq" [~2] forall f a b. mapIx f (Vector.seq b a) = Vector.seq b (mapIx f a) + +"mapVectorIx/mapVectorIx" [~1] forall f g a. mapVectorIx f (mapVectorIx g a) = mapVectorIx (\(Offset i) -> f (Offset i) . g (Offset i)) a +"mapVectorIx/seq" [~1] forall f a b. mapVectorIx f (Vector.seq b a) = Vector.seq b (mapVectorIx f a) #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/tests/Tests.hs new/mlkem-0.2.3.0/tests/Tests.hs --- old/mlkem-0.2.1.0/tests/Tests.hs 2026-05-26 06:41:57.000000000 +0200 +++ new/mlkem-0.2.3.0/tests/Tests.hs 2026-08-16 08:42:30.000000000 +0200 @@ -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,10 +181,13 @@ 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 `" ++ @@ -191,6 +195,17 @@ 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 step "Reading test vectors ..." diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/mlkem-0.2.1.0/tests/get-vectors.sh new/mlkem-0.2.3.0/tests/get-vectors.sh --- old/mlkem-0.2.1.0/tests/get-vectors.sh 2025-10-25 16:22:53.000000000 +0200 +++ new/mlkem-0.2.3.0/tests/get-vectors.sh 2026-08-14 07:47:44.000000000 +0200 @@ -2,12 +2,12 @@ DESTDIR="`dirname "$0"`" -REF=commit/cbb097019deb25eb966932ee293d89417482d8bc +REF=commit/9d33b0c138bee155d78a3feae3bf3d8d79057652 CURL=curl for KEY in keyGen encapDecap; do FILENAME="$DESTDIR"/$KEY.json.gz URL=https://codeberg.org/ocheron/hs-mlkem/raw/$REF/tests/$KEY.json.gz - "$CURL" --silent -o "$FILENAME" "$URL" || exit $? + "$CURL" --silent --fail -o "$FILENAME" "$URL" || exit $? done
