diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,6 @@ +# Changelog + +- 0.1.0 (2025-12-21) + * Initial release, supporting wide, wider, and secp256k1-related + Montgomery-form words with supporting constant-time operations. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,147 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Word.Wider (Wider) +import qualified Numeric.Montgomery.Secp256k1.Curve as C +import qualified Numeric.Montgomery.Secp256k1.Scalar as S +import Criterion.Main +import Prelude hiding (exp, sqrt) + +main :: IO () +main = defaultMain [ + add + , sub + , mul + , sqr + , inv + , exp + , sqrt + , redc + , retr + ] + +add :: Benchmark +add = + let !c1 = 1 :: C.Montgomery + !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s1 = 1 :: S.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "add" [ + bench "curve: M(1) + M(2)" $ nf (C.add c1) c2 + , bench "curve: M(1) + M(2 ^ 255 - 19)" $ nf (C.add c1) c_big + , bench "scalar: M(1) + M(2)" $ nf (S.add s1) s2 + , bench "scalar: M(1) + M(2 ^ 255 - 19)" $ nf (S.add s1) s_big + ] + +sub :: Benchmark +sub = + let !c_max = (2 ^ 255 - 1) :: C.Montgomery + !c1 = 1 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s_max = (2 ^ 255 - 1) :: S.Montgomery + !s1 = 1 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "sub" [ + bench "curve: M(2 ^ 255 - 1) - M(1)" $ nf (C.sub c_max) c1 + , bench "curve: M(2 ^ 255 - 1) - M(2 ^ 255 - 19)" $ + nf (C.sub c_max) c_big + , bench "scalar: M(2 ^ 255 - 1) - M(1)" $ nf (S.sub s_max) s1 + , bench "scalar: M(2 ^ 255 - 1) - M(2 ^ 255 - 19)" $ + nf (S.sub s_max) s_big + ] + +mul :: Benchmark +mul = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "mul" [ + bench "curve: M(2) * M(2)" $ nf (C.mul c2) c2 + , bench "curve: M(2) * M(2 ^ 255 - 19)" $ nf (C.mul c2) c_big + , bench "scalar: M(2) * M(2)" $ nf (S.mul s2) s2 + , bench "scalar: M(2) * M(2 ^ 255 - 19)" $ nf (S.mul s2) s_big + ] + +sqr :: Benchmark +sqr = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "sqr" [ + bench "curve: M(2) ^ 2" $ nf C.sqr c2 + , bench "curve: M(2 ^ 255 - 19) ^ 2" $ nf C.sqr c_big + , bench "scalar: M(2) ^ 2" $ nf S.sqr s2 + , bench "scalar: M(2 ^ 255 - 19) ^ 2" $ nf S.sqr s_big + ] + +inv :: Benchmark +inv = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "inv" [ + bench "curve: M(2) ^ -1" $ nf C.inv c2 + , bench "curve: M(2 ^ 255 - 19) ^ -1" $ nf C.inv c_big + , bench "scalar: M(2) ^ -1" $ nf S.inv s2 + , bench "scalar: M(2 ^ 255 - 19) ^ -1" $ nf S.inv s_big + ] + +sqrt :: Benchmark +sqrt = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + in bgroup "sqrt" [ + bench "curve: sqrt M(2)" $ nf C.sqrt c2 + , bench "curve: sqrt M(2 ^ 255 - 19)" $ nf C.sqrt c_big + ] + +exp :: Benchmark +exp = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + !e2 = 2 :: Wider + !e_big = (2 ^ 255 - 19) :: Wider + in bgroup "exp" [ + bench "curve: M(2) ^ 2" $ nf (C.exp c2) e2 + , bench "curve: M(2 ^ 255 - 19) ^ (2 ^ 255 - 19)" $ + nf (C.exp c_big) e_big + , bench "scalar: M(2) ^ 2" $ nf (S.exp s2) e2 + , bench "scalar: M(2 ^ 255 - 19) ^ (2 ^ 255 - 19)" $ + nf (S.exp s_big) e_big + ] + +redc :: Benchmark +redc = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "redc" [ + bench "curve: REDC(M(2), M(2))" $ nf (C.redc c2) c2 + , bench "curve: REDC(M(2), M(2 ^ 255 - 19))" $ nf (C.redc c2) c_big + , bench "scalar: REDC(M(2), M(2))" $ nf (S.redc s2) s2 + , bench "scalar: REDC(M(2), M(2 ^ 255 - 19))" $ nf (S.redc s2) s_big + ] + +retr :: Benchmark +retr = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in bgroup "retr" [ + bench "curve: RETR(M(2))" $ nf C.retr c2 + , bench "curve: RETR(M(2 ^ 255 - 19))" $ nf C.retr c_big + , bench "scalar: RETR(M(2))" $ nf S.retr s2 + , bench "scalar: RETR(M(2 ^ 255 - 19))" $ nf S.retr s_big + ] diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -0,0 +1,153 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.DeepSeq +import Data.Word.Wider (Wider) +import qualified Data.Word.Wider as W +import qualified Numeric.Montgomery.Secp256k1.Curve as C +import qualified Numeric.Montgomery.Secp256k1.Scalar as S +import Prelude hiding (sqrt, exp) +import Weigh + +-- note that 'weigh' doesn't work properly in a repl +main :: IO () +main = mainWith $ do + num_wider + cmp + add + sub + mul + sqr + inv + exp + sqrt + redc + retr + +num_wider :: Weigh () +num_wider = wgroup "num_wider" $ do + func "small" (force :: Wider -> Wider) 2 + func "large" (force :: Wider -> Wider) + 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed + +cmp :: Weigh () +cmp = + let !a = 1 + !b = 2 + !c = 2 ^ 255 - 19 + in wgroup "cmp" $ do + func "cmp: 1 < 2" (W.cmp a) b + func "cmp: 2 < 1" (W.cmp b) a + func "cmp: 2 < 2 ^ 255 - 19" (W.cmp b) c + func "cmp: 2 ^ 255 - 19 < 2" (W.cmp c) b + +add :: Weigh () +add = + let !c1 = 1 :: C.Montgomery + !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s1 = 1 :: S.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "add" $ do + func "curve: M(1) + M(2)" (C.add c1) c2 + func "curve: M(1) + M(2 ^ 255 - 19)" (C.add c1) c_big + func "scalar: M(1) + M(2)" (S.add s1) s2 + func "scalar: M(1) + M(2 ^ 255 - 19)" (S.add s1) s_big + +sub :: Weigh () +sub = + let !c_max = (2 ^ 255 - 1) :: C.Montgomery + !c1 = 1 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s_max = (2 ^ 255 - 1) :: S.Montgomery + !s1 = 1 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "sub" $ do + func "curve: M(2 ^ 255 - 1) - M(1)" (C.sub c_max) c1 + func "curve: M(2 ^ 255 - 1) - M(2 ^ 255 - 19)" (C.sub c_max) c_big + func "scalar: M(2 ^ 255 - 1) - M(1)" (S.sub s_max) s1 + func "scalar: M(2 ^ 255 - 1) - M(2 ^ 255 - 19)" (S.sub s_max) s_big + +mul :: Weigh () +mul = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "mul" $ do + func "curve: M(2) * M(2)" (C.mul c2) c2 + func "curve: M(2) * M(2 ^ 255 - 19)" (C.mul c2) c_big + func "scalar: M(2) * M(2)" (S.mul s2) s2 + func "scalar: M(2) * M(2 ^ 255 - 19)" (S.mul s2) s_big + +sqr :: Weigh () +sqr = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "sqr" $ do + func "curve: M(2) ^ 2" C.sqr c2 + func "curve: M(2 ^ 255 - 19) ^ 2" C.sqr c_big + func "scalar: M(2) ^ 2" S.sqr s2 + func "scalar: M(2 ^ 255 - 19) ^ 2" S.sqr s_big + +inv :: Weigh () +inv = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "inv" $ do + func "curve: M(2) ^ -1" C.inv c2 + func "curve: M(2 ^ 255 - 19) ^ -1" C.inv c_big + func "scalar: M(2) ^ -1" S.inv s2 + func "scalar: M(2 ^ 255 - 19) ^ -1" S.inv s_big + +exp :: Weigh () +exp = + let !c2 = 2 :: C.Montgomery + !s2 = 2 :: S.Montgomery + !sma = 2 :: Wider + !big = (2 ^ 255 - 19) :: Wider + in wgroup "exp" $ do + func "curve: M(2) ^ 2" (C.exp c2) sma + func "curve: M(2) ^ (2 ^ 255 - 19)" (C.exp c2) big + func "scalar: M(2) ^ 2" (S.exp s2) sma + func "scalar: M(2) ^ (2 ^ 255 - 19)" (S.exp s2) big + +sqrt :: Weigh () +sqrt = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + in wgroup "sqrt" $ do + func "curve: sqrt M(2)" C.sqrt c2 + func "curve: sqrt M(2 ^ 255 - 19)" C.sqrt c_big + +redc :: Weigh () +redc = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "redc" $ do + func "curve: REDC(M(2), M(2))" (C.redc c2) c2 + func "curve: REDC(M(2), M(2 ^ 255 - 19))" (C.redc c2) c_big + func "scalar: REDC(M(2), M(2))" (S.redc s2) s2 + func "scalar: REDC(M(2), M(2 ^ 255 - 19))" (S.redc s2) s_big + +retr :: Weigh () +retr = + let !c2 = 2 :: C.Montgomery + !c_big = (2 ^ 255 - 19) :: C.Montgomery + !s2 = 2 :: S.Montgomery + !s_big = (2 ^ 255 - 19) :: S.Montgomery + in wgroup "retr" $ do + func "curve: RETR(M(2))" C.retr c2 + func "curve: RETR(M(2 ^ 255 - 19))" C.retr c_big + func "scalar: RETR(M(2))" S.retr s2 + func "scalar: RETR(M(2 ^ 255 - 19))" S.retr s_big diff --git a/lib/Data/Choice.hs b/lib/Data/Choice.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Choice.hs @@ -0,0 +1,454 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedNewtypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Data.Choice +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Constant-time choice. + +module Data.Choice ( + -- * Choice + Choice + , true# + , false# + , decide + , to_word# + + -- * MaybeWord# + , MaybeWord#(..) + , some_word# + , none_word# + + -- * MaybeWide# + , MaybeWide#(..) + , some_wide# + , just_wide# + , none_wide# + , expect_wide# + , expect_wide_or# + + -- * Construction + , from_word_mask# + , from_word# + , from_word_nonzero# + , from_word_eq# + , from_word_le# + , from_word_lt# + , from_word_gt# + + , from_wide# + , from_wide_le# + + -- * Manipulation + , or# + , and# + , xor# + , not# + , ne# + , eq# + + -- * Constant-time Selection + , select_word# + , select_wide# + , select_wider# + + -- * Constant-time Equality + , eq_word# + , eq_wide# + , eq_wider# + ) where + +import qualified Data.Bits as B +import GHC.Exts (Word#, Int(..), Word(..)) +import qualified GHC.Exts as Exts + +-- utilities ------------------------------------------------------------------ + +-- wrapping negation +neg_w# :: Word# -> Word# +neg_w# w = Exts.plusWord# (Exts.not# w) 1## +{-# INLINE neg_w# #-} + +hi# :: Word# -> (# Word#, Word# #) +hi# w = (# 0##, w #) +{-# INLINE hi# #-} + +lo# :: Word# -> (# Word#, Word# #) +lo# w = (# w, 0## #) +{-# INLINE lo# #-} + +not_w# :: (# Word#, Word# #) -> (# Word#, Word# #) +not_w# (# a0, a1 #) = (# Exts.not# a0, Exts.not# a1 #) +{-# INLINE not_w# #-} + +or_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) +or_w# (# a0, a1 #) (# b0, b1 #) = (# Exts.or# a0 b0, Exts.or# a1 b1 #) +{-# INLINE or_w# #-} + +and_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) +and_w# (# a0, a1 #) (# b0, b1 #) = (# Exts.and# a0 b0, Exts.and# a1 b1 #) +{-# INLINE and_w# #-} + +xor_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) +xor_w# (# a0, a1 #) (# b0, b1 #) = (# Exts.xor# a0 b0, Exts.xor# a1 b1 #) +{-# INLINE xor_w# #-} + +-- subtract-with-borrow +sub_b# :: Word# -> Word# -> Word# -> (# Word#, Word# #) +sub_b# m n b = + let !(# d0, b0 #) = Exts.subWordC# m n + !(# d, b1 #) = Exts.subWordC# d0 b + !c = Exts.int2Word# (Exts.orI# b0 b1) + in (# d, c #) +{-# INLINE sub_b# #-} + +-- wide subtract-with-borrow +sub_wb# + :: (# Word#, Word# #) + -> (# Word#, Word# #) + -> (# Word#, Word#, Word# #) +sub_wb# (# a0, a1 #) (# b0, b1 #) = + let !(# s0, c0 #) = sub_b# a0 b0 0## + !(# s1, c1 #) = sub_b# a1 b1 c0 + in (# s0, s1, c1 #) +{-# INLINE sub_wb# #-} + +-- wide subtraction (wrapping) +sub_w# + :: (# Word#, Word# #) + -> (# Word#, Word# #) + -> (# Word#, Word# #) +sub_w# a b = + let !(# c0, c1, _ #) = sub_wb# a b + in (# c0, c1 #) +{-# INLINE sub_w# #-} + +-- choice --------------------------------------------------------------------- + +-- | Constant-time choice, encoded as a mask. +-- +-- Note that 'Choice' is defined as an unboxed newtype, and so a +-- 'Choice' value cannot be bound at the top level. You should work +-- with it locally in the context of a computation. +-- +-- It's safe to 'decide' a choice, reducing it to a 'Bool', at any +-- time, but the general encouraged pattern is to do that only at the +-- end of a computation. +-- +-- >>> decide (or# (false# ()) (true# ())) +-- True +newtype Choice = Choice Word# + +-- | Construct the falsy value. +-- +-- >>> decide (false# ()) +-- False +false# :: () -> Choice +false# _ = Choice 0## +{-# INLINE false# #-} + +-- | Construct the truthy value. +-- +-- >>> decide (true# ()) +-- True +true# :: () -> Choice +true# _ = case maxBound :: Word of + W# w -> Choice w +{-# INLINE true# #-} + +-- | Decide a 'Choice' by reducing it to a 'Bool'. +-- +-- >>> decide (true# ()) +-- True +decide :: Choice -> Bool +decide (Choice c) = Exts.isTrue# (Exts.neWord# c 0##) +{-# INLINE decide #-} + +-- | Convert a 'Choice' to an unboxed 'Word#'. +to_word# :: Choice -> Word# +to_word# (Choice c) = Exts.and# c 1## +{-# INLINE to_word# #-} + +-- constant time 'Maybe Word#' +newtype MaybeWord# = MaybeWord# (# Word#, Choice #) + +some_word# :: Word# -> MaybeWord# +some_word# w = MaybeWord# (# w, true# () #) +{-# INLINE some_word# #-} + +none_word# :: Word# -> MaybeWord# +none_word# w = MaybeWord# (# w, false# () #) +{-# INLINE none_word# #-} + +-- constant time 'Maybe (# Word#, Word# #)' +newtype MaybeWide# = MaybeWide# (# (# Word#, Word# #), Choice #) + +just_wide# :: (# Word#, Word# #) -> Choice -> MaybeWide# +just_wide# w c = MaybeWide# (# w, c #) +{-# INLINE just_wide# #-} + +some_wide# :: (# Word#, Word# #) -> MaybeWide# +some_wide# w = MaybeWide# (# w, true# () #) +{-# INLINE some_wide# #-} + +none_wide# :: (# Word#, Word# #) -> MaybeWide# +none_wide# w = MaybeWide# (# w, false# () #) +{-# INLINE none_wide# #-} + +expect_wide# :: MaybeWide# -> String -> (# Word#, Word# #) +expect_wide# (MaybeWide# (# w, Choice c #)) msg + | Exts.isTrue# (Exts.eqWord# c t#) = w + | otherwise = error $ "ppad-fixed (expect_wide#): " <> msg + where + !(Choice t#) = true# () +{-# INLINE expect_wide# #-} + +expect_wide_or# :: MaybeWide# -> (# Word#, Word# #) -> (# Word#, Word# #) +expect_wide_or# (MaybeWide# (# w, Choice c #)) alt + | Exts.isTrue# (Exts.eqWord# c t#) = w + | otherwise = alt + where + !(Choice t#) = true# () +{-# INLINE expect_wide_or# #-} + +-- construction --------------------------------------------------------------- + +-- | Construct a 'Choice' from an unboxed mask. +-- +-- The input is /not/ checked. +-- +-- >>> decide (from_word_mask# 0##) +-- False +-- >>> decide (from_word_mask# 0xFFFFFFFFF_FFFFFFFF##) +-- True +from_word_mask# :: Word# -> Choice +from_word_mask# w = Choice w +{-# INLINE from_word_mask# #-} + +-- | Construct a 'Choice' from an unboxed word, which should be either +-- 0## or 1##. +-- +-- The input is /not/ checked. +-- +-- >>> decide (from_word# 1##) +-- True +from_word# :: Word# -> Choice +from_word# w = Choice (neg_w# w) +{-# INLINE from_word# #-} + +-- | Construct a 'Choice' from a two-limb word, constructing a mask from +-- the lower limb, which should be 0## or 1##. +-- +-- The input is /not/ checked. +-- +-- >>> decide (from_wide# (# 0##, 1## #)) +-- False +from_wide# :: (# Word#, Word# #) -> Choice +from_wide# (# l, _ #) = from_word# l +{-# INLINE from_wide# #-} + +-- | Construct a 'Choice' from a /nonzero/ unboxed word. +-- +-- The input is /not/ checked. +-- +-- >>> decide (from_word_nonzero# 2##) +-- True +from_word_nonzero# :: Word# -> Choice +from_word_nonzero# w = + let !n = neg_w# w + !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !v = Exts.uncheckedShiftRL# (Exts.or# w n) s + in from_word# v +{-# INLINE from_word_nonzero# #-} + +-- | Construct a 'Choice' from an equality comparison. +-- +-- >>> decide (from_word_eq# 0## 1##) +-- False +-- decide (from_word_eq# 1## 1##) +-- True +from_word_eq# :: Word# -> Word# -> Choice +from_word_eq# x y = case from_word_nonzero# (Exts.xor# x y) of + Choice w -> Choice (Exts.not# w) +{-# INLINE from_word_eq# #-} + +-- | Construct a 'Choice from an at most comparison. +-- +-- >>> decide (from_word_le# 0## 1##) +-- True +-- >>> decide (from_word_le# 1## 1##) +-- True +from_word_le# :: Word# -> Word# -> Choice +from_word_le# x y = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !bit = + Exts.uncheckedShiftRL# + (Exts.and# + (Exts.or# (Exts.not# x) y) + (Exts.or# (Exts.xor# x y) (Exts.not# (Exts.minusWord# y x)))) + s + in from_word# bit +{-# INLINE from_word_le# #-} + +-- | Construct a 'Choice' from an at most comparison on a two-limb +-- unboxed word. +-- +-- >>> decide (from_wide_le# (# 0##, 0## #) (# 1##, 0## #)) +-- True +-- >>> decide (from_wide_le# (# 1##, 0## #) (# 1##, 0## #)) +-- True +from_wide_le# :: (# Word#, Word# #) -> (# Word#, Word# #) -> Choice +from_wide_le# x y = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !mask = + (and_w# + (or_w# (not_w# x) y) + (or_w# (xor_w# x y) (not_w# (sub_w# y x)))) + !bit = case mask of + (# l, _ #) -> Exts.uncheckedShiftRL# l s + in from_word# bit +{-# INLINE from_wide_le# #-} + +-- | Construct a 'Choice' from a less-than comparison. +-- +-- >>> decide (from_word_lt# 0## 1##) +-- True +-- >>> decide (from_word_lt# 1## 1##) +-- False +from_word_lt# :: Word# -> Word# -> Choice +from_word_lt# x y = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !bit = + Exts.uncheckedShiftRL# + (Exts.or# + (Exts.and# (Exts.not# x) y) + (Exts.and# (Exts.or# (Exts.not# x) y) (Exts.minusWord# x y))) + s + in from_word# bit +{-# INLINE from_word_lt# #-} + +-- | Construct a 'Choice' from a greater-than comparison. +-- +-- >>> decide (from_word_gt# 0## 1##) +-- False +-- >>> decide (from_word_gt# 1## 1##) +-- False +from_word_gt# :: Word# -> Word# -> Choice +from_word_gt# x y = from_word_lt# y x +{-# INLINE from_word_gt# #-} + +-- manipulation --------------------------------------------------------------- + +-- | Logically negate a 'Choice'. +not# :: Choice -> Choice +not# (Choice w) = Choice (Exts.not# w) +{-# INLINE not# #-} + +-- | Logical disjunction on 'Choice' values. +or# :: Choice -> Choice -> Choice +or# (Choice w0) (Choice w1) = Choice (Exts.or# w0 w1) +{-# INLINE or# #-} + +-- | Logical conjunction on 'Choice' values. +and# :: Choice -> Choice -> Choice +and# (Choice w0) (Choice w1) = Choice (Exts.and# w0 w1) +{-# INLINE and# #-} + +-- | Logical inequality on 'Choice' values. +xor# :: Choice -> Choice -> Choice +xor# (Choice w0) (Choice w1) = Choice (Exts.xor# w0 w1) +{-# INLINE xor# #-} + +-- | Logical inequality on 'Choice' values. +ne# :: Choice -> Choice -> Choice +ne# c0 c1 = xor# c0 c1 +{-# INLINE ne# #-} + +-- | Logical equality on 'Choice' values. +eq# :: Choice -> Choice -> Choice +eq# c0 c1 = not# (ne# c0 c1) +{-# INLINE eq# #-} + +-- constant-time selection ---------------------------------------------------- + +-- | Select an unboxed word, given a 'Choice'. +select_word# :: Word# -> Word# -> Choice -> Word# +select_word# a b (Choice c) = Exts.xor# a (Exts.and# c (Exts.xor# a b)) +{-# INLINE select_word# #-} + +-- | Select an unboxed two-limb word, given a 'Choice'. +select_wide# + :: (# Word#, Word# #) + -> (# Word#, Word# #) + -> Choice + -> (# Word#, Word# #) +select_wide# a b (Choice w) = + let !mask = or_w# (hi# w) (lo# w) + in xor_w# a (and_w# mask (xor_w# a b)) +{-# INLINE select_wide# #-} + +-- | Select an unboxed four-limb word, given a 'Choice'. +select_wider# + :: (# Word#, Word#, Word#, Word# #) + -> (# Word#, Word#, Word#, Word# #) + -> Choice + -> (# Word#, Word#, Word#, Word# #) +select_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) (Choice w) = + let !w0 = Exts.xor# a0 (Exts.and# w (Exts.xor# a0 b0)) + !w1 = Exts.xor# a1 (Exts.and# w (Exts.xor# a1 b1)) + !w2 = Exts.xor# a2 (Exts.and# w (Exts.xor# a2 b2)) + !w3 = Exts.xor# a3 (Exts.and# w (Exts.xor# a3 b3)) + in (# w0, w1, w2, w3 #) +{-# INLINE select_wider# #-} + +-- constant-time equality ----------------------------------------------------- + +-- | Compare unboxed words for equality in constant time. +-- +-- >>> decide (eq_word# 0## 1##) +-- False +eq_word# :: Word# -> Word# -> Choice +eq_word# a b = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !x = Exts.xor# a b + !y = Exts.uncheckedShiftRL# (Exts.or# x (neg_w# x)) s + in Choice (Exts.xor# y 1##) +{-# INLINE eq_word# #-} + +-- | Compare unboxed two-limb words for equality in constant time. +-- +-- >>> decide (eq_wide (# 0##, 0## #) (# 0##, 0## #)) +-- True +eq_wide# + :: (# Word#, Word# #) + -> (# Word#, Word# #) + -> Choice +eq_wide# (# a0, a1 #) (# b0, b1 #) = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !x = Exts.or# (Exts.xor# a0 b0) (Exts.xor# a1 b1) + !y = Exts.uncheckedShiftRL# (Exts.or# x (neg_w# x)) s + in Choice (Exts.xor# y 1##) +{-# INLINE eq_wide# #-} + +-- | Compare unboxed four-limb words for equality in constant time. +-- +-- >>> let zero = (# 0##, 0##, 0##, 0## #) in decide (eq_wider# zero zero) +-- True +eq_wider# + :: (# Word#, Word#, Word#, Word# #) + -> (# Word#, Word#, Word#, Word# #) + -> Choice +eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !x = Exts.or# (Exts.or# (Exts.xor# a0 b0) (Exts.xor# a1 b1)) + (Exts.or# (Exts.xor# a2 b2) (Exts.xor# a3 b3)) + !y = Exts.uncheckedShiftRL# (Exts.or# x (neg_w# x)) s + in Choice (Exts.xor# y 1##) +{-# INLINE eq_wider# #-} + diff --git a/lib/Data/Word/Limb.hs b/lib/Data/Word/Limb.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Word/Limb.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UnliftedNewtypes #-} + +-- | +-- Module: Data.Word.Limb +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- The primitive 'Limb' type, as well as operations on it. + +module Data.Word.Limb ( + -- * Limb + Limb(..) + , render + + -- * Bit manipulation and representation + , and# + , or# + , not# + , xor# + , bits# + , shl# + , shl1# + , shr# + , shr1# + + -- * Comparison + , eq# + , ne# + , eq_vartime# + , ne_vartime# + , nonzero# + , lt# + , gt# + + -- * Selection + , select# + , cswap# + + -- * Negation + + , neg# + + -- * Arithmetic + , add_o# + , add_c# + , add_w# + , add_s# + + , sub_b# + , sub_w# + , sub_s# + + , mul_c# + , mul_w# + , mul_s# + + , mac# + ) where + +import qualified Data.Bits as B +import qualified Data.Choice as C +import GHC.Exts (Word#) +import qualified GHC.Exts as Exts + +-- | A 'Limb' is the smallest component of a wider word. +newtype Limb = Limb Word# + +-- | Return a 'Limb' value as a 'String'. +render :: Limb -> String +render (Limb a) = show (Exts.W# a) + +-- comparison ----------------------------------------------------------------- + +-- | Equality comparison. +eq# + :: Limb + -> Limb + -> C.Choice +eq# (Limb a) (Limb b) = C.eq_word# a b +{-# INLINE eq# #-} + +eq_vartime# + :: Limb + -> Limb + -> Bool +eq_vartime# (Limb a) (Limb b) = Exts.isTrue# (Exts.eqWord# a b) +{-# INLINE eq_vartime# #-} + +-- | Inequality comparison. +ne# + :: Limb + -> Limb + -> C.Choice +ne# a b = C.not# (eq# a b) +{-# INLINE ne# #-} + +ne_vartime# + :: Limb + -> Limb + -> Bool +ne_vartime# a b = not (eq_vartime# a b) +{-# INLINE ne_vartime# #-} + +-- | Comparison to zero. +nonzero# + :: Limb + -> C.Choice +nonzero# (Limb a) = C.from_word_nonzero# a +{-# INLINE nonzero# #-} + +-- | Less than. +lt# + :: Limb + -> Limb + -> C.Choice +lt# (Limb a) (Limb b) = C.from_word_lt# a b +{-# INLINE lt# #-} + +-- | Greater than. +gt# + :: Limb + -> Limb + -> C.Choice +gt# (Limb a) (Limb b) = C.from_word_gt# a b +{-# INLINE gt# #-} + +-- selection ------------------------------------------------------------------ + +-- | Return a if c is truthy, otherwise return b. +select# + :: Limb -- ^ a + -> Limb -- ^ b + -> C.Choice -- ^ c + -> Limb -- ^ result +select# (Limb a) (Limb b) c = Limb (C.select_word# a b c) +{-# INLINE select# #-} + +-- | Return (# b, a #) if c is truthy, otherwise return (# a, b #). +cswap# + :: Limb -- ^ a + -> Limb -- ^ b + -> C.Choice -- ^ c + -> (# Limb, Limb #) -- ^ result +cswap# (Limb a) (Limb b) c = + let !l = C.select_word# a b c + !r = C.select_word# b a c + in (# Limb l, Limb r #) +{-# INLINE cswap# #-} + +-- bit manipulation ----------------------------------------------------------- + +-- | Bitwise and. +and# + :: Limb -- ^ a + -> Limb -- ^ b + -> Limb -- ^ a & b +and# (Limb a) (Limb b) = Limb (Exts.and# a b) +{-# INLINE and# #-} + +-- | Bitwise or. +or# + :: Limb -- ^ a + -> Limb -- ^ b + -> Limb -- ^ a | b +or# (Limb a) (Limb b) = Limb (Exts.or# a b) +{-# INLINE or# #-} + +-- | Bitwise not. +not# + :: Limb -- ^ a + -> Limb -- ^ not a +not# (Limb a) = Limb (Exts.not# a) +{-# INLINE not# #-} + +-- | Bitwise exclusive or. +xor# + :: Limb -- ^ a + -> Limb -- ^ b + -> Limb -- ^ a ^ b +xor# (Limb a) (Limb b) = Limb (Exts.xor# a b) +{-# INLINE xor# #-} + +-- | Number of bits required to represent this limb. +bits# + :: Limb -- ^ limb + -> Int -- ^ bits required to represent limb +bits# (Limb a) = + let !_BITS = B.finiteBitSize (0 :: Word) + !zs = B.countLeadingZeros (Exts.W# a) + in _BITS - zs -- XX unbox? +{-# INLINE bits# #-} + +-- | Bit-shift left. +shl# + :: Limb -- ^ limb + -> Exts.Int# -- ^ shift amount + -> Limb -- ^ result +shl# (Limb w) s = Limb (Exts.uncheckedShiftL# w s) +{-# INLINE shl# #-} + +-- | Bit-shift left by 1, returning the result and carry. +shl1# + :: Limb + -> (# Limb, Limb #) +shl1# (Limb w) = + let !s = case B.finiteBitSize (0 :: Word) of Exts.I# m -> m Exts.-# 1# + !r = Exts.uncheckedShiftL# w 1# + !c = Exts.uncheckedShiftRL# w s + in (# Limb r, Limb c #) +{-# INLINE shl1# #-} + +-- | Bit-shift right. +shr# + :: Limb -- ^ limb + -> Exts.Int# -- ^ shift amount + -> Limb -- ^ result +shr# (Limb w) s = Limb (Exts.uncheckedShiftRL# w s) +{-# INLINE shr# #-} + +-- | Bit-shift right by 1, returning the result and carry. +shr1# + :: Limb + -> (# Limb, Limb #) +shr1# (Limb w) = + let !s = case B.finiteBitSize (0 :: Word) of Exts.I# m -> m Exts.-# 1# + !r = Exts.uncheckedShiftRL# w 1# + !c = Exts.uncheckedShiftL# w s + in (# Limb r, Limb c #) +{-# INLINE shr1# #-} + +-- negation ------------------------------------------------------------------- + +-- | Wrapping (two's complement) negation. +neg# + :: Limb + -> Limb +neg# (Limb x) = Limb (Exts.plusWord# (Exts.not# x) 1##) +{-# INLINE neg# #-} + +-- addition ------------------------------------------------------------------- + +-- | Overflowing addition, computing augend + addend, returning the +-- sum and carry. +add_o# + :: Limb -- ^ augend + -> Limb -- ^ addend + -> (# Limb, Limb #) -- ^ (# sum, carry #) +add_o# (Limb a) (Limb b) = case Exts.plusWord2# a b of + (# c, s #) -> (# Limb s, Limb c #) +{-# INLINE add_o# #-} + +-- | Carrying addition, computing augend + addend + carry, returning +-- the sum and new carry. +add_c# + :: Limb -- ^ augend + -> Limb -- ^ addend + -> Limb -- ^ carry + -> (# Limb, Limb #) -- ^ (# sum, new carry #) +add_c# (Limb a) (Limb b) (Limb c) = + let !(# c0, s0 #) = Exts.plusWord2# a b + !(# c1, s #) = Exts.plusWord2# s0 c + in (# Limb s, Limb (Exts.or# c0 c1) #) +{-# INLINE add_c# #-} + +-- | Wrapping addition, computing augend + addend, returning the sum +-- (discarding overflow). +add_w# + :: Limb -- ^ augend + -> Limb -- ^ addend + -> Limb -- ^ sum +add_w# (Limb a) (Limb b) = Limb (Exts.plusWord# a b) +{-# INLINE add_w# #-} + +-- | Saturating addition, computing augend + addend, returning the +-- sum (clamping to the maximum representable value in the case of +-- overflow). +add_s# + :: Limb + -> Limb + -> Limb +add_s# (Limb a) (Limb b) = case Exts.addWordC# a b of + (# s, 0# #) -> Limb s + _ -> case maxBound :: Word of + Exts.W# m -> Limb m +{-# INLINE add_s# #-} + +-- subtraction ---------------------------------------------------------------- + +-- | Borrowing subtraction, computing minuend - (subtrahend + borrow), +-- returning the difference and new borrow mask. +sub_b# + :: Limb -- ^ minuend + -> Limb -- ^ subtrahend + -> Limb -- ^ borrow + -> (# Limb, Limb #) -- ^ (# difference, new borrow #) +sub_b# (Limb m) (Limb n) (Limb a) = + let !s = case B.finiteBitSize (0 :: Word) of Exts.I# bs -> bs Exts.-# 1# + !b = Exts.uncheckedShiftRL# a s + !(# d0, b0 #) = Exts.subWordC# m n + !(# d, b1 #) = Exts.subWordC# d0 b + !c = Exts.int2Word# (Exts.negateInt# (Exts.orI# b0 b1)) + in (# Limb d, Limb c #) +{-# INLINE sub_b# #-} + +-- | Saturating subtraction, computing minuend - subtrahend, returning the +-- difference (and clamping to zero in the case of underflow). +sub_s# + :: Limb -- ^ minuend + -> Limb -- ^ subtrahend + -> Limb -- ^ difference +sub_s# (Limb m) (Limb n) = case Exts.subWordC# m n of + (# d, 0# #) -> Limb d + _ -> Limb 0## +{-# INLINE sub_s# #-} + +-- | Wrapping subtraction, computing minuend - subtrahend, returning the +-- difference (and discarding underflow). +sub_w# + :: Limb -- ^ minuend + -> Limb -- ^ subtrahend + -> Limb -- ^ difference +sub_w# (Limb m) (Limb n) = Limb (Exts.minusWord# m n) +{-# INLINE sub_w# #-} + +-- multiplication ------------------------------------------------------------- + +-- | Widening multiplication, returning low and high words of the product. +mul_c# + :: Limb -- ^ multiplicand + -> Limb -- ^ multiplier + -> (# Limb, Limb #) -- ^ (# low, high #) product +mul_c# (Limb a) (Limb b) = + let !(# h, l #) = Exts.timesWord2# a b + in (# Limb l, Limb h #) +{-# INLINE mul_c# #-} + +-- | Wrapping multiplication, returning only the low word of the product. +mul_w# + :: Limb -- ^ multiplicand + -> Limb -- ^ multiplier + -> Limb -- ^ low word of product +mul_w# (Limb a) (Limb b) = Limb (Exts.timesWord# a b) +{-# INLINE mul_w# #-} + +-- | Saturating multiplication, returning only the low word of the product, +-- and clamping to the maximum value in the case of overflow. +mul_s# + :: Limb -- ^ multiplicand + -> Limb -- ^ multiplier + -> Limb -- ^ clamped low word of product +mul_s# (Limb a) (Limb b) = case Exts.timesWord2# a b of + (# 0##, l #) -> Limb l + _ -> Limb (Exts.not# 0##) +{-# INLINE mul_s# #-} + +-- | Multiply-add-carry, computing a * b + m + c, returning the +-- result along with the new carry. +mac# + :: Limb -- ^ a (multiplicand) + -> Limb -- ^ b (multiplier) + -> Limb -- ^ m (addend) + -> Limb -- ^ c (carry) + -> (# Limb, Limb #) -- ^ a * b + m + c +mac# (Limb a) (Limb b) (Limb m) (Limb c) = + let !(# h, l #) = Exts.timesWord2# a b + !(# l_0, h_0 #) = wadd_w# (# l, h #) m + !(# d, l_1 #) = Exts.plusWord2# l_0 c + !h_1 = Exts.plusWord# h_0 d + in (# Limb l_1, Limb h_1 #) + where + -- wide wrapping addition + wadd_w# :: (# Word#, Word# #) -> Word# -> (# Word#, Word# #) + wadd_w# (# x_lo, x_hi #) y_lo = + let !(# c0, s0 #) = Exts.plusWord2# x_lo y_lo + !(# _, s1 #) = Exts.plusWord2# x_hi c0 + in (# s0, s1 #) + {-# INLINE wadd_w# #-} +{-# INLINE mac# #-} + diff --git a/lib/Data/Word/Wide.hs b/lib/Data/Word/Wide.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Word/Wide.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +-- | +-- Module: Data.Word.Wide +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Wide words, consisting of two 'Limb's. + +module Data.Word.Wide ( + -- * Wide Words + Wide(..) + + -- * Construction, Conversion + , wide + , to + , from + + -- * Bit Manipulation + , or + , or# + , and + , and# + , xor + , xor# + , not + , not# + + -- * Comparison + , eq_vartime + + -- * Arithmetic + , add + , add_o + , sub + , mul + , neg + + -- * Unboxed Arithmetic + , add_o# + , add_w# + , sub_b# + , sub_w# + , mul_w# + , neg# + ) where + +import Control.DeepSeq +import Data.Bits ((.|.), (.&.), (.<<.), (.>>.)) +import qualified Data.Bits as B +import Data.Word.Limb (Limb(..)) +import qualified Data.Word.Limb as L +import GHC.Exts +import Prelude hiding (div, mod, or, and, not, quot, rem, recip) + +-- utilities ------------------------------------------------------------------ + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +-- wide words ----------------------------------------------------------------- + +-- | Little-endian wide words. +data Wide = Wide !(# Limb, Limb #) + +instance Show Wide where + show = show . from + +instance Num Wide where + (+) = add + (-) = sub + (*) = mul + abs = id + fromInteger = to + negate = neg + signum a = case a of + Wide (# Limb 0##, Limb 0## #) -> 0 + _ -> 1 + +instance NFData Wide where + rnf (Wide a) = case a of (# _, _ #) -> () + +-- construction / conversion -------------------------------------------------- + +-- | Construct a 'Wide' word from low and high 'Word's. +wide :: Word -> Word -> Wide +wide (W# l) (W# h) = Wide (# Limb l, Limb h #) + +-- | Convert an 'Integer' to a 'Wide' word. +to :: Integer -> Wide +to n = + let !size = B.finiteBitSize (0 :: Word) + !mask = fi (maxBound :: Word) :: Integer + !(W# w0) = fi (n .&. mask) + !(W# w1) = fi ((n .>>. size) .&. mask) + in Wide (# Limb w0, Limb w1 #) + +-- | Convert a 'Wide' word to an 'Integer'. +from :: Wide -> Integer +from (Wide (# Limb a, Limb b #)) = + fi (W# b) .<<. (B.finiteBitSize (0 :: Word)) + .|. fi (W# a) + +-- comparison ----------------------------------------------------------------- + +-- | Compare 'Wide' words for equality in variable time. +eq_vartime :: Wide -> Wide -> Bool +eq_vartime (Wide (# Limb a0, Limb b0 #)) (Wide (# Limb a1, Limb b1 #)) = + isTrue# (andI# (eqWord# a0 a1) (eqWord# b0 b1)) + +-- bits ----------------------------------------------------------------------- + +or_w# :: (# Limb, Limb #) -> (# Limb, Limb #) -> (# Limb, Limb #) +or_w# (# a0, a1 #) (# b0, b1 #) = (# L.or# a0 b0, L.or# a1 b1 #) +{-# INLINE or_w# #-} + +or :: Wide -> Wide -> Wide +or (Wide a) (Wide b) = Wide (or_w# a b) + +and_w# :: (# Limb, Limb #) -> (# Limb, Limb #) -> (# Limb, Limb #) +and_w# (# a0, a1 #) (# b0, b1 #) = (# L.and# a0 b0, L.and# a1 b1 #) +{-# INLINE and_w# #-} + +and :: Wide -> Wide -> Wide +and (Wide a) (Wide b) = Wide (and_w# a b) + +xor_w# :: (# Limb, Limb #) -> (# Limb, Limb #) -> (# Limb, Limb #) +xor_w# (# a0, a1 #) (# b0, b1 #) = (# L.xor# a0 b0, L.xor# a1 b1 #) +{-# INLINE xor_w# #-} + +xor :: Wide -> Wide -> Wide +xor (Wide a) (Wide b) = Wide (xor_w# a b) + +not_w# :: (# Limb, Limb #) -> (# Limb, Limb #) +not_w# (# a0, a1 #) = (# L.not# a0, L.not# a1 #) +{-# INLINE not_w# #-} + +not :: Wide -> Wide +not (Wide w) = Wide (not_w# w) +{-# INLINE not #-} + +-- negation ------------------------------------------------------------------- + +neg# + :: (# Limb, Limb #) -- ^ argument + -> (# Limb, Limb #) -- ^ (wrapping) additive inverse +neg# w = add_w# (not_w# w) (# Limb 1##, Limb 0## #) +{-# INLINE neg# #-} + +neg + :: Wide -- ^ argument + -> Wide -- ^ (wrapping) additive inverse +neg (Wide w) = Wide (neg# w) + +-- addition, subtraction ------------------------------------------------------ + +-- | Overflowing addition, computing 'a + b', returning the sum and a +-- carry bit. +add_o# + :: (# Limb, Limb #) -- ^ augend + -> (# Limb, Limb #) -- ^ addend + -> (# (# Limb, Limb #), Limb #) -- ^ (# sum, carry bit #) +add_o# (# a0, a1 #) (# b0, b1 #) = + let !(# s0, c0 #) = L.add_o# a0 b0 + !(# s1, c1 #) = L.add_c# a1 b1 c0 + in (# (# s0, s1 #), c1 #) +{-# INLINE add_o# #-} + +-- | Overflowing addition on 'Wide' words, computing 'a + b', returning +-- the sum and carry. +add_o + :: Wide -- ^ augend + -> Wide -- ^ addend + -> (Wide, Word) -- ^ (sum, carry) +add_o (Wide a) (Wide b) = + let !(# s, Limb c #) = add_o# a b + in (Wide s, W# c) + +-- | Wrapping addition, computing 'a + b'. +add_w# + :: (# Limb, Limb #) -- ^ augend + -> (# Limb, Limb #) -- ^ addend + -> (# Limb, Limb #) -- ^ sum +add_w# a b = + let !(# c, _ #) = add_o# a b + in c +{-# INLINE add_w# #-} + +-- | Wrapping addition on 'Wide' words, computing 'a + b'. +add :: Wide -> Wide -> Wide +add (Wide a) (Wide b) = Wide (add_w# a b) + +-- | Borrowing subtraction, computing 'a - b' and returning the +-- difference with a borrow mask. +sub_b# + :: (# Limb, Limb #) -- ^ minuend + -> (# Limb, Limb #) -- ^ subtrahend + -> (# (# Limb, Limb #), Limb #) -- ^ (# difference, borrow mask #) +sub_b# (# a0, a1 #) (# b0, b1 #) = + let !(# s0, c0 #) = L.sub_b# a0 b0 (Limb 0##) + !(# s1, c1 #) = L.sub_b# a1 b1 c0 + in (# (# s0, s1 #), c1 #) +{-# INLINE sub_b# #-} + +-- | Wrapping subtraction, computing 'a - b'. +sub_w# + :: (# Limb, Limb #) -- ^ minuend + -> (# Limb, Limb #) -- ^ subtrahend + -> (# Limb, Limb #) -- ^ difference +sub_w# a b = + let !(# c, _ #) = sub_b# a b + in c +{-# INLINE sub_w# #-} + +-- | Wrapping subtraction on 'Wide' words, computing 'a - b'. +sub :: Wide -> Wide -> Wide +sub (Wide a) (Wide b) = Wide (sub_w# a b) + +-- multiplication ------------------------------------------------------------- + +-- | Wrapping multiplication, computing 'a b'. +mul_w# + :: (# Limb, Limb #) -- ^ multiplicand + -> (# Limb, Limb #) -- ^ multiplier + -> (# Limb, Limb #) -- ^ product +mul_w# (# a0, a1 #) (# b0, b1 #) = + let !(# p0_lo, p0_hi #) = L.mul_c# a0 b0 + !(# p1_lo, _ #) = L.mul_c# a0 b1 + !(# p2_lo, _ #) = L.mul_c# a1 b0 + !(# s0, _ #) = L.add_o# p0_hi p1_lo + !(# s1, _ #) = L.add_o# s0 p2_lo + in (# p0_lo, s1 #) +{-# INLINE mul_w# #-} + +-- | Wrapping multiplication on 'Wide' words. +mul :: Wide -> Wide -> Wide +mul (Wide a) (Wide b) = Wide (mul_w# a b) + diff --git a/lib/Data/Word/Wider.hs b/lib/Data/Word/Wider.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Word/Wider.hs @@ -0,0 +1,749 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +-- | +-- Module: Data.Word.Wider +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Wider words, consisting of four 'Limb's. + +module Data.Word.Wider ( + -- * Four-limb words + Wider(..) + , wider + , to + , from + + -- * Comparison + , eq_vartime + , cmp + , cmp# + , eq# + , lt + , lt# + , gt + , gt# + + -- * Parity + , odd# + , odd + + -- * Constant-time selection + , select + , select# + + -- * Bit manipulation + , shl1 + , shr1 + , shl1_c + , shr1_c + , shr_limb + , shl_limb + , shl1_c# + , shr1_c# + , shr_limb# + , shl_limb# + , and + , and_w# + , or + , or_w# + , not + , not# + + -- * Arithmetic + , add_o + , add_o# + , add + , add_w# + , add_mod + , add_mod# + , sub + , sub_b + , sub_b# + , sub_mod + , sub_mod# + , sub_mod_c# + , mul + , mul_c + , mul_c# + , sqr + , sqr# + ) where + +import Control.DeepSeq +import Data.Bits ((.|.), (.&.), (.<<.), (.>>.)) +import qualified Data.Bits as B +import qualified Data.Choice as C +import Data.Word.Limb (Limb(..)) +import qualified Data.Word.Limb as L +import GHC.Exts (Word(..), Int(..), Int#) +import qualified GHC.Exts as Exts +import Prelude hiding (div, mod, or, and, not, quot, rem, recip, odd) + +-- utilities ------------------------------------------------------------------ + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +-- wider words ---------------------------------------------------------------- + +-- | Little-endian wider words, consisting of four 'Limbs'. +-- +-- >>> 1 :: Wider +-- 1 +data Wider = Wider !(# Limb, Limb, Limb, Limb #) + +instance Show Wider where + show = show . from + +instance Eq Wider where + Wider a == Wider b = C.decide (eq# a b) + +instance Ord Wider where + compare = cmp + +instance Num Wider where + (+) = add + (-) = sub + (*) = mul + abs = id + fromInteger = to + negate w = add (not w) (Wider (# Limb 1##, Limb 0##, Limb 0##, Limb 0## #)) + signum a = case a of + Wider (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) -> 0 + _ -> 1 + +instance NFData Wider where + rnf (Wider a) = case a of + (# _, _, _, _ #) -> () + +-- comparison ----------------------------------------------------------------- + +eq# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> C.Choice +eq# a b = + let !(# Limb a0, Limb a1, Limb a2, Limb a3 #) = a + !(# Limb b0, Limb b1, Limb b2, Limb b3 #) = b + in C.eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) +{-# INLINE eq# #-} + +-- | Compare 'Wider' words for equality in variable time. +-- +-- >>> eq_vartime 1 0 +-- False +-- >>> eq_vartime 1 1 +-- True +eq_vartime :: Wider -> Wider -> Bool +eq_vartime a b = + let !(Wider (# a0, a1, a2, a3 #)) = a + !(Wider (# b0, b1, b2, b3 #)) = b + in (L.eq_vartime# a0 b0) + && (L.eq_vartime# a1 b1) + && (L.eq_vartime# a2 b2) + && (L.eq_vartime# a3 b3) + +lt# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> C.Choice +lt# a b = + let !(# _, Limb bor #) = sub_b# a b + in C.from_word_mask# bor +{-# INLINE lt# #-} + +lt :: Wider -> Wider -> C.Choice +lt (Wider a) (Wider b) = lt# a b + +gt# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> C.Choice +gt# a b = + let !(# _, Limb bor #) = sub_b# b a + in C.from_word_mask# bor +{-# INLINE gt# #-} + +gt :: Wider -> Wider -> C.Choice +gt (Wider a) (Wider b) = gt# a b + +cmp# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> Int# +cmp# (# l0, l1, l2, l3 #) (# r0, r1, r2, r3 #) = + let !(# w0, b0 #) = L.sub_b# r0 l0 (Limb 0##) + !d0 = L.or# (Limb 0##) w0 + !(# w1, b1 #) = L.sub_b# r1 l1 b0 + !d1 = L.or# d0 w1 + !(# w2, b2 #) = L.sub_b# r2 l2 b1 + !d2 = L.or# d1 w2 + !(# w3, b3 #) = L.sub_b# r3 l3 b2 + !d3 = L.or# d2 w3 + !(Limb w) = L.and# b3 (Limb 2##) + !s = Exts.word2Int# w Exts.-# 1# + in (Exts.word2Int# (C.to_word# (L.nonzero# d3))) Exts.*# s +{-# INLINE cmp# #-} + +-- | Constant-time comparison between 'Wider' words. +-- +-- >>> cmp 1 2 +-- LT +-- >>> cmp 2 1 +-- GT +-- >>> cmp 2 2 +-- EQ +cmp :: Wider -> Wider -> Ordering +cmp (Wider a) (Wider b) = case cmp# a b of + 1# -> GT + 0# -> EQ + _ -> LT +{-# INLINABLE cmp #-} + +-- construction / conversion -------------------------------------------------- + +-- | Construct a 'Wider' word from four 'Words', provided in +-- little-endian order. +-- +-- >>> wider 1 0 0 0 +-- 1 +wider :: Word -> Word -> Word -> Word -> Wider +wider (W# w0) (W# w1) (W# w2) (W# w3) = Wider + (# Limb w0, Limb w1, Limb w2, Limb w3 #) + +-- | Convert an 'Integer' to a 'Wider' word. +-- +-- >>> to 1 +-- 1 +to :: Integer -> Wider +to n = + let !size = B.finiteBitSize (0 :: Word) + !mask = fi (maxBound :: Word) :: Integer + !(W# w0) = fi (n .&. mask) + !(W# w1) = fi ((n .>>. size) .&. mask) + !(W# w2) = fi ((n .>>. (2 * size)) .&. mask) + !(W# w3) = fi ((n .>>. (3 * size)) .&. mask) + in Wider (# Limb w0, Limb w1, Limb w2, Limb w3 #) + +-- | Convert a 'Wider' word to an 'Integer'. +-- +-- >>> from 1 +-- 1 +from :: Wider -> Integer +from (Wider (# Limb w0, Limb w1, Limb w2, Limb w3 #)) = + fi (W# w3) .<<. (3 * size) + .|. fi (W# w2) .<<. (2 * size) + .|. fi (W# w1) .<<. size + .|. fi (W# w0) + where + !size = B.finiteBitSize (0 :: Word) + +-- constant-time selection----------------------------------------------------- + +select# + :: (# Limb, Limb, Limb, Limb #) -- ^ a + -> (# Limb, Limb, Limb, Limb #) -- ^ b + -> C.Choice -- ^ c + -> (# Limb, Limb, Limb, Limb #) -- ^ result +select# a b c = + let !(# Limb a0, Limb a1, Limb a2, Limb a3 #) = a + !(# Limb b0, Limb b1, Limb b2, Limb b3 #) = b + !(# w0, w1, w2, w3 #) = + C.select_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) c + in (# Limb w0, Limb w1, Limb w2, Limb w3 #) +{-# INLINE select# #-} + +-- | Return a if c is truthy, otherwise return b. +-- +-- >>> import qualified Data.Choice as C +-- >>> select 0 1 (C.true# ()) +-- 1 +select + :: Wider -- ^ a + -> Wider -- ^ b + -> C.Choice -- ^ c + -> Wider -- ^ result +select (Wider a) (Wider b) c = Wider (select# a b c) + +-- bit manipulation ----------------------------------------------------------- + +shr1_c# + :: (# Limb, Limb, Limb, Limb #) -- ^ argument + -> (# (# Limb, Limb, Limb, Limb #), C.Choice #) -- ^ result, carry +shr1_c# (# w0, w1, w2, w3 #) = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !(# s3, c3 #) = (# L.shr# w3 1#, L.shl# w3 s #) + !r3 = L.or# s3 (Limb 0##) + !(# s2, c2 #) = (# L.shr# w2 1#, L.shl# w2 s #) + !r2 = L.or# s2 c3 + !(# s1, c1 #) = (# L.shr# w1 1#, L.shl# w1 s #) + !r1 = L.or# s1 c2 + !(# s0, c0 #) = (# L.shr# w0 1#, L.shl# w0 s #) + !r0 = L.or# s0 c1 + !(Limb w) = L.shr# c0 s + in (# (# r0, r1, r2, r3 #), C.from_word# w #) +{-# INLINE shr1_c# #-} + +-- | Constant-time 1-bit shift-right with carry, with a 'Choice' +-- indicating whether the lowest bit was set. +shr1_c :: Wider -> (# Wider, C.Choice #) +shr1_c (Wider w) = + let !(# r, c #) = shr1_c# w + in (# Wider r, c #) + +-- | Constant-time 1-bit shift-right. +-- +-- >>> shr1 2 +-- 1 +-- >>> shr1 1 +-- 0 +shr1 :: Wider -> Wider +shr1 (Wider w) = + let !(# r, _ #) = shr1_c# w + in Wider r + +shl1_c# + :: (# Limb, Limb, Limb, Limb #) -- ^ argument + -> (# (# Limb, Limb, Limb, Limb #), C.Choice #) -- ^ result, carry +shl1_c# (# w0, w1, w2, w3 #) = + let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !(# s0, c0 #) = (# L.shl# w0 1#, L.shr# w0 s #) + !r0 = L.or# s0 (Limb 0##) + !(# s1, c1 #) = (# L.shl# w1 1#, L.shr# w1 s #) + !r1 = L.or# s1 c0 + !(# s2, c2 #) = (# L.shl# w2 1#, L.shr# w2 s #) + !r2 = L.or# s2 c1 + !(# s3, c3 #) = (# L.shl# w3 1#, L.shr# w3 s #) + !r3 = L.or# s3 c2 + !(Limb w) = L.shl# c3 s + in (# (# r0, r1, r2, r3 #), C.from_word# w #) +{-# INLINE shl1_c# #-} + +-- | Constant-time 1-bit shift-left with carry, with a 'Choice' indicating +-- whether the highest bit was set. +shl1_c :: Wider -> (# Wider, C.Choice #) +shl1_c (Wider w) = + let !(# r, c #) = shl1_c# w + in (# Wider r, c #) + +-- | Constant-time 1-bit shift-left. +-- +-- >>> shl1 1 +-- 2 +-- >>> shl1 (2 ^ (255 :: Word)) +-- 0 +shl1 :: Wider -> Wider +shl1 (Wider w) = + let !(# r, _ #) = shl1_c# w + in Wider r + +shr_limb# + :: (# Limb, Limb, Limb, Limb #) + -> Int# + -> (# (# Limb, Limb, Limb, Limb #), Limb #) +shr_limb# (# a0, a1, a2, a3 #) rs = + let !size = case B.finiteBitSize (0 :: Word) of I# m -> m + !ls = size Exts.-# rs + !(# l3, c3 #) = (# L.shr# a3 rs, L.shl# a3 ls #) + !(# l2, c2 #) = (# L.or# (L.shr# a2 rs) c3, L.shl# a2 ls #) + !(# l1, c1 #) = (# L.or# (L.shr# a1 rs) c2, L.shl# a1 ls #) + !(# l0, c0 #) = (# L.or# (L.shr# a0 rs) c1, L.shl# a0 ls #) + in (# (# l0, l1, l2, l3 #), c0 #) +{-# INLINE shr_limb# #-} + +-- | Shift right by less than the number of bits in a 'Limb' (e.g., by +-- a maximum of 63 bits on 64-bit architectures). The shift amount is +-- unchecked. +-- +-- >>> shr_limb 2 1 +-- 1 +shr_limb + :: Wider -- ^ value + -> Int -- ^ right-shift amount (0 < s < WORD_SIZE) + -> Wider -- ^ right-shifted value +shr_limb (Wider w) (I# s) = + let !(# r, _ #) = shr_limb# w s + in Wider r + +shl_limb# + :: (# Limb, Limb, Limb, Limb #) + -> Int# + -> (# (# Limb, Limb, Limb, Limb #), Limb #) +shl_limb# (# a0, a1, a2, a3 #) ls = + let !size = case B.finiteBitSize (0 :: Word) of I# m -> m + !rs = size Exts.-# ls + !(# l0, c0 #) = (# L.shl# a0 ls, L.shr# a0 rs #) + !(# l1, c1 #) = (# L.or# (L.shl# a1 ls) c0, L.shr# a1 rs #) + !(# l2, c2 #) = (# L.or# (L.shl# a2 ls) c1, L.shr# a2 rs #) + !(# l3, c3 #) = (# L.or# (L.shl# a3 ls) c2, L.shr# a3 rs #) + in (# (# l0, l1, l2, l3 #), c3 #) +{-# INLINE shl_limb# #-} + +-- | Shift left by less than the number of bits in a 'Limb' (e.g., by +-- a maximum of 63 bits on 64-bit architectures). The shift amount is +-- unchecked. +-- +-- >>> shl_limb 2 1 +-- 1 +-- >>> shl_limb 1 63 +-- 9223372036854775808 +shl_limb + :: Wider -- ^ value + -> Int -- ^ left-shift amount (0 < s < WORD_SIZE) + -> Wider -- ^ left-shifted value +shl_limb (Wider w) (I# s) = + let !(# r, _ #) = shl_limb# w s + in Wider r + +and_w# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +and_w# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) = + (# L.and# a0 b0, L.and# a1 b1, L.and# a2 b2, L.and# a3 b3 #) +{-# INLINE and_w# #-} + +-- | Binary /and/. +-- +-- >>> and 1 1 +-- 1 +-- >>> and 1 0 +-- 0 +and + :: Wider -- ^ a + -> Wider -- ^ b + -> Wider -- ^ a & b +and (Wider a) (Wider b) = Wider (and_w# a b) + +or_w# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +or_w# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) = + (# L.or# a0 b0, L.or# a1 b1, L.or# a2 b2, L.or# a3 b3 #) +{-# INLINE or_w# #-} + +-- | Binary /or/. +-- +-- >>> or 1 1 +-- 1 +-- >>> or 1 0 +-- 1 +or + :: Wider -- ^ a + -> Wider -- ^ b + -> Wider -- ^ a | b +or (Wider a) (Wider b) = Wider (or_w# a b) + +not# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +not# (# l0, l1, l2, l3 #) = (# L.not# l0, L.not# l1, L.not# l2, L.not# l3 #) +{-# INLINE not# #-} + +-- | Binary /not/. +-- +-- >>> not 0 +-- 115792089237316195423570985008687907853269984665640564039457584007913129639935 +-- >>> not (not 0) +-- 0 +not + :: Wider -- ^ value + -> Wider -- ^ not value +not (Wider w) = Wider (not# w) + +-- addition, subtraction ------------------------------------------------------ + +add_o# + :: (# Limb, Limb, Limb, Limb #) -- ^ augend + -> (# Limb, Limb, Limb, Limb #) -- ^ addend + -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ (# sum, carry bit #) +add_o# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) = + let !(# s0, c0 #) = L.add_o# a0 b0 + !(# s1, c1 #) = L.add_c# a1 b1 c0 + !(# s2, c2 #) = L.add_c# a2 b2 c1 + !(# s3, c3 #) = L.add_c# a3 b3 c2 + in (# (# s0, s1, s2, s3 #), c3 #) +{-# INLINE add_o# #-} + +-- | Overflowing addition, computing 'a + b', returning the sum and a +-- carry bit. +-- +-- >>> add_o 1 1 +-- (2,0) +-- >>> add_o 1 (2 ^ (256 :: Word) - 1) +-- (0,1) +add_o + :: Wider + -> Wider + -> (Wider, Word) +add_o (Wider a) (Wider b) = + let !(# s, Limb c #) = add_o# a b + in (Wider s, W# c) + +add_w# + :: (# Limb, Limb, Limb, Limb #) -- ^ augend + -> (# Limb, Limb, Limb, Limb #) -- ^ addend + -> (# Limb, Limb, Limb, Limb #) -- ^ sum +add_w# a b = + let !(# c, _ #) = add_o# a b + in c +{-# INLINE add_w# #-} + +-- | Wrapping addition, computing 'a + b'. +-- +-- Note that as 'Wider' is an instance of 'Num', you can use '+' to apply +-- this function. +-- +-- >>> add 1 (2 ^ (256 :: Word) - 1) +-- 0 +add + :: Wider + -> Wider + -> Wider +add (Wider a) (Wider b) = Wider (add_w# a b) +{-# INLINE add #-} + +add_mod# + :: (# Limb, Limb, Limb, Limb #) -- ^ augend + -> (# Limb, Limb, Limb, Limb #) -- ^ addend + -> (# Limb, Limb, Limb, Limb #) -- ^ modulus + -> (# Limb, Limb, Limb, Limb #) -- ^ sum +add_mod# a b m = + let !(# w, c #) = add_o# a b + in sub_mod_c# w c m m +{-# INLINE add_mod# #-} + +-- | Modular addition. +-- +-- Assumes that the sum is less than twice the modulus; this is not +-- checked. +-- +-- >>> add_mod 1 1 3 +-- 2 +-- >>> add_mod 1 2 3 +-- 0 +add_mod + :: Wider -- ^ augend + -> Wider -- ^ addend + -> Wider -- ^ modulus + -> Wider -- ^ sum +add_mod (Wider a) (Wider b) (Wider m) = Wider (add_mod# a b m) + +sub_b# + :: (# Limb, Limb, Limb, Limb #) -- ^ minuend + -> (# Limb, Limb, Limb, Limb #) -- ^ subtrahend + -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ (# diff, borrow mask #) +sub_b# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) = + let !(# s0, c0 #) = L.sub_b# a0 b0 (Limb 0##) + !(# s1, c1 #) = L.sub_b# a1 b1 c0 + !(# s2, c2 #) = L.sub_b# a2 b2 c1 + !(# s3, c3 #) = L.sub_b# a3 b3 c2 + in (# (# s0, s1, s2, s3 #), c3 #) +{-# INLINE sub_b# #-} + +-- | Borrowing subtraction, computing 'a - b' and returning the +-- difference with a borrow mask. +-- +-- >>> sub_b 1 1 +-- (0,0) +-- >>> sub_b 0 (2 ^ (256 :: Word) - 1) +-- (1,18446744073709551615) +sub_b + :: Wider -- ^ minuend + -> Wider -- ^ subtrahend + -> (Wider, Word) -- ^ (difference, borrow mask) +sub_b (Wider l) (Wider r) = + let !(# d, Limb b #) = sub_b# l r + in (Wider d, W# b) + +-- | Wrapping subtraction, computing 'a - b' and returning the +-- difference. +-- +-- Note that as 'Wider' is an instance of 'Num', you can use '-' to apply +-- this function. +-- +-- >>> sub 1 1 +-- 0 +-- >>> sub 0 (2 ^ (256 :: Word) - 1) +-- 1 +sub + :: Wider -- ^ minuend + -> Wider -- ^ subtrahend + -> Wider -- ^ difference +sub (Wider a) (Wider b) = + let !(# d, _ #) = sub_b# a b + in Wider d + +sub_mod# + :: (# Limb, Limb, Limb, Limb #) -- ^ minuend + -> (# Limb, Limb, Limb, Limb #) -- ^ subtrahend + -> (# Limb, Limb, Limb, Limb #) -- ^ modulus + -> (# Limb, Limb, Limb, Limb #) -- ^ difference +sub_mod# a b (# p0, p1, p2, p3 #) = + let !(# o, m #) = sub_b# a b + !ba = (# L.and# p0 m, L.and# p1 m, L.and# p2 m, L.and# p3 m #) + in add_w# o ba +{-# INLINE sub_mod# #-} + +-- | Modular subtraction. Computes a - b mod m. +-- +-- Assumes that the magnitude of the difference is less than the +-- modulus (this is unchecked). +-- +-- >>> sub_mod 1 1 4 +-- 0 +-- >>> sub_mod 2 3 4 +-- 3 +sub_mod + :: Wider + -> Wider + -> Wider + -> Wider +sub_mod (Wider a) (Wider b) (Wider p) = Wider (sub_mod# a b p) + +-- | Modular subtraction with carry. Computes (# a, c #) - b mod m. +sub_mod_c# + :: (# Limb, Limb, Limb, Limb #) -- ^ minuend + -> Limb -- ^ carry bit + -> (# Limb, Limb, Limb, Limb #) -- ^ subtrahend + -> (# Limb, Limb, Limb, Limb #) -- ^ modulus + -> (# Limb, Limb, Limb, Limb #) -- ^ difference +sub_mod_c# a c b (# p0, p1, p2, p3 #) = + let !(# (# o0, o1, o2, o3 #), bb #) = sub_b# a b + !(# _, m #) = L.sub_b# c (Limb 0##) bb + !ba = (# L.and# p0 m, L.and# p1 m, L.and# p2 m, L.and# p3 m #) + in add_w# (# o0, o1, o2, o3 #) ba +{-# INLINE sub_mod_c# #-} + +-- multiplication ------------------------------------------------------------- + +mul_c# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# (# Limb, Limb, Limb, Limb #), (# Limb, Limb, Limb, Limb #) #) +mul_c# (# x0, x1, x2, x3 #) (# y0, y1, y2, y3 #) = + let !(# z0, c0_0 #) = L.mac# x0 y0 (Limb 0##) (Limb 0##) + !(# s1_0, c1_0 #) = L.mac# x0 y1 (Limb 0##) c0_0 + !(# z1, c1_1 #) = L.mac# x1 y0 s1_0 (Limb 0##) + !(# s2_0, c2_0 #) = L.mac# x0 y2 (Limb 0##) c1_0 + !(# s2_1, c2_1 #) = L.mac# x1 y1 s2_0 c1_1 + !(# z2, c2_2 #) = L.mac# x2 y0 s2_1 (Limb 0##) + !(# s3_0, c3_0 #) = L.mac# x0 y3 (Limb 0##) c2_0 + !(# s3_1, c3_1 #) = L.mac# x1 y2 s3_0 c2_1 + !(# s3_2, c3_2 #) = L.mac# x2 y1 s3_1 c2_2 + !(# z3, c3_3 #) = L.mac# x3 y0 s3_2 (Limb 0##) + !(# s4_0, c4_0 #) = L.mac# x1 y3 (Limb 0##) c3_0 + !(# s4_1, c4_1 #) = L.mac# x2 y2 s4_0 c3_1 + !(# s4_2, c4_2 #) = L.mac# x3 y1 s4_1 c3_2 + !(# w4, c4_3 #) = L.add_c# s4_2 c3_3 (Limb 0##) + !(# s5_0, c5_0 #) = L.mac# x2 y3 (Limb 0##) c4_0 + !(# s5_1, c5_1 #) = L.mac# x3 y2 s5_0 c4_1 + !(# w5, c5_2 #) = L.add_c# s5_1 c4_2 (Limb 0##) + !(# w5f, c5_3 #) = L.add_c# w5 c4_3 (Limb 0##) + !(# s6_0, c6_0 #) = L.mac# x3 y3 (Limb 0##) c5_0 + !(# w6, c6_1 #) = L.add_c# s6_0 c5_1 (Limb 0##) + !(# w6f, c6_2 #) = L.add_c# w6 c5_2 (Limb 0##) + !(# w6ff, c6_3 #) = L.add_c# w6f c5_3 (Limb 0##) + !(# w7, _ #) = L.add_c# c6_0 c6_1 (Limb 0##) + !(# w7f, _ #) = L.add_c# w7 c6_2 (Limb 0##) + !(# w7ff, _ #) = L.add_c# w7f c6_3 (Limb 0##) + in (# (# z0, z1, z2, z3 #), (# w4, w5f, w6ff, w7ff #) #) +{-# INLINE mul_c# #-} + +-- | Widening multiplication. +-- +-- Returns the low and high 'Wider' words of the product, in that +-- order. +-- +-- >>> mul_c 2 3 +-- (6,0) +-- >>> mul_c (2 ^ (256 :: Word) - 1) 2 +-- (115792089237316195423570985008687907853269984665640564039457584007913129639934,1) +mul_c + :: Wider + -> Wider + -> (Wider, Wider) +mul_c (Wider a) (Wider b) = + let !(# l, h #) = mul_c# a b + in (Wider l, Wider h) + +-- | Wrapping multiplication. +-- +-- Note that as 'Wider' is an instance of 'Num', you can use '*' to apply +-- this function. +-- +-- >>> mul 1 1 +-- 1 +-- >>> mul 1 2 +-- 2 +mul + :: Wider + -> Wider + -> Wider +mul (Wider a) (Wider b) = + let !(# l, _ #) = mul_c# a b + in Wider l + +sqr# + :: (# Limb, Limb, Limb, Limb #) + -> (# (# Limb, Limb, Limb, Limb #), (# Limb, Limb, Limb, Limb #) #) +sqr# (# x0, x1, x2, x3 #) = + let !sh = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1# + !(# q1_0, c1_0 #) = L.mac# x1 x0 (Limb 0##) (Limb 0##) + !r1 = c1_0 + !(# r2_0, c2_0 #) = L.mac# x2 x0 r1 (Limb 0##) + !(# s2_1, c2_1 #) = L.mac# x2 x1 (Limb 0##) c2_0 + !t2 = c2_1 + !(# s3_0, c3_0 #) = L.mac# x3 x0 s2_1 (Limb 0##) + !(# t3, c3_1 #) = L.mac# x3 x1 t2 c3_0 + !(# u3, c3_2 #) = L.mac# x3 x2 (Limb 0##) c3_1 + !v3 = c3_2 + !(# lo1, car0_1 #) = (# L.shl# q1_0 1#, L.shr# q1_0 sh #) + !(# lo2, car0_2 #) = (# L.or# (L.shl# r2_0 1#) car0_1, L.shr# r2_0 sh #) + !(# lo3, car0_3 #) = (# L.or# (L.shl# s3_0 1#) car0_2, L.shr# s3_0 sh #) + !(# hi0, car1_0 #) = (# L.or# (L.shl# t3 1#) car0_3, L.shr# t3 sh #) + !(# hi1, car1_1 #) = (# L.or# (L.shl# u3 1#) car1_0, L.shr# u3 sh #) + !(# hi2, car1_2 #) = (# L.or# (L.shl# v3 1#) car1_1, L.shr# v3 sh #) + !hi3 = car1_2 + !(# pf, car2_0 #) = L.mac# x0 x0 (Limb 0##) (Limb 0##) + !(# qf, car2_1 #) = L.add_c# lo1 car2_0 (Limb 0##) + !(# rf, car2_2 #) = L.mac# x1 x1 lo2 car2_1 + !(# sf, car2_3 #) = L.add_c# lo3 car2_2 (Limb 0##) + !(# tf, car2_4 #) = L.mac# x2 x2 hi0 car2_3 + !(# uf, car2_5 #) = L.add_c# hi1 car2_4 (Limb 0##) + !(# vf, car2_6 #) = L.mac# x3 x3 hi2 car2_5 + !(# wf, _ #) = L.add_c# hi3 car2_6 (Limb 0##) + in (# (# pf, qf, rf, sf #), (# tf, uf, vf, wf #) #) +{-# INLINE sqr# #-} + +-- | Widening square. +-- +-- >>> sqr 2 +-- (4,0) +-- >>> sqr (2 ^ (256 :: Word) - 1) +-- (1,115792089237316195423570985008687907853269984665640564039457584007913129639934) +sqr :: Wider -> (Wider, Wider) +sqr (Wider w) = + let !(# l, h #) = sqr# w + in (Wider l, Wider h) + +odd# :: (# Limb, Limb, Limb, Limb #) -> C.Choice +odd# (# Limb w, _, _, _ #) = C.from_word# (Exts.and# w 1##) +{-# INLINE odd# #-} + +-- | Check if a 'Wider' is odd, returning a 'Choice'. +odd + :: Wider + -> C.Choice +odd (Wider w) = odd# w + diff --git a/lib/Numeric/Montgomery/Secp256k1/Curve.hs b/lib/Numeric/Montgomery/Secp256k1/Curve.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/Montgomery/Secp256k1/Curve.hs @@ -0,0 +1,1573 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +-- | +-- Module: Numeric.Montgomery.Secp256k1.Curve +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Montgomery form 'Wider' words, as well as arithmetic operations, with +-- domain derived from the secp256k1 elliptic curve field prime. + +module Numeric.Montgomery.Secp256k1.Curve ( + -- * Montgomery form, secp256k1 field prime modulus + Montgomery(..) + , render + , to + , from + , zero + , one + + -- * Comparison + , eq + , eq_vartime + + -- * Reduction and retrieval + , redc + , retr + , redc# + , retr# + + -- * Constant-time selection + , select# + , select + + -- * Montgomery arithmetic + , add + , add# + , sub + , sub# + , mul + , mul# + , sqr + , sqr# + , neg + , neg# + , inv + , inv# + , sqrt + , sqrt# + , exp + , odd# + , odd + ) where + +import Control.DeepSeq +import qualified Data.Choice as C +import Data.Word.Limb (Limb(..)) +import qualified Data.Word.Limb as L +import qualified Data.Word.Wide as W +import Data.Word.Wider (Wider(..)) +import qualified Data.Word.Wider as WW +import GHC.Exts (Word(..)) +import Prelude hiding (or, and, not, sqrt, exp, odd) + +-- montgomery arithmetic, specialized to the secp256k1 field prime modulus +-- 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F + +-- | Montgomery-form 'Wider' words, on the Montgomery domain defined by +-- the secp256k1 scalar group order. +-- +-- >>> let one = 1 :: Montgomery +-- >>> one +-- 1 +-- >>> putStrLn (render one) +-- (4294968273, 0, 0, 0) +data Montgomery = Montgomery !(# Limb, Limb, Limb, Limb #) + +-- | Render a 'Montgomery' value as a 'String', showing its individual +-- 'Limb's. +-- +-- >>> putStrLn (render 1) +-- (4294968273, 0, 0, 0) +render :: Montgomery -> String +render (Montgomery (# Limb a, Limb b, Limb c, Limb d #)) = + "(" <> show (W# a) <> ", " <> show (W# b) <> ", " + <> show (W# c) <> ", " <> show (W# d) <> ")" + +instance Show Montgomery where + show = show . from + +instance Num Montgomery where + a + b = add a b + a - b = sub a b + a * b = mul a b + negate a = neg a + abs = id + fromInteger = to . WW.to + signum a = case a of + Montgomery (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) -> 0 + _ -> 1 + +instance Eq Montgomery where + a == b = C.decide (eq a b) + +instance NFData Montgomery where + rnf (Montgomery a) = case a of (# _, _, _, _ #) -> () + +-- utilities ------------------------------------------------------------------ + +-- Wide wrapping addition, when addend is only a limb. +wadd_w# :: (# Limb, Limb #) -> Limb -> (# Limb, Limb #) +wadd_w# (# x_lo, x_hi #) y_lo = + let !(# s0, c0 #) = L.add_o# x_lo y_lo + !(# s1, _ #) = L.add_o# x_hi c0 + in (# s0, s1 #) +{-# INLINE wadd_w# #-} + +-- Truncate a wide word to a 'Limb'. +lo :: (# Limb, Limb #) -> Limb +lo (# l, _ #) = l +{-# INLINE lo #-} + +-- comparison ----------------------------------------------------------------- + +-- | Constant-time equality comparison. +eq :: Montgomery -> Montgomery -> C.Choice +eq + (Montgomery (# Limb a0, Limb a1, Limb a2, Limb a3 #)) + (Montgomery (# Limb b0, Limb b1, Limb b2, Limb b3 #)) + = C.eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) +{-# INLINE eq #-} + +-- | Variable-time equality comparison. +eq_vartime :: Montgomery -> Montgomery -> Bool +eq_vartime (Montgomery (Wider -> a)) (Montgomery (Wider -> b)) = + WW.eq_vartime a b + +-- innards -------------------------------------------------------------------- + +redc_inner# + :: (# Limb, Limb, Limb, Limb #) -- ^ upper limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ lower limbs + -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ upper limbs, meta-carry +redc_inner# (# u0, u1, u2, u3 #) (# l0, l1, l2, l3 #) = + let !(# m0, m1, m2, m3 #) = + (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + !n = Limb 0xD838091DD2253531## + !w_0 = L.mul_w# l0 n + !(# _, c_00 #) = L.mac# w_0 m0 l0 (Limb 0##) + !(# l0_1, c_01 #) = L.mac# w_0 m1 l1 c_00 + !(# l0_2, c_02 #) = L.mac# w_0 m2 l2 c_01 + !(# l0_3, c_03 #) = L.mac# w_0 m3 l3 c_02 + !(# u_0, mc_0 #) = L.add_c# u0 c_03 (Limb 0##) + !w_1 = L.mul_w# l0_1 n + !(# _, c_10 #) = L.mac# w_1 m0 l0_1 (Limb 0##) + !(# l1_1, c_11 #) = L.mac# w_1 m1 l0_2 c_10 + !(# l1_2, c_12 #) = L.mac# w_1 m2 l0_3 c_11 + !(# u1_3, c_13 #) = L.mac# w_1 m3 u_0 c_12 + !(# u_1, mc_1 #) = L.add_c# u1 c_13 mc_0 + !w_2 = L.mul_w# l1_1 n + !(# _, c_20 #) = L.mac# w_2 m0 l1_1 (Limb 0##) + !(# l2_1, c_21 #) = L.mac# w_2 m1 l1_2 c_20 + !(# u2_2, c_22 #) = L.mac# w_2 m2 u1_3 c_21 + !(# u2_3, c_23 #) = L.mac# w_2 m3 u_1 c_22 + !(# u_2, mc_2 #) = L.add_c# u2 c_23 mc_1 + !w_3 = L.mul_w# l2_1 n + !(# _, c_30 #) = L.mac# w_3 m0 l2_1 (Limb 0##) + !(# u3_1, c_31 #) = L.mac# w_3 m1 u2_2 c_30 + !(# u3_2, c_32 #) = L.mac# w_3 m2 u2_3 c_31 + !(# u3_3, c_33 #) = L.mac# w_3 m3 u_2 c_32 + !(# u_3, mc_3 #) = L.add_c# u3 c_33 mc_2 + in (# (# u3_1, u3_2, u3_3, u_3 #), mc_3 #) +{-# INLINE redc_inner# #-} + +-- | Montgomery reduction. +redc# + :: (# Limb, Limb, Limb, Limb #) -- ^ lower limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ upper limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ result +redc# l u = + let -- field prime + !m = (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + !(# nu, mc #) = redc_inner# u l + in WW.sub_mod_c# nu mc m m +{-# INLINE redc# #-} + +-- | Montgomery reduction. +-- +-- The first argument represents the low words, and the second the +-- high words, of an extra-large eight-limb word in Montgomery form. +redc + :: Montgomery -- ^ low wider-word, Montgomery form + -> Montgomery -- ^ high wider-word, Montgomery form + -> Montgomery -- ^ reduced value +redc (Montgomery l) (Montgomery u) = + let !res = redc# l u + in (Montgomery res) + +retr_inner# + :: (# Limb, Limb, Limb, Limb #) -- ^ value in montgomery form + -> (# Limb, Limb, Limb, Limb #) -- ^ retrieved value +retr_inner# (# x0, x1, x2, x3 #) = + let !(# m0, m1, m2, m3 #) = + (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + !n = Limb 0xD838091DD2253531## + !u_0 = L.mul_w# x0 n + !(# _, o0 #) = L.mac# u_0 m0 x0 (Limb 0##) + !(# o0_1, p0_1 #) = L.mac# u_0 m1 (Limb 0##) o0 + !(# p0_2, q0_2 #) = L.mac# u_0 m2 (Limb 0##) p0_1 + !(# q0_3, r0_3 #) = L.mac# u_0 m3 (Limb 0##) q0_2 + !u_1 = L.mul_w# (L.add_w# o0_1 x1) n + !(# _, o1 #) = L.mac# u_1 m0 x1 o0_1 + !(# o1_1, p1_1 #) = L.mac# u_1 m1 p0_2 o1 + !(# p1_2, q1_2 #) = L.mac# u_1 m2 q0_3 p1_1 + !(# q1_3, r1_3 #) = L.mac# u_1 m3 r0_3 q1_2 + !u_2 = L.mul_w# (L.add_w# o1_1 x2) n + !(# _, o2 #) = L.mac# u_2 m0 x2 o1_1 + !(# o2_1, p2_1 #) = L.mac# u_2 m1 p1_2 o2 + !(# p2_2, q2_2 #) = L.mac# u_2 m2 q1_3 p2_1 + !(# q2_3, r2_3 #) = L.mac# u_2 m3 r1_3 q2_2 + !u_3 = L.mul_w# (L.add_w# o2_1 x3) n + !(# _, o3 #) = L.mac# u_3 m0 x3 o2_1 + !(# o3_1, p3_1 #) = L.mac# u_3 m1 p2_2 o3 + !(# p3_2, q3_2 #) = L.mac# u_3 m2 q2_3 p3_1 + !(# q3_3, r3_3 #) = L.mac# u_3 m3 r2_3 q3_2 + in (# o3_1, p3_2, q3_3, r3_3 #) +{-# INLINE retr_inner# #-} + +retr# + :: (# Limb, Limb, Limb, Limb #) -- montgomery form + -> (# Limb, Limb, Limb, Limb #) +retr# f = retr_inner# f +{-# INLINE retr# #-} + +-- | Retrieve a 'Montgomery' value from the Montgomery domain, producing +-- a 'Wider' word. +retr + :: Montgomery -- ^ value in montgomery form + -> Wider -- ^ retrieved value +retr (Montgomery f) = + let !res = retr# f + in (Wider res) + +-- | Montgomery multiplication (FIOS), without conditional subtract. +mul_inner# + :: (# Limb, Limb, Limb, Limb #) -- ^ x + -> (# Limb, Limb, Limb, Limb #) -- ^ y + -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ product, meta-carry +mul_inner# (# x0, x1, x2, x3 #) (# y0, y1, y2, y3 #) = + let !(# m0, m1, m2, m3 #) = + (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + !n = Limb 0xD838091DD2253531## + !axy0 = L.mul_c# x0 y0 + !u0 = L.mul_w# (lo axy0) n + !(# (# _, a0 #), c0 #) = W.add_o# (L.mul_c# u0 m0) axy0 + !carry0 = (# a0, c0 #) + !axy0_1 = L.mul_c# x0 y1 + !umc0_1 = W.add_w# (L.mul_c# u0 m1) carry0 + !(# (# o0, ab0_1 #), c0_1 #) = W.add_o# axy0_1 umc0_1 + !carry0_1 = (# ab0_1, c0_1 #) + !axy0_2 = L.mul_c# x0 y2 + !umc0_2 = W.add_w# (L.mul_c# u0 m2) carry0_1 + !(# (# p0, ab0_2 #), c0_2 #) = W.add_o# axy0_2 umc0_2 + !carry0_2 = (# ab0_2, c0_2 #) + !axy0_3 = L.mul_c# x0 y3 + !umc0_3 = W.add_w# (L.mul_c# u0 m3) carry0_2 + !(# (# q0, ab0_3 #), c0_3 #) = W.add_o# axy0_3 umc0_3 + !carry0_3 = (# ab0_3, c0_3 #) + !(# r0, mc0 #) = carry0_3 + !axy1 = wadd_w# (L.mul_c# x1 y0) o0 + !u1 = L.mul_w# (lo axy1) n + !(# (# _, a1 #), c1 #) = W.add_o# (L.mul_c# u1 m0) axy1 + !carry1 = (# a1, c1 #) + !axy1_1 = wadd_w# (L.mul_c# x1 y1) p0 + !umc1_1 = W.add_w# (L.mul_c# u1 m1) carry1 + !(# (# o1, ab1_1 #), c1_1 #) = W.add_o# axy1_1 umc1_1 + !carry1_1 = (# ab1_1, c1_1 #) + !axy1_2 = wadd_w# (L.mul_c# x1 y2) q0 + !umc1_2 = W.add_w# (L.mul_c# u1 m2) carry1_1 + !(# (# p1, ab1_2 #), c1_2 #) = W.add_o# axy1_2 umc1_2 + !carry1_2 = (# ab1_2, c1_2 #) + !axy1_3 = wadd_w# (L.mul_c# x1 y3) r0 + !umc1_3 = W.add_w# (L.mul_c# u1 m3) carry1_2 + !(# (# q1, ab1_3 #), c1_3 #) = W.add_o# axy1_3 umc1_3 + !carry1_3 = (# ab1_3, c1_3 #) + !(# r1, mc1 #) = wadd_w# carry1_3 mc0 + !axy2 = wadd_w# (L.mul_c# x2 y0) o1 + !u2 = L.mul_w# (lo axy2) n + !(# (# _, a2 #), c2 #) = W.add_o# (L.mul_c# u2 m0) axy2 + !carry2 = (# a2, c2 #) + !axy2_1 = wadd_w# (L.mul_c# x2 y1) p1 + !umc2_1 = W.add_w# (L.mul_c# u2 m1) carry2 + !(# (# o2, ab2_1 #), c2_1 #) = W.add_o# axy2_1 umc2_1 + !carry2_1 = (# ab2_1, c2_1 #) + !axy2_2 = wadd_w# (L.mul_c# x2 y2) q1 + !umc2_2 = W.add_w# (L.mul_c# u2 m2) carry2_1 + !(# (# p2, ab2_2 #), c2_2 #) = W.add_o# axy2_2 umc2_2 + !carry2_2 = (# ab2_2, c2_2 #) + !axy2_3 = wadd_w# (L.mul_c# x2 y3) r1 + !umc2_3 = W.add_w# (L.mul_c# u2 m3) carry2_2 + !(# (# q2, ab2_3 #), c2_3 #) = W.add_o# axy2_3 umc2_3 + !carry2_3 = (# ab2_3, c2_3 #) + !(# r2, mc2 #) = wadd_w# carry2_3 mc1 + !axy3 = wadd_w# (L.mul_c# x3 y0) o2 + !u3 = L.mul_w# (lo axy3) n + !(# (# _, a3 #), c3 #) = W.add_o# (L.mul_c# u3 m0) axy3 + !carry3 = (# a3, c3 #) + !axy3_1 = wadd_w# (L.mul_c# x3 y1) p2 + !umc3_1 = W.add_w# (L.mul_c# u3 m1) carry3 + !(# (# o3, ab3_1 #), c3_1 #) = W.add_o# axy3_1 umc3_1 + !carry3_1 = (# ab3_1, c3_1 #) + !axy3_2 = wadd_w# (L.mul_c# x3 y2) q2 + !umc3_2 = W.add_w# (L.mul_c# u3 m2) carry3_1 + !(# (# p3, ab3_2 #), c3_2 #) = W.add_o# axy3_2 umc3_2 + !carry3_2 = (# ab3_2, c3_2 #) + !axy3_3 = wadd_w# (L.mul_c# x3 y3) r2 + !umc3_3 = W.add_w# (L.mul_c# u3 m3) carry3_2 + !(# (# q3, ab3_3 #), c3_3 #) = W.add_o# axy3_3 umc3_3 + !carry3_3 = (# ab3_3, c3_3 #) + !(# r3, mc3 #) = wadd_w# carry3_3 mc2 + in (# (# o3, p3, q3, r3 #), mc3 #) +{-# INLINE mul_inner# #-} + +mul# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +mul# a b = + let -- field prime + !m = (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + !(# nu, mc #) = mul_inner# a b + in WW.sub_mod_c# nu mc m m +{-# NOINLINE mul# #-} -- cannot be inlined without exploding comp time + +-- | Multiplication in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use '*' +-- to apply this function. +-- +-- >>> 1 * 1 :: Montgomery +-- 1 +mul + :: Montgomery -- ^ multiplicand in montgomery form + -> Montgomery -- ^ multiplier in montgomery form + -> Montgomery -- ^ montgomery product +mul (Montgomery a) (Montgomery b) = Montgomery (mul# a b) + +to# + :: (# Limb, Limb, Limb, Limb #) -- ^ integer + -> (# Limb, Limb, Limb, Limb #) +to# x = + let -- r^2 mod m + !r2 = (# Limb 0x000007A2000E90A1##, Limb 0x1##, Limb 0##, Limb 0## #) + in mul# x r2 +{-# INLINE to# #-} + +-- | Convert a 'Wider' word to the Montgomery domain. +to :: Wider -> Montgomery +to (Wider x) = Montgomery (to# x) + +-- | Retrieve a 'Montgomery' word from the Montgomery domain. +-- +-- This function is a synonym for 'retr'. +from :: Montgomery -> Wider +from = retr + +add# + :: (# Limb, Limb, Limb, Limb #) -- ^ augend + -> (# Limb, Limb, Limb, Limb #) -- ^ addend + -> (# Limb, Limb, Limb, Limb #) -- ^ sum +add# a b = + let -- field prime + !m = (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + in WW.add_mod# a b m +{-# INLINE add# #-} + +-- | Addition in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use '+' +-- to apply this function. +-- +-- >>> 1 + 1 :: Montgomery +-- 2 +add :: Montgomery -> Montgomery -> Montgomery +add (Montgomery a) (Montgomery b) = Montgomery (add# a b) + +sub# + :: (# Limb, Limb, Limb, Limb #) -- ^ minuend + -> (# Limb, Limb, Limb, Limb #) -- ^ subtrahend + -> (# Limb, Limb, Limb, Limb #) -- ^ difference +sub# a b = + let -- field prime + !m = (# Limb 0xFFFFFFFEFFFFFC2F##, Limb 0xFFFFFFFFFFFFFFFF## + , Limb 0xFFFFFFFFFFFFFFFF##, Limb 0xFFFFFFFFFFFFFFFF## #) + in WW.sub_mod# a b m +{-# INLINE sub# #-} + +-- | Subtraction in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use '-' +-- to apply this function. +-- +-- >>> 1 - 1 :: Montgomery +-- 0 +sub :: Montgomery -> Montgomery -> Montgomery +sub (Montgomery a) (Montgomery b) = Montgomery (sub# a b) + +neg# + :: (# Limb, Limb, Limb, Limb #) -- ^ argument + -> (# Limb, Limb, Limb, Limb #) -- ^ modular negation +neg# a = sub# (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) a +{-# INLINE neg# #-} + +-- | Additive inverse in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use 'negate' +-- to apply this function. +-- +-- >>> negate 1 :: Montgomery +-- 115792089237316195423570985008687907853269984665640564039457584007908834671662 +-- >>> (negate 1 :: Montgomery) + 1 +-- 0 +neg :: Montgomery -> Montgomery +neg (Montgomery a) = Montgomery (neg# a) + +sqr# :: (# Limb, Limb, Limb, Limb #) -> (# Limb, Limb, Limb, Limb #) +sqr# a = + let !(# l, h #) = WW.sqr# a + in redc# l h +{-# NOINLINE sqr# #-} -- cannot be inlined without exploding comp time + +-- | Squaring in the Montgomery domain. +-- +-- >>> sqr 1 +-- 1 +-- >>> sqr 2 +-- 4 +-- >>> sqr (negate 2) +-- 4 +sqr :: Montgomery -> Montgomery +sqr (Montgomery a) = Montgomery (mul# a a) + +-- | Zero (the additive unit) in the Montgomery domain. +zero :: Montgomery +zero = Montgomery (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) + +-- | One (the multiplicative unit) in the Montgomery domain. +one :: Montgomery +one = Montgomery (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) + +-- generated by etc/generate_inv.sh +inv# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +inv# a = + let -- montgomery 'one' + !t0 = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) + !t1 = sqr# t0 + !t2 = mul# a t1 + !t3 = sqr# t2 + !t4 = mul# a t3 + !t5 = sqr# t4 + !t6 = mul# a t5 + !t7 = sqr# t6 + !t8 = mul# a t7 + !t9 = sqr# t8 + !t10 = mul# a t9 + !t11 = sqr# t10 + !t12 = mul# a t11 + !t13 = sqr# t12 + !t14 = mul# a t13 + !t15 = sqr# t14 + !t16 = mul# a t15 + !t17 = sqr# t16 + !t18 = mul# a t17 + !t19 = sqr# t18 + !t20 = mul# a t19 + !t21 = sqr# t20 + !t22 = mul# a t21 + !t23 = sqr# t22 + !t24 = mul# a t23 + !t25 = sqr# t24 + !t26 = mul# a t25 + !t27 = sqr# t26 + !t28 = mul# a t27 + !t29 = sqr# t28 + !t30 = mul# a t29 + !t31 = sqr# t30 + !t32 = mul# a t31 + !t33 = sqr# t32 + !t34 = mul# a t33 + !t35 = sqr# t34 + !t36 = mul# a t35 + !t37 = sqr# t36 + !t38 = mul# a t37 + !t39 = sqr# t38 + !t40 = mul# a t39 + !t41 = sqr# t40 + !t42 = mul# a t41 + !t43 = sqr# t42 + !t44 = mul# a t43 + !t45 = sqr# t44 + !t46 = mul# a t45 + !t47 = sqr# t46 + !t48 = mul# a t47 + !t49 = sqr# t48 + !t50 = mul# a t49 + !t51 = sqr# t50 + !t52 = mul# a t51 + !t53 = sqr# t52 + !t54 = mul# a t53 + !t55 = sqr# t54 + !t56 = mul# a t55 + !t57 = sqr# t56 + !t58 = mul# a t57 + !t59 = sqr# t58 + !t60 = mul# a t59 + !t61 = sqr# t60 + !t62 = mul# a t61 + !t63 = sqr# t62 + !t64 = mul# a t63 + !t65 = sqr# t64 + !t66 = mul# a t65 + !t67 = sqr# t66 + !t68 = mul# a t67 + !t69 = sqr# t68 + !t70 = mul# a t69 + !t71 = sqr# t70 + !t72 = mul# a t71 + !t73 = sqr# t72 + !t74 = mul# a t73 + !t75 = sqr# t74 + !t76 = mul# a t75 + !t77 = sqr# t76 + !t78 = mul# a t77 + !t79 = sqr# t78 + !t80 = mul# a t79 + !t81 = sqr# t80 + !t82 = mul# a t81 + !t83 = sqr# t82 + !t84 = mul# a t83 + !t85 = sqr# t84 + !t86 = mul# a t85 + !t87 = sqr# t86 + !t88 = mul# a t87 + !t89 = sqr# t88 + !t90 = mul# a t89 + !t91 = sqr# t90 + !t92 = mul# a t91 + !t93 = sqr# t92 + !t94 = mul# a t93 + !t95 = sqr# t94 + !t96 = mul# a t95 + !t97 = sqr# t96 + !t98 = mul# a t97 + !t99 = sqr# t98 + !t100 = mul# a t99 + !t101 = sqr# t100 + !t102 = mul# a t101 + !t103 = sqr# t102 + !t104 = mul# a t103 + !t105 = sqr# t104 + !t106 = mul# a t105 + !t107 = sqr# t106 + !t108 = mul# a t107 + !t109 = sqr# t108 + !t110 = mul# a t109 + !t111 = sqr# t110 + !t112 = mul# a t111 + !t113 = sqr# t112 + !t114 = mul# a t113 + !t115 = sqr# t114 + !t116 = mul# a t115 + !t117 = sqr# t116 + !t118 = mul# a t117 + !t119 = sqr# t118 + !t120 = mul# a t119 + !t121 = sqr# t120 + !t122 = mul# a t121 + !t123 = sqr# t122 + !t124 = mul# a t123 + !t125 = sqr# t124 + !t126 = mul# a t125 + !t127 = sqr# t126 + !t128 = mul# a t127 + !t129 = sqr# t128 + !t130 = mul# a t129 + !t131 = sqr# t130 + !t132 = mul# a t131 + !t133 = sqr# t132 + !t134 = mul# a t133 + !t135 = sqr# t134 + !t136 = mul# a t135 + !t137 = sqr# t136 + !t138 = mul# a t137 + !t139 = sqr# t138 + !t140 = mul# a t139 + !t141 = sqr# t140 + !t142 = mul# a t141 + !t143 = sqr# t142 + !t144 = mul# a t143 + !t145 = sqr# t144 + !t146 = mul# a t145 + !t147 = sqr# t146 + !t148 = mul# a t147 + !t149 = sqr# t148 + !t150 = mul# a t149 + !t151 = sqr# t150 + !t152 = mul# a t151 + !t153 = sqr# t152 + !t154 = mul# a t153 + !t155 = sqr# t154 + !t156 = mul# a t155 + !t157 = sqr# t156 + !t158 = mul# a t157 + !t159 = sqr# t158 + !t160 = mul# a t159 + !t161 = sqr# t160 + !t162 = mul# a t161 + !t163 = sqr# t162 + !t164 = mul# a t163 + !t165 = sqr# t164 + !t166 = mul# a t165 + !t167 = sqr# t166 + !t168 = mul# a t167 + !t169 = sqr# t168 + !t170 = mul# a t169 + !t171 = sqr# t170 + !t172 = mul# a t171 + !t173 = sqr# t172 + !t174 = mul# a t173 + !t175 = sqr# t174 + !t176 = mul# a t175 + !t177 = sqr# t176 + !t178 = mul# a t177 + !t179 = sqr# t178 + !t180 = mul# a t179 + !t181 = sqr# t180 + !t182 = mul# a t181 + !t183 = sqr# t182 + !t184 = mul# a t183 + !t185 = sqr# t184 + !t186 = mul# a t185 + !t187 = sqr# t186 + !t188 = mul# a t187 + !t189 = sqr# t188 + !t190 = mul# a t189 + !t191 = sqr# t190 + !t192 = mul# a t191 + !t193 = sqr# t192 + !t194 = mul# a t193 + !t195 = sqr# t194 + !t196 = mul# a t195 + !t197 = sqr# t196 + !t198 = mul# a t197 + !t199 = sqr# t198 + !t200 = mul# a t199 + !t201 = sqr# t200 + !t202 = mul# a t201 + !t203 = sqr# t202 + !t204 = mul# a t203 + !t205 = sqr# t204 + !t206 = mul# a t205 + !t207 = sqr# t206 + !t208 = mul# a t207 + !t209 = sqr# t208 + !t210 = mul# a t209 + !t211 = sqr# t210 + !t212 = mul# a t211 + !t213 = sqr# t212 + !t214 = mul# a t213 + !t215 = sqr# t214 + !t216 = mul# a t215 + !t217 = sqr# t216 + !t218 = mul# a t217 + !t219 = sqr# t218 + !t220 = mul# a t219 + !t221 = sqr# t220 + !t222 = mul# a t221 + !t223 = sqr# t222 + !t224 = mul# a t223 + !t225 = sqr# t224 + !t226 = mul# a t225 + !t227 = sqr# t226 + !t228 = mul# a t227 + !t229 = sqr# t228 + !t230 = mul# a t229 + !t231 = sqr# t230 + !t232 = mul# a t231 + !t233 = sqr# t232 + !t234 = mul# a t233 + !t235 = sqr# t234 + !t236 = mul# a t235 + !t237 = sqr# t236 + !t238 = mul# a t237 + !t239 = sqr# t238 + !t240 = mul# a t239 + !t241 = sqr# t240 + !t242 = mul# a t241 + !t243 = sqr# t242 + !t244 = mul# a t243 + !t245 = sqr# t244 + !t246 = mul# a t245 + !t247 = sqr# t246 + !t248 = mul# a t247 + !t249 = sqr# t248 + !t250 = mul# a t249 + !t251 = sqr# t250 + !t252 = mul# a t251 + !t253 = sqr# t252 + !t254 = mul# a t253 + !t255 = sqr# t254 + !t256 = mul# a t255 + !t257 = sqr# t256 + !t258 = mul# a t257 + !t259 = sqr# t258 + !t260 = mul# a t259 + !t261 = sqr# t260 + !t262 = mul# a t261 + !t263 = sqr# t262 + !t264 = mul# a t263 + !t265 = sqr# t264 + !t266 = mul# a t265 + !t267 = sqr# t266 + !t268 = mul# a t267 + !t269 = sqr# t268 + !t270 = mul# a t269 + !t271 = sqr# t270 + !t272 = mul# a t271 + !t273 = sqr# t272 + !t274 = mul# a t273 + !t275 = sqr# t274 + !t276 = mul# a t275 + !t277 = sqr# t276 + !t278 = mul# a t277 + !t279 = sqr# t278 + !t280 = mul# a t279 + !t281 = sqr# t280 + !t282 = mul# a t281 + !t283 = sqr# t282 + !t284 = mul# a t283 + !t285 = sqr# t284 + !t286 = mul# a t285 + !t287 = sqr# t286 + !t288 = mul# a t287 + !t289 = sqr# t288 + !t290 = mul# a t289 + !t291 = sqr# t290 + !t292 = mul# a t291 + !t293 = sqr# t292 + !t294 = mul# a t293 + !t295 = sqr# t294 + !t296 = mul# a t295 + !t297 = sqr# t296 + !t298 = mul# a t297 + !t299 = sqr# t298 + !t300 = mul# a t299 + !t301 = sqr# t300 + !t302 = mul# a t301 + !t303 = sqr# t302 + !t304 = mul# a t303 + !t305 = sqr# t304 + !t306 = mul# a t305 + !t307 = sqr# t306 + !t308 = mul# a t307 + !t309 = sqr# t308 + !t310 = mul# a t309 + !t311 = sqr# t310 + !t312 = mul# a t311 + !t313 = sqr# t312 + !t314 = mul# a t313 + !t315 = sqr# t314 + !t316 = mul# a t315 + !t317 = sqr# t316 + !t318 = mul# a t317 + !t319 = sqr# t318 + !t320 = mul# a t319 + !t321 = sqr# t320 + !t322 = mul# a t321 + !t323 = sqr# t322 + !t324 = mul# a t323 + !t325 = sqr# t324 + !t326 = mul# a t325 + !t327 = sqr# t326 + !t328 = mul# a t327 + !t329 = sqr# t328 + !t330 = mul# a t329 + !t331 = sqr# t330 + !t332 = mul# a t331 + !t333 = sqr# t332 + !t334 = mul# a t333 + !t335 = sqr# t334 + !t336 = mul# a t335 + !t337 = sqr# t336 + !t338 = mul# a t337 + !t339 = sqr# t338 + !t340 = mul# a t339 + !t341 = sqr# t340 + !t342 = mul# a t341 + !t343 = sqr# t342 + !t344 = mul# a t343 + !t345 = sqr# t344 + !t346 = mul# a t345 + !t347 = sqr# t346 + !t348 = mul# a t347 + !t349 = sqr# t348 + !t350 = mul# a t349 + !t351 = sqr# t350 + !t352 = mul# a t351 + !t353 = sqr# t352 + !t354 = mul# a t353 + !t355 = sqr# t354 + !t356 = mul# a t355 + !t357 = sqr# t356 + !t358 = mul# a t357 + !t359 = sqr# t358 + !t360 = mul# a t359 + !t361 = sqr# t360 + !t362 = mul# a t361 + !t363 = sqr# t362 + !t364 = mul# a t363 + !t365 = sqr# t364 + !t366 = mul# a t365 + !t367 = sqr# t366 + !t368 = mul# a t367 + !t369 = sqr# t368 + !t370 = mul# a t369 + !t371 = sqr# t370 + !t372 = mul# a t371 + !t373 = sqr# t372 + !t374 = mul# a t373 + !t375 = sqr# t374 + !t376 = mul# a t375 + !t377 = sqr# t376 + !t378 = mul# a t377 + !t379 = sqr# t378 + !t380 = mul# a t379 + !t381 = sqr# t380 + !t382 = mul# a t381 + !t383 = sqr# t382 + !t384 = mul# a t383 + !t385 = sqr# t384 + !t386 = mul# a t385 + !t387 = sqr# t386 + !t388 = mul# a t387 + !t389 = sqr# t388 + !t390 = mul# a t389 + !t391 = sqr# t390 + !t392 = mul# a t391 + !t393 = sqr# t392 + !t394 = mul# a t393 + !t395 = sqr# t394 + !t396 = mul# a t395 + !t397 = sqr# t396 + !t398 = mul# a t397 + !t399 = sqr# t398 + !t400 = mul# a t399 + !t401 = sqr# t400 + !t402 = mul# a t401 + !t403 = sqr# t402 + !t404 = mul# a t403 + !t405 = sqr# t404 + !t406 = mul# a t405 + !t407 = sqr# t406 + !t408 = mul# a t407 + !t409 = sqr# t408 + !t410 = mul# a t409 + !t411 = sqr# t410 + !t412 = mul# a t411 + !t413 = sqr# t412 + !t414 = mul# a t413 + !t415 = sqr# t414 + !t416 = mul# a t415 + !t417 = sqr# t416 + !t418 = mul# a t417 + !t419 = sqr# t418 + !t420 = mul# a t419 + !t421 = sqr# t420 + !t422 = mul# a t421 + !t423 = sqr# t422 + !t424 = mul# a t423 + !t425 = sqr# t424 + !t426 = mul# a t425 + !t427 = sqr# t426 + !t428 = mul# a t427 + !t429 = sqr# t428 + !t430 = mul# a t429 + !t431 = sqr# t430 + !t432 = mul# a t431 + !t433 = sqr# t432 + !t434 = mul# a t433 + !t435 = sqr# t434 + !t436 = mul# a t435 + !t437 = sqr# t436 + !t438 = mul# a t437 + !t439 = sqr# t438 + !t440 = mul# a t439 + !t441 = sqr# t440 + !t442 = mul# a t441 + !t443 = sqr# t442 + !t444 = mul# a t443 + !t445 = sqr# t444 + !t446 = mul# a t445 + !t447 = sqr# t446 + !t448 = sqr# t447 + !t449 = mul# a t448 + !t450 = sqr# t449 + !t451 = mul# a t450 + !t452 = sqr# t451 + !t453 = mul# a t452 + !t454 = sqr# t453 + !t455 = mul# a t454 + !t456 = sqr# t455 + !t457 = mul# a t456 + !t458 = sqr# t457 + !t459 = mul# a t458 + !t460 = sqr# t459 + !t461 = mul# a t460 + !t462 = sqr# t461 + !t463 = mul# a t462 + !t464 = sqr# t463 + !t465 = mul# a t464 + !t466 = sqr# t465 + !t467 = mul# a t466 + !t468 = sqr# t467 + !t469 = mul# a t468 + !t470 = sqr# t469 + !t471 = mul# a t470 + !t472 = sqr# t471 + !t473 = mul# a t472 + !t474 = sqr# t473 + !t475 = mul# a t474 + !t476 = sqr# t475 + !t477 = mul# a t476 + !t478 = sqr# t477 + !t479 = mul# a t478 + !t480 = sqr# t479 + !t481 = mul# a t480 + !t482 = sqr# t481 + !t483 = mul# a t482 + !t484 = sqr# t483 + !t485 = mul# a t484 + !t486 = sqr# t485 + !t487 = mul# a t486 + !t488 = sqr# t487 + !t489 = mul# a t488 + !t490 = sqr# t489 + !t491 = mul# a t490 + !t492 = sqr# t491 + !t493 = sqr# t492 + !t494 = sqr# t493 + !t495 = sqr# t494 + !t496 = sqr# t495 + !t497 = mul# a t496 + !t498 = sqr# t497 + !t499 = sqr# t498 + !t500 = mul# a t499 + !t501 = sqr# t500 + !t502 = mul# a t501 + !t503 = sqr# t502 + !t504 = sqr# t503 + !t505 = mul# a t504 + !r = t505 + in r +{-# INLINE inv# #-} + +-- | Multiplicative inverse in the Montgomery domain. +-- +-- >> inv 2 +-- 57896044618658097711785492504343953926634992332820282019728792003954417335832 +-- >> inv 2 * 2 +-- 1 +inv :: Montgomery -> Montgomery +inv (Montgomery w) = Montgomery (inv# w) + +-- | Square root (Tonelli-Shanks) in the Montgomery domain. +-- +-- For a, return x such that a = x x mod p. Returns nothing if no such +-- square root exists. +-- +-- >>> sqrt 4 +-- Just 2 +-- >>> sqrt 15 +-- Just 69211104694897500952317515077652022726490027694212560352756646854116994689233 +-- >>> (*) <$> sqrt 15 <*> sqrt 15 +-- Just 15 +sqrt :: Montgomery -> Maybe Montgomery +sqrt (Montgomery n) = case sqrt# n of + (# a | #) -> Just $! Montgomery a + _ -> Nothing + +-- generated by etc/generate_sqrt.sh +sqrt# + :: (# Limb, Limb, Limb, Limb #) + -> (# (# Limb, Limb, Limb, Limb #) | () #) +sqrt# a = + let !t0 = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) + !t1 = sqr# t0 + !t2 = sqr# t1 + !t3 = sqr# t2 + !t4 = mul# a t3 + !t5 = sqr# t4 + !t6 = mul# a t5 + !t7 = sqr# t6 + !t8 = mul# a t7 + !t9 = sqr# t8 + !t10 = mul# a t9 + !t11 = sqr# t10 + !t12 = mul# a t11 + !t13 = sqr# t12 + !t14 = mul# a t13 + !t15 = sqr# t14 + !t16 = mul# a t15 + !t17 = sqr# t16 + !t18 = mul# a t17 + !t19 = sqr# t18 + !t20 = mul# a t19 + !t21 = sqr# t20 + !t22 = mul# a t21 + !t23 = sqr# t22 + !t24 = mul# a t23 + !t25 = sqr# t24 + !t26 = mul# a t25 + !t27 = sqr# t26 + !t28 = mul# a t27 + !t29 = sqr# t28 + !t30 = mul# a t29 + !t31 = sqr# t30 + !t32 = mul# a t31 + !t33 = sqr# t32 + !t34 = mul# a t33 + !t35 = sqr# t34 + !t36 = mul# a t35 + !t37 = sqr# t36 + !t38 = mul# a t37 + !t39 = sqr# t38 + !t40 = mul# a t39 + !t41 = sqr# t40 + !t42 = mul# a t41 + !t43 = sqr# t42 + !t44 = mul# a t43 + !t45 = sqr# t44 + !t46 = mul# a t45 + !t47 = sqr# t46 + !t48 = mul# a t47 + !t49 = sqr# t48 + !t50 = mul# a t49 + !t51 = sqr# t50 + !t52 = mul# a t51 + !t53 = sqr# t52 + !t54 = mul# a t53 + !t55 = sqr# t54 + !t56 = mul# a t55 + !t57 = sqr# t56 + !t58 = mul# a t57 + !t59 = sqr# t58 + !t60 = mul# a t59 + !t61 = sqr# t60 + !t62 = mul# a t61 + !t63 = sqr# t62 + !t64 = mul# a t63 + !t65 = sqr# t64 + !t66 = mul# a t65 + !t67 = sqr# t66 + !t68 = mul# a t67 + !t69 = sqr# t68 + !t70 = mul# a t69 + !t71 = sqr# t70 + !t72 = mul# a t71 + !t73 = sqr# t72 + !t74 = mul# a t73 + !t75 = sqr# t74 + !t76 = mul# a t75 + !t77 = sqr# t76 + !t78 = mul# a t77 + !t79 = sqr# t78 + !t80 = mul# a t79 + !t81 = sqr# t80 + !t82 = mul# a t81 + !t83 = sqr# t82 + !t84 = mul# a t83 + !t85 = sqr# t84 + !t86 = mul# a t85 + !t87 = sqr# t86 + !t88 = mul# a t87 + !t89 = sqr# t88 + !t90 = mul# a t89 + !t91 = sqr# t90 + !t92 = mul# a t91 + !t93 = sqr# t92 + !t94 = mul# a t93 + !t95 = sqr# t94 + !t96 = mul# a t95 + !t97 = sqr# t96 + !t98 = mul# a t97 + !t99 = sqr# t98 + !t100 = mul# a t99 + !t101 = sqr# t100 + !t102 = mul# a t101 + !t103 = sqr# t102 + !t104 = mul# a t103 + !t105 = sqr# t104 + !t106 = mul# a t105 + !t107 = sqr# t106 + !t108 = mul# a t107 + !t109 = sqr# t108 + !t110 = mul# a t109 + !t111 = sqr# t110 + !t112 = mul# a t111 + !t113 = sqr# t112 + !t114 = mul# a t113 + !t115 = sqr# t114 + !t116 = mul# a t115 + !t117 = sqr# t116 + !t118 = mul# a t117 + !t119 = sqr# t118 + !t120 = mul# a t119 + !t121 = sqr# t120 + !t122 = mul# a t121 + !t123 = sqr# t122 + !t124 = mul# a t123 + !t125 = sqr# t124 + !t126 = mul# a t125 + !t127 = sqr# t126 + !t128 = mul# a t127 + !t129 = sqr# t128 + !t130 = mul# a t129 + !t131 = sqr# t130 + !t132 = mul# a t131 + !t133 = sqr# t132 + !t134 = mul# a t133 + !t135 = sqr# t134 + !t136 = mul# a t135 + !t137 = sqr# t136 + !t138 = mul# a t137 + !t139 = sqr# t138 + !t140 = mul# a t139 + !t141 = sqr# t140 + !t142 = mul# a t141 + !t143 = sqr# t142 + !t144 = mul# a t143 + !t145 = sqr# t144 + !t146 = mul# a t145 + !t147 = sqr# t146 + !t148 = mul# a t147 + !t149 = sqr# t148 + !t150 = mul# a t149 + !t151 = sqr# t150 + !t152 = mul# a t151 + !t153 = sqr# t152 + !t154 = mul# a t153 + !t155 = sqr# t154 + !t156 = mul# a t155 + !t157 = sqr# t156 + !t158 = mul# a t157 + !t159 = sqr# t158 + !t160 = mul# a t159 + !t161 = sqr# t160 + !t162 = mul# a t161 + !t163 = sqr# t162 + !t164 = mul# a t163 + !t165 = sqr# t164 + !t166 = mul# a t165 + !t167 = sqr# t166 + !t168 = mul# a t167 + !t169 = sqr# t168 + !t170 = mul# a t169 + !t171 = sqr# t170 + !t172 = mul# a t171 + !t173 = sqr# t172 + !t174 = mul# a t173 + !t175 = sqr# t174 + !t176 = mul# a t175 + !t177 = sqr# t176 + !t178 = mul# a t177 + !t179 = sqr# t178 + !t180 = mul# a t179 + !t181 = sqr# t180 + !t182 = mul# a t181 + !t183 = sqr# t182 + !t184 = mul# a t183 + !t185 = sqr# t184 + !t186 = mul# a t185 + !t187 = sqr# t186 + !t188 = mul# a t187 + !t189 = sqr# t188 + !t190 = mul# a t189 + !t191 = sqr# t190 + !t192 = mul# a t191 + !t193 = sqr# t192 + !t194 = mul# a t193 + !t195 = sqr# t194 + !t196 = mul# a t195 + !t197 = sqr# t196 + !t198 = mul# a t197 + !t199 = sqr# t198 + !t200 = mul# a t199 + !t201 = sqr# t200 + !t202 = mul# a t201 + !t203 = sqr# t202 + !t204 = mul# a t203 + !t205 = sqr# t204 + !t206 = mul# a t205 + !t207 = sqr# t206 + !t208 = mul# a t207 + !t209 = sqr# t208 + !t210 = mul# a t209 + !t211 = sqr# t210 + !t212 = mul# a t211 + !t213 = sqr# t212 + !t214 = mul# a t213 + !t215 = sqr# t214 + !t216 = mul# a t215 + !t217 = sqr# t216 + !t218 = mul# a t217 + !t219 = sqr# t218 + !t220 = mul# a t219 + !t221 = sqr# t220 + !t222 = mul# a t221 + !t223 = sqr# t222 + !t224 = mul# a t223 + !t225 = sqr# t224 + !t226 = mul# a t225 + !t227 = sqr# t226 + !t228 = mul# a t227 + !t229 = sqr# t228 + !t230 = mul# a t229 + !t231 = sqr# t230 + !t232 = mul# a t231 + !t233 = sqr# t232 + !t234 = mul# a t233 + !t235 = sqr# t234 + !t236 = mul# a t235 + !t237 = sqr# t236 + !t238 = mul# a t237 + !t239 = sqr# t238 + !t240 = mul# a t239 + !t241 = sqr# t240 + !t242 = mul# a t241 + !t243 = sqr# t242 + !t244 = mul# a t243 + !t245 = sqr# t244 + !t246 = mul# a t245 + !t247 = sqr# t246 + !t248 = mul# a t247 + !t249 = sqr# t248 + !t250 = mul# a t249 + !t251 = sqr# t250 + !t252 = mul# a t251 + !t253 = sqr# t252 + !t254 = mul# a t253 + !t255 = sqr# t254 + !t256 = mul# a t255 + !t257 = sqr# t256 + !t258 = mul# a t257 + !t259 = sqr# t258 + !t260 = mul# a t259 + !t261 = sqr# t260 + !t262 = mul# a t261 + !t263 = sqr# t262 + !t264 = mul# a t263 + !t265 = sqr# t264 + !t266 = mul# a t265 + !t267 = sqr# t266 + !t268 = mul# a t267 + !t269 = sqr# t268 + !t270 = mul# a t269 + !t271 = sqr# t270 + !t272 = mul# a t271 + !t273 = sqr# t272 + !t274 = mul# a t273 + !t275 = sqr# t274 + !t276 = mul# a t275 + !t277 = sqr# t276 + !t278 = mul# a t277 + !t279 = sqr# t278 + !t280 = mul# a t279 + !t281 = sqr# t280 + !t282 = mul# a t281 + !t283 = sqr# t282 + !t284 = mul# a t283 + !t285 = sqr# t284 + !t286 = mul# a t285 + !t287 = sqr# t286 + !t288 = mul# a t287 + !t289 = sqr# t288 + !t290 = mul# a t289 + !t291 = sqr# t290 + !t292 = mul# a t291 + !t293 = sqr# t292 + !t294 = mul# a t293 + !t295 = sqr# t294 + !t296 = mul# a t295 + !t297 = sqr# t296 + !t298 = mul# a t297 + !t299 = sqr# t298 + !t300 = mul# a t299 + !t301 = sqr# t300 + !t302 = mul# a t301 + !t303 = sqr# t302 + !t304 = mul# a t303 + !t305 = sqr# t304 + !t306 = mul# a t305 + !t307 = sqr# t306 + !t308 = mul# a t307 + !t309 = sqr# t308 + !t310 = mul# a t309 + !t311 = sqr# t310 + !t312 = mul# a t311 + !t313 = sqr# t312 + !t314 = mul# a t313 + !t315 = sqr# t314 + !t316 = mul# a t315 + !t317 = sqr# t316 + !t318 = mul# a t317 + !t319 = sqr# t318 + !t320 = mul# a t319 + !t321 = sqr# t320 + !t322 = mul# a t321 + !t323 = sqr# t322 + !t324 = mul# a t323 + !t325 = sqr# t324 + !t326 = mul# a t325 + !t327 = sqr# t326 + !t328 = mul# a t327 + !t329 = sqr# t328 + !t330 = mul# a t329 + !t331 = sqr# t330 + !t332 = mul# a t331 + !t333 = sqr# t332 + !t334 = mul# a t333 + !t335 = sqr# t334 + !t336 = mul# a t335 + !t337 = sqr# t336 + !t338 = mul# a t337 + !t339 = sqr# t338 + !t340 = mul# a t339 + !t341 = sqr# t340 + !t342 = mul# a t341 + !t343 = sqr# t342 + !t344 = mul# a t343 + !t345 = sqr# t344 + !t346 = mul# a t345 + !t347 = sqr# t346 + !t348 = mul# a t347 + !t349 = sqr# t348 + !t350 = mul# a t349 + !t351 = sqr# t350 + !t352 = mul# a t351 + !t353 = sqr# t352 + !t354 = mul# a t353 + !t355 = sqr# t354 + !t356 = mul# a t355 + !t357 = sqr# t356 + !t358 = mul# a t357 + !t359 = sqr# t358 + !t360 = mul# a t359 + !t361 = sqr# t360 + !t362 = mul# a t361 + !t363 = sqr# t362 + !t364 = mul# a t363 + !t365 = sqr# t364 + !t366 = mul# a t365 + !t367 = sqr# t366 + !t368 = mul# a t367 + !t369 = sqr# t368 + !t370 = mul# a t369 + !t371 = sqr# t370 + !t372 = mul# a t371 + !t373 = sqr# t372 + !t374 = mul# a t373 + !t375 = sqr# t374 + !t376 = mul# a t375 + !t377 = sqr# t376 + !t378 = mul# a t377 + !t379 = sqr# t378 + !t380 = mul# a t379 + !t381 = sqr# t380 + !t382 = mul# a t381 + !t383 = sqr# t382 + !t384 = mul# a t383 + !t385 = sqr# t384 + !t386 = mul# a t385 + !t387 = sqr# t386 + !t388 = mul# a t387 + !t389 = sqr# t388 + !t390 = mul# a t389 + !t391 = sqr# t390 + !t392 = mul# a t391 + !t393 = sqr# t392 + !t394 = mul# a t393 + !t395 = sqr# t394 + !t396 = mul# a t395 + !t397 = sqr# t396 + !t398 = mul# a t397 + !t399 = sqr# t398 + !t400 = mul# a t399 + !t401 = sqr# t400 + !t402 = mul# a t401 + !t403 = sqr# t402 + !t404 = mul# a t403 + !t405 = sqr# t404 + !t406 = mul# a t405 + !t407 = sqr# t406 + !t408 = mul# a t407 + !t409 = sqr# t408 + !t410 = mul# a t409 + !t411 = sqr# t410 + !t412 = mul# a t411 + !t413 = sqr# t412 + !t414 = mul# a t413 + !t415 = sqr# t414 + !t416 = mul# a t415 + !t417 = sqr# t416 + !t418 = mul# a t417 + !t419 = sqr# t418 + !t420 = mul# a t419 + !t421 = sqr# t420 + !t422 = mul# a t421 + !t423 = sqr# t422 + !t424 = mul# a t423 + !t425 = sqr# t424 + !t426 = mul# a t425 + !t427 = sqr# t426 + !t428 = mul# a t427 + !t429 = sqr# t428 + !t430 = mul# a t429 + !t431 = sqr# t430 + !t432 = mul# a t431 + !t433 = sqr# t432 + !t434 = mul# a t433 + !t435 = sqr# t434 + !t436 = mul# a t435 + !t437 = sqr# t436 + !t438 = mul# a t437 + !t439 = sqr# t438 + !t440 = mul# a t439 + !t441 = sqr# t440 + !t442 = mul# a t441 + !t443 = sqr# t442 + !t444 = mul# a t443 + !t445 = sqr# t444 + !t446 = mul# a t445 + !t447 = sqr# t446 + !t448 = mul# a t447 + !t449 = sqr# t448 + !t450 = sqr# t449 + !t451 = mul# a t450 + !t452 = sqr# t451 + !t453 = mul# a t452 + !t454 = sqr# t453 + !t455 = mul# a t454 + !t456 = sqr# t455 + !t457 = mul# a t456 + !t458 = sqr# t457 + !t459 = mul# a t458 + !t460 = sqr# t459 + !t461 = mul# a t460 + !t462 = sqr# t461 + !t463 = mul# a t462 + !t464 = sqr# t463 + !t465 = mul# a t464 + !t466 = sqr# t465 + !t467 = mul# a t466 + !t468 = sqr# t467 + !t469 = mul# a t468 + !t470 = sqr# t469 + !t471 = mul# a t470 + !t472 = sqr# t471 + !t473 = mul# a t472 + !t474 = sqr# t473 + !t475 = mul# a t474 + !t476 = sqr# t475 + !t477 = mul# a t476 + !t478 = sqr# t477 + !t479 = mul# a t478 + !t480 = sqr# t479 + !t481 = mul# a t480 + !t482 = sqr# t481 + !t483 = mul# a t482 + !t484 = sqr# t483 + !t485 = mul# a t484 + !t486 = sqr# t485 + !t487 = mul# a t486 + !t488 = sqr# t487 + !t489 = mul# a t488 + !t490 = sqr# t489 + !t491 = mul# a t490 + !t492 = sqr# t491 + !t493 = mul# a t492 + !t494 = sqr# t493 + !t495 = sqr# t494 + !t496 = sqr# t495 + !t497 = sqr# t496 + !t498 = sqr# t497 + !t499 = mul# a t498 + !t500 = sqr# t499 + !t501 = mul# a t500 + !t502 = sqr# t501 + !t503 = sqr# t502 + !r = t503 + in if C.decide (WW.eq# (sqr# r) a) + then (# r | #) + else (# | () #) +{-# INLINE sqrt# #-} + +-- | Exponentiation in the Montgomery domain. +-- +-- >>> exp 2 3 +-- 8 +-- >>> exp 2 10 +-- 1024 +exp :: Montgomery -> Wider -> Montgomery +exp (Montgomery b) (Wider e) = + let !one# = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #) + loop !r !_ !_ 0 = r + loop !r !m !ex !n = + let !(# ne, bit #) = WW.shr1_c# ex + !candidate = mul# r m + !nr = select# r candidate bit + !nm = sqr# m + in loop nr nm ne (n - 1) + in Montgomery (loop one# b e (256 :: Word)) + +odd# :: (# Limb, Limb, Limb, Limb #) -> C.Choice +odd# = WW.odd# +{-# INLINE odd #-} + +-- | Check if a 'Montgomery' value is odd. +-- +-- >>> odd 1 +-- True +-- >>> odd 2 +-- False +-- >>> Data.Word.Wider.odd (retr 3) -- parity is preserved +-- True +odd :: Montgomery -> Bool +odd (Montgomery m) = C.decide (odd# m) + +-- constant-time selection ---------------------------------------------------- + +select# + :: (# Limb, Limb, Limb, Limb #) -- ^ a + -> (# Limb, Limb, Limb, Limb #) -- ^ b + -> C.Choice -- ^ c + -> (# Limb, Limb, Limb, Limb #) -- ^ result +select# = WW.select# +{-# INLINE select# #-} + +-- | Return a if c is truthy, otherwise return b. +-- +-- >>> import qualified Data.Choice as C +-- >>> select 0 1 (C.true# ()) +-- 1 +select + :: Montgomery -- ^ a + -> Montgomery -- ^ b + -> C.Choice -- ^ c + -> Montgomery -- ^ result +select (Montgomery a) (Montgomery b) c = Montgomery (select# a b c) + diff --git a/lib/Numeric/Montgomery/Secp256k1/Scalar.hs b/lib/Numeric/Montgomery/Secp256k1/Scalar.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/Montgomery/Secp256k1/Scalar.hs @@ -0,0 +1,999 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +-- | +-- Module: Numeric.Montgomery.Secp256k1.Scalar +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Montgomery form 'Wider' words, as well as arithmetic operations, with +-- domain derived from the secp256k1 elliptic curve scalar group order. + +module Numeric.Montgomery.Secp256k1.Scalar ( + -- * Montgomery form, secp256k1 scalar group order modulus + Montgomery(..) + , render + , to + , from + , zero + , one + + -- * Comparison + , eq + , eq_vartime + + -- * Reduction and retrieval + , redc + , retr + , redc# + , retr# + + -- * Constant-time selection + , select# + , select + + -- * Montgomery arithmetic + , add + , add# + , sub + , sub# + , mul + , mul# + , sqr + , sqr# + , neg + , neg# + , inv + , inv# + , exp + , odd# + , odd + ) where + +import Control.DeepSeq +import qualified Data.Choice as C +import Data.Word.Limb (Limb(..)) +import qualified Data.Word.Limb as L +import qualified Data.Word.Wide as W +import Data.Word.Wider (Wider(..)) +import qualified Data.Word.Wider as WW +import GHC.Exts (Word(..)) +import Prelude hiding (or, and, not, exp, odd) + +-- montgomery arithmetic, specialized to the secp256k1 scalar group order +-- 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 + +-- | Montgomery-form 'Wider' words, on the Montgomery domain defined by +-- the secp256k1 scalar group order. +-- +-- >>> let one = 1 :: Montgomery +-- >>> one +-- 1 +-- >>> putStrLn (render one) +-- (4624529908474429119, 4994812053365940164, 1, 0) +data Montgomery = Montgomery !(# Limb, Limb, Limb, Limb #) + +instance Show Montgomery where + show = show . from + +-- | Render a 'Montgomery' value as a 'String', showing its individual +-- 'Limb's. +-- +-- >>> putStrLn (render 1) +-- (4624529908474429119, 4994812053365940164, 1, 0) +render :: Montgomery -> String +render (Montgomery (# Limb a, Limb b, Limb c, Limb d #)) = + "(" <> show (W# a) <> ", " <> show (W# b) <> ", " + <> show (W# c) <> ", " <> show (W# d) <> ")" + +instance Num Montgomery where + a + b = add a b + a - b = sub a b + a * b = mul a b + negate a = neg a + abs = id + fromInteger = to . WW.to + signum a = case a of + Montgomery (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) -> 0 + _ -> 1 + +instance Eq Montgomery where + a == b = C.decide (eq a b) + +instance NFData Montgomery where + rnf (Montgomery a) = case a of (# _, _, _, _ #) -> () + +-- utilities ------------------------------------------------------------------ + +-- Wide wrapping addition, when addend is only a limb. +wadd_w# :: (# Limb, Limb #) -> Limb -> (# Limb, Limb #) +wadd_w# (# x_lo, x_hi #) y_lo = + let !(# s0, c0 #) = L.add_o# x_lo y_lo + !(# s1, _ #) = L.add_o# x_hi c0 + in (# s0, s1 #) +{-# INLINE wadd_w# #-} + +-- Truncate a wide word to a 'Limb'. +lo :: (# Limb, Limb #) -> Limb +lo (# l, _ #) = l +{-# INLINE lo #-} + +-- comparison ----------------------------------------------------------------- + +-- | Constant-time equality comparison. +eq :: Montgomery -> Montgomery -> C.Choice +eq + (Montgomery (# Limb a0, Limb a1, Limb a2, Limb a3 #)) + (Montgomery (# Limb b0, Limb b1, Limb b2, Limb b3 #)) + = C.eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) +{-# INLINE eq #-} + +-- | Variable-time equality comparison. +eq_vartime :: Montgomery -> Montgomery -> Bool +eq_vartime (Montgomery (Wider -> a)) (Montgomery (Wider -> b)) = + WW.eq_vartime a b + +-- innards -------------------------------------------------------------------- + +redc_inner# + :: (# Limb, Limb, Limb, Limb #) -- ^ upper limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ lower limbs + -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ upper limbs, meta-carry +redc_inner# (# u0, u1, u2, u3 #) (# l0, l1, l2, l3 #) = + let !(# m0, m1, m2, m3 #) = + (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + !n = Limb 0x4B0DFF665588B13F## + !w_0 = L.mul_w# l0 n + !(# _, c_00 #) = L.mac# w_0 m0 l0 (Limb 0##) + !(# l0_1, c_01 #) = L.mac# w_0 m1 l1 c_00 + !(# l0_2, c_02 #) = L.mac# w_0 m2 l2 c_01 + !(# l0_3, c_03 #) = L.mac# w_0 m3 l3 c_02 + !(# u_0, mc_0 #) = L.add_c# u0 c_03 (Limb 0##) + !w_1 = L.mul_w# l0_1 n + !(# _, c_10 #) = L.mac# w_1 m0 l0_1 (Limb 0##) + !(# l1_1, c_11 #) = L.mac# w_1 m1 l0_2 c_10 + !(# l1_2, c_12 #) = L.mac# w_1 m2 l0_3 c_11 + !(# u1_3, c_13 #) = L.mac# w_1 m3 u_0 c_12 + !(# u_1, mc_1 #) = L.add_c# u1 c_13 mc_0 + !w_2 = L.mul_w# l1_1 n + !(# _, c_20 #) = L.mac# w_2 m0 l1_1 (Limb 0##) + !(# l2_1, c_21 #) = L.mac# w_2 m1 l1_2 c_20 + !(# u2_2, c_22 #) = L.mac# w_2 m2 u1_3 c_21 + !(# u2_3, c_23 #) = L.mac# w_2 m3 u_1 c_22 + !(# u_2, mc_2 #) = L.add_c# u2 c_23 mc_1 + !w_3 = L.mul_w# l2_1 n + !(# _, c_30 #) = L.mac# w_3 m0 l2_1 (Limb 0##) + !(# u3_1, c_31 #) = L.mac# w_3 m1 u2_2 c_30 + !(# u3_2, c_32 #) = L.mac# w_3 m2 u2_3 c_31 + !(# u3_3, c_33 #) = L.mac# w_3 m3 u_2 c_32 + !(# u_3, mc_3 #) = L.add_c# u3 c_33 mc_2 + in (# (# u3_1, u3_2, u3_3, u_3 #), mc_3 #) +{-# INLINE redc_inner# #-} + +redc# + :: (# Limb, Limb, Limb, Limb #) -- ^ lower limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ upper limbs + -> (# Limb, Limb, Limb, Limb #) -- ^ result +redc# l u = + let -- group order + !m = (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + !(# nu, mc #) = redc_inner# u l + in WW.sub_mod_c# nu mc m m +{-# INLINE redc# #-} + +-- | Montgomery reduction. +-- +-- The first argument represents the low words, and the second the +-- high words, of an extra-large eight-limb word in Montgomery form. +redc + :: Montgomery -- ^ low wider-word, Montgomery form + -> Montgomery -- ^ high wider-word, Montgomery form + -> Montgomery -- ^ reduced value +redc (Montgomery l) (Montgomery u) = + let !res = redc# l u + in (Montgomery res) + +retr_inner# + :: (# Limb, Limb, Limb, Limb #) -- ^ value in montgomery form + -> (# Limb, Limb, Limb, Limb #) -- ^ retrieved value +retr_inner# (# x0, x1, x2, x3 #) = + let !(# m0, m1, m2, m3 #) = + (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + !n = Limb 0x4B0DFF665588B13F## + !u_0 = L.mul_w# x0 n + !(# _, o0 #) = L.mac# u_0 m0 x0 (Limb 0##) + !(# o0_1, p0_1 #) = L.mac# u_0 m1 (Limb 0##) o0 + !(# p0_2, q0_2 #) = L.mac# u_0 m2 (Limb 0##) p0_1 + !(# q0_3, r0_3 #) = L.mac# u_0 m3 (Limb 0##) q0_2 + !u_1 = L.mul_w# (L.add_w# o0_1 x1) n + !(# _, o1 #) = L.mac# u_1 m0 x1 o0_1 + !(# o1_1, p1_1 #) = L.mac# u_1 m1 p0_2 o1 + !(# p1_2, q1_2 #) = L.mac# u_1 m2 q0_3 p1_1 + !(# q1_3, r1_3 #) = L.mac# u_1 m3 r0_3 q1_2 + !u_2 = L.mul_w# (L.add_w# o1_1 x2) n + !(# _, o2 #) = L.mac# u_2 m0 x2 o1_1 + !(# o2_1, p2_1 #) = L.mac# u_2 m1 p1_2 o2 + !(# p2_2, q2_2 #) = L.mac# u_2 m2 q1_3 p2_1 + !(# q2_3, r2_3 #) = L.mac# u_2 m3 r1_3 q2_2 + !u_3 = L.mul_w# (L.add_w# o2_1 x3) n + !(# _, o3 #) = L.mac# u_3 m0 x3 o2_1 + !(# o3_1, p3_1 #) = L.mac# u_3 m1 p2_2 o3 + !(# p3_2, q3_2 #) = L.mac# u_3 m2 q2_3 p3_1 + !(# q3_3, r3_3 #) = L.mac# u_3 m3 r2_3 q3_2 + in (# o3_1, p3_2, q3_3, r3_3 #) +{-# INLINE retr_inner# #-} + +retr# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +retr# f = retr_inner# f +{-# INLINE retr# #-} + +-- | Retrieve a 'Montgomery' value from the Montgomery domain, producing +-- a 'Wider' word. +retr + :: Montgomery -- ^ value in Montgomery form + -> Wider -- ^ retrieved value +retr (Montgomery f) = + let !res = retr# f + in (Wider res) + +-- | Montgomery multiplication (FIOS), without conditional subtract. +mul_inner# + :: (# Limb, Limb, Limb, Limb #) -- ^ x + -> (# Limb, Limb, Limb, Limb #) -- ^ y + -> (# (# Limb, Limb, Limb, Limb #), Limb #) -- ^ product, meta-carry +mul_inner# (# x0, x1, x2, x3 #) (# y0, y1, y2, y3 #) = + let !(# m0, m1, m2, m3 #) = + (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + !n = Limb 0x4B0DFF665588B13F## + !axy0 = L.mul_c# x0 y0 + !u0 = L.mul_w# (lo axy0) n + !(# (# _, a0 #), c0 #) = W.add_o# (L.mul_c# u0 m0) axy0 + !carry0 = (# a0, c0 #) + !axy0_1 = L.mul_c# x0 y1 + !umc0_1 = W.add_w# (L.mul_c# u0 m1) carry0 + !(# (# o0, ab0_1 #), c0_1 #) = W.add_o# axy0_1 umc0_1 + !carry0_1 = (# ab0_1, c0_1 #) + !axy0_2 = L.mul_c# x0 y2 + !umc0_2 = W.add_w# (L.mul_c# u0 m2) carry0_1 + !(# (# p0, ab0_2 #), c0_2 #) = W.add_o# axy0_2 umc0_2 + !carry0_2 = (# ab0_2, c0_2 #) + !axy0_3 = L.mul_c# x0 y3 + !umc0_3 = W.add_w# (L.mul_c# u0 m3) carry0_2 + !(# (# q0, ab0_3 #), c0_3 #) = W.add_o# axy0_3 umc0_3 + !carry0_3 = (# ab0_3, c0_3 #) + !(# r0, mc0 #) = carry0_3 + !axy1 = wadd_w# (L.mul_c# x1 y0) o0 + !u1 = L.mul_w# (lo axy1) n + !(# (# _, a1 #), c1 #) = W.add_o# (L.mul_c# u1 m0) axy1 + !carry1 = (# a1, c1 #) + !axy1_1 = wadd_w# (L.mul_c# x1 y1) p0 + !umc1_1 = W.add_w# (L.mul_c# u1 m1) carry1 + !(# (# o1, ab1_1 #), c1_1 #) = W.add_o# axy1_1 umc1_1 + !carry1_1 = (# ab1_1, c1_1 #) + !axy1_2 = wadd_w# (L.mul_c# x1 y2) q0 + !umc1_2 = W.add_w# (L.mul_c# u1 m2) carry1_1 + !(# (# p1, ab1_2 #), c1_2 #) = W.add_o# axy1_2 umc1_2 + !carry1_2 = (# ab1_2, c1_2 #) + !axy1_3 = wadd_w# (L.mul_c# x1 y3) r0 + !umc1_3 = W.add_w# (L.mul_c# u1 m3) carry1_2 + !(# (# q1, ab1_3 #), c1_3 #) = W.add_o# axy1_3 umc1_3 + !carry1_3 = (# ab1_3, c1_3 #) + !(# r1, mc1 #) = wadd_w# carry1_3 mc0 + !axy2 = wadd_w# (L.mul_c# x2 y0) o1 + !u2 = L.mul_w# (lo axy2) n + !(# (# _, a2 #), c2 #) = W.add_o# (L.mul_c# u2 m0) axy2 + !carry2 = (# a2, c2 #) + !axy2_1 = wadd_w# (L.mul_c# x2 y1) p1 + !umc2_1 = W.add_w# (L.mul_c# u2 m1) carry2 + !(# (# o2, ab2_1 #), c2_1 #) = W.add_o# axy2_1 umc2_1 + !carry2_1 = (# ab2_1, c2_1 #) + !axy2_2 = wadd_w# (L.mul_c# x2 y2) q1 + !umc2_2 = W.add_w# (L.mul_c# u2 m2) carry2_1 + !(# (# p2, ab2_2 #), c2_2 #) = W.add_o# axy2_2 umc2_2 + !carry2_2 = (# ab2_2, c2_2 #) + !axy2_3 = wadd_w# (L.mul_c# x2 y3) r1 + !umc2_3 = W.add_w# (L.mul_c# u2 m3) carry2_2 + !(# (# q2, ab2_3 #), c2_3 #) = W.add_o# axy2_3 umc2_3 + !carry2_3 = (# ab2_3, c2_3 #) + !(# r2, mc2 #) = wadd_w# carry2_3 mc1 + !axy3 = wadd_w# (L.mul_c# x3 y0) o2 + !u3 = L.mul_w# (lo axy3) n + !(# (# _, a3 #), c3 #) = W.add_o# (L.mul_c# u3 m0) axy3 + !carry3 = (# a3, c3 #) + !axy3_1 = wadd_w# (L.mul_c# x3 y1) p2 + !umc3_1 = W.add_w# (L.mul_c# u3 m1) carry3 + !(# (# o3, ab3_1 #), c3_1 #) = W.add_o# axy3_1 umc3_1 + !carry3_1 = (# ab3_1, c3_1 #) + !axy3_2 = wadd_w# (L.mul_c# x3 y2) q2 + !umc3_2 = W.add_w# (L.mul_c# u3 m2) carry3_1 + !(# (# p3, ab3_2 #), c3_2 #) = W.add_o# axy3_2 umc3_2 + !carry3_2 = (# ab3_2, c3_2 #) + !axy3_3 = wadd_w# (L.mul_c# x3 y3) r2 + !umc3_3 = W.add_w# (L.mul_c# u3 m3) carry3_2 + !(# (# q3, ab3_3 #), c3_3 #) = W.add_o# axy3_3 umc3_3 + !carry3_3 = (# ab3_3, c3_3 #) + !(# r3, mc3 #) = wadd_w# carry3_3 mc2 + in (# (# o3, p3, q3, r3 #), mc3 #) +{-# INLINE mul_inner# #-} + +mul# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +mul# a b = + let -- group order + !m = (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + !(# nu, mc #) = mul_inner# a b + in WW.sub_mod_c# nu mc m m +{-# NOINLINE mul# #-} -- cannot be inlined without exploding comp time + +-- | Multiplication in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use '*' +-- to apply this function. +-- +-- >>> 1 * 1 :: Montgomery +-- 1 +mul + :: Montgomery -- ^ multiplicand in montgomery form + -> Montgomery -- ^ multiplier in montgomery form + -> Montgomery -- ^ montgomery product +mul (Montgomery a) (Montgomery b) = Montgomery (mul# a b) + +to# + :: (# Limb, Limb, Limb, Limb #) -- ^ integer + -> (# Limb, Limb, Limb, Limb #) +to# x = + let -- r^2 mod m + !r2 = (# Limb 0x896CF21467D7D140##, Limb 0x741496C20E7CF878## + , Limb 0xE697F5E45BCD07C6##, Limb 0x9D671CD581C69BC5## #) + in mul# x r2 +{-# INLINE to# #-} + +-- | Convert a 'Wider' word to the Montgomery domain. +to :: Wider -> Montgomery +to (Wider x) = Montgomery (to# x) + +-- | Retrieve a 'Montgomery' word from the Montgomery domain. +-- +-- This function is a synonym for 'retr'. +from :: Montgomery -> Wider +from = retr + +add# + :: (# Limb, Limb, Limb, Limb #) -- ^ augend + -> (# Limb, Limb, Limb, Limb #) -- ^ addend + -> (# Limb, Limb, Limb, Limb #) -- ^ sum +add# a b = + let -- group order + !m = (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + in WW.add_mod# a b m +{-# INLINE add# #-} + +-- | Addition in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use '+' +-- to apply this function. +-- +-- >>> 1 + 1 :: Montgomery +-- 2 +add + :: Montgomery -- ^ augend + -> Montgomery -- ^ addend + -> Montgomery -- ^ sum +add (Montgomery a) (Montgomery b) = Montgomery (add# a b) + +sub# + :: (# Limb, Limb, Limb, Limb #) -- ^ minuend + -> (# Limb, Limb, Limb, Limb #) -- ^ subtrahend + -> (# Limb, Limb, Limb, Limb #) -- ^ difference +sub# a b = + let !m = (# Limb 0xBFD25E8CD0364141##, Limb 0xBAAEDCE6AF48A03B## + , Limb 0xFFFFFFFFFFFFFFFE##, Limb 0xFFFFFFFFFFFFFFFF## #) + in WW.sub_mod# a b m +{-# INLINE sub# #-} + +-- | Subtraction in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use '-' +-- to apply this function. +-- +-- >>> 1 - 1 :: Montgomery +-- 0 +sub + :: Montgomery -- ^ minuend + -> Montgomery -- ^ subtrahend + -> Montgomery -- ^ difference +sub (Montgomery a) (Montgomery b) = Montgomery (sub# a b) + +neg# + :: (# Limb, Limb, Limb, Limb #) -- ^ argument + -> (# Limb, Limb, Limb, Limb #) -- ^ modular negation +neg# a = sub# (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) a +{-# INLINE neg# #-} + +-- | Additive inverse in the Montgomery domain. +-- +-- Note that 'Montgomery' is an instance of 'Num', so you can use 'negate' +-- to apply this function. +-- +-- >>> negate 1 :: Montgomery +-- 115792089237316195423570985008687907852837564279074904382605163141518161494336 +-- >>> (negate 1 :: Montgomery) + 1 +-- 0 +neg :: Montgomery -> Montgomery +neg (Montgomery a) = Montgomery (neg# a) + +sqr# :: (# Limb, Limb, Limb, Limb #) -> (# Limb, Limb, Limb, Limb #) +sqr# a = + let !(# l, h #) = WW.sqr# a + in redc# l h +{-# NOINLINE sqr# #-} -- cannot be inlined without exploding comp time + +-- | Squaring in the Montgomery domain. +-- +-- >>> sqr 1 +-- 1 +-- >>> sqr 2 +-- 4 +-- >>> sqr (negate 2) +-- 4 +sqr + :: Montgomery -- ^ argument + -> Montgomery -- ^ square +sqr (Montgomery a) = Montgomery (mul# a a) + +-- | Zero (the additive unit) in the Montgomery domain. +zero :: Montgomery +zero = Montgomery (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #) + +-- | One (the multiplicative unit) in the Montgomery domain. +one :: Montgomery +one = Montgomery + (# Limb 0x402DA1732FC9BEBF##, Limb 0x4551231950B75FC4## + , Limb 0x0000000000000001##, Limb 0x0000000000000000## #) + +-- generated by etc/generate_inv.sh +inv# + :: (# Limb, Limb, Limb, Limb #) + -> (# Limb, Limb, Limb, Limb #) +inv# a = + let !t0 = (# Limb 0x402DA1732FC9BEBF##, Limb 0x4551231950B75FC4## + , Limb 0x0000000000000001##, Limb 0x0000000000000000## #) + !t1 = sqr# t0 + !t2 = mul# a t1 + !t3 = sqr# t2 + !t4 = mul# a t3 + !t5 = sqr# t4 + !t6 = mul# a t5 + !t7 = sqr# t6 + !t8 = mul# a t7 + !t9 = sqr# t8 + !t10 = mul# a t9 + !t11 = sqr# t10 + !t12 = mul# a t11 + !t13 = sqr# t12 + !t14 = mul# a t13 + !t15 = sqr# t14 + !t16 = mul# a t15 + !t17 = sqr# t16 + !t18 = mul# a t17 + !t19 = sqr# t18 + !t20 = mul# a t19 + !t21 = sqr# t20 + !t22 = mul# a t21 + !t23 = sqr# t22 + !t24 = mul# a t23 + !t25 = sqr# t24 + !t26 = mul# a t25 + !t27 = sqr# t26 + !t28 = mul# a t27 + !t29 = sqr# t28 + !t30 = mul# a t29 + !t31 = sqr# t30 + !t32 = mul# a t31 + !t33 = sqr# t32 + !t34 = mul# a t33 + !t35 = sqr# t34 + !t36 = mul# a t35 + !t37 = sqr# t36 + !t38 = mul# a t37 + !t39 = sqr# t38 + !t40 = mul# a t39 + !t41 = sqr# t40 + !t42 = mul# a t41 + !t43 = sqr# t42 + !t44 = mul# a t43 + !t45 = sqr# t44 + !t46 = mul# a t45 + !t47 = sqr# t46 + !t48 = mul# a t47 + !t49 = sqr# t48 + !t50 = mul# a t49 + !t51 = sqr# t50 + !t52 = mul# a t51 + !t53 = sqr# t52 + !t54 = mul# a t53 + !t55 = sqr# t54 + !t56 = mul# a t55 + !t57 = sqr# t56 + !t58 = mul# a t57 + !t59 = sqr# t58 + !t60 = mul# a t59 + !t61 = sqr# t60 + !t62 = mul# a t61 + !t63 = sqr# t62 + !t64 = mul# a t63 + !t65 = sqr# t64 + !t66 = mul# a t65 + !t67 = sqr# t66 + !t68 = mul# a t67 + !t69 = sqr# t68 + !t70 = mul# a t69 + !t71 = sqr# t70 + !t72 = mul# a t71 + !t73 = sqr# t72 + !t74 = mul# a t73 + !t75 = sqr# t74 + !t76 = mul# a t75 + !t77 = sqr# t76 + !t78 = mul# a t77 + !t79 = sqr# t78 + !t80 = mul# a t79 + !t81 = sqr# t80 + !t82 = mul# a t81 + !t83 = sqr# t82 + !t84 = mul# a t83 + !t85 = sqr# t84 + !t86 = mul# a t85 + !t87 = sqr# t86 + !t88 = mul# a t87 + !t89 = sqr# t88 + !t90 = mul# a t89 + !t91 = sqr# t90 + !t92 = mul# a t91 + !t93 = sqr# t92 + !t94 = mul# a t93 + !t95 = sqr# t94 + !t96 = mul# a t95 + !t97 = sqr# t96 + !t98 = mul# a t97 + !t99 = sqr# t98 + !t100 = mul# a t99 + !t101 = sqr# t100 + !t102 = mul# a t101 + !t103 = sqr# t102 + !t104 = mul# a t103 + !t105 = sqr# t104 + !t106 = mul# a t105 + !t107 = sqr# t106 + !t108 = mul# a t107 + !t109 = sqr# t108 + !t110 = mul# a t109 + !t111 = sqr# t110 + !t112 = mul# a t111 + !t113 = sqr# t112 + !t114 = mul# a t113 + !t115 = sqr# t114 + !t116 = mul# a t115 + !t117 = sqr# t116 + !t118 = mul# a t117 + !t119 = sqr# t118 + !t120 = mul# a t119 + !t121 = sqr# t120 + !t122 = mul# a t121 + !t123 = sqr# t122 + !t124 = mul# a t123 + !t125 = sqr# t124 + !t126 = mul# a t125 + !t127 = sqr# t126 + !t128 = mul# a t127 + !t129 = sqr# t128 + !t130 = mul# a t129 + !t131 = sqr# t130 + !t132 = mul# a t131 + !t133 = sqr# t132 + !t134 = mul# a t133 + !t135 = sqr# t134 + !t136 = mul# a t135 + !t137 = sqr# t136 + !t138 = mul# a t137 + !t139 = sqr# t138 + !t140 = mul# a t139 + !t141 = sqr# t140 + !t142 = mul# a t141 + !t143 = sqr# t142 + !t144 = mul# a t143 + !t145 = sqr# t144 + !t146 = mul# a t145 + !t147 = sqr# t146 + !t148 = mul# a t147 + !t149 = sqr# t148 + !t150 = mul# a t149 + !t151 = sqr# t150 + !t152 = mul# a t151 + !t153 = sqr# t152 + !t154 = mul# a t153 + !t155 = sqr# t154 + !t156 = mul# a t155 + !t157 = sqr# t156 + !t158 = mul# a t157 + !t159 = sqr# t158 + !t160 = mul# a t159 + !t161 = sqr# t160 + !t162 = mul# a t161 + !t163 = sqr# t162 + !t164 = mul# a t163 + !t165 = sqr# t164 + !t166 = mul# a t165 + !t167 = sqr# t166 + !t168 = mul# a t167 + !t169 = sqr# t168 + !t170 = mul# a t169 + !t171 = sqr# t170 + !t172 = mul# a t171 + !t173 = sqr# t172 + !t174 = mul# a t173 + !t175 = sqr# t174 + !t176 = mul# a t175 + !t177 = sqr# t176 + !t178 = mul# a t177 + !t179 = sqr# t178 + !t180 = mul# a t179 + !t181 = sqr# t180 + !t182 = mul# a t181 + !t183 = sqr# t182 + !t184 = mul# a t183 + !t185 = sqr# t184 + !t186 = mul# a t185 + !t187 = sqr# t186 + !t188 = mul# a t187 + !t189 = sqr# t188 + !t190 = mul# a t189 + !t191 = sqr# t190 + !t192 = mul# a t191 + !t193 = sqr# t192 + !t194 = mul# a t193 + !t195 = sqr# t194 + !t196 = mul# a t195 + !t197 = sqr# t196 + !t198 = mul# a t197 + !t199 = sqr# t198 + !t200 = mul# a t199 + !t201 = sqr# t200 + !t202 = mul# a t201 + !t203 = sqr# t202 + !t204 = mul# a t203 + !t205 = sqr# t204 + !t206 = mul# a t205 + !t207 = sqr# t206 + !t208 = mul# a t207 + !t209 = sqr# t208 + !t210 = mul# a t209 + !t211 = sqr# t210 + !t212 = mul# a t211 + !t213 = sqr# t212 + !t214 = mul# a t213 + !t215 = sqr# t214 + !t216 = mul# a t215 + !t217 = sqr# t216 + !t218 = mul# a t217 + !t219 = sqr# t218 + !t220 = mul# a t219 + !t221 = sqr# t220 + !t222 = mul# a t221 + !t223 = sqr# t222 + !t224 = mul# a t223 + !t225 = sqr# t224 + !t226 = mul# a t225 + !t227 = sqr# t226 + !t228 = mul# a t227 + !t229 = sqr# t228 + !t230 = mul# a t229 + !t231 = sqr# t230 + !t232 = mul# a t231 + !t233 = sqr# t232 + !t234 = mul# a t233 + !t235 = sqr# t234 + !t236 = mul# a t235 + !t237 = sqr# t236 + !t238 = mul# a t237 + !t239 = sqr# t238 + !t240 = mul# a t239 + !t241 = sqr# t240 + !t242 = mul# a t241 + !t243 = sqr# t242 + !t244 = mul# a t243 + !t245 = sqr# t244 + !t246 = mul# a t245 + !t247 = sqr# t246 + !t248 = mul# a t247 + !t249 = sqr# t248 + !t250 = mul# a t249 + !t251 = sqr# t250 + !t252 = mul# a t251 + !t253 = sqr# t252 + !t254 = mul# a t253 + !t255 = sqr# t254 + !t256 = sqr# t255 + !t257 = mul# a t256 + !t258 = sqr# t257 + !t259 = sqr# t258 + !t260 = mul# a t259 + !t261 = sqr# t260 + !t262 = mul# a t261 + !t263 = sqr# t262 + !t264 = mul# a t263 + !t265 = sqr# t264 + !t266 = sqr# t265 + !t267 = mul# a t266 + !t268 = sqr# t267 + !t269 = sqr# t268 + !t270 = mul# a t269 + !t271 = sqr# t270 + !t272 = sqr# t271 + !t273 = mul# a t272 + !t274 = sqr# t273 + !t275 = sqr# t274 + !t276 = mul# a t275 + !t277 = sqr# t276 + !t278 = mul# a t277 + !t279 = sqr# t278 + !t280 = mul# a t279 + !t281 = sqr# t280 + !t282 = sqr# t281 + !t283 = mul# a t282 + !t284 = sqr# t283 + !t285 = mul# a t284 + !t286 = sqr# t285 + !t287 = sqr# t286 + !t288 = mul# a t287 + !t289 = sqr# t288 + !t290 = mul# a t289 + !t291 = sqr# t290 + !t292 = mul# a t291 + !t293 = sqr# t292 + !t294 = sqr# t293 + !t295 = sqr# t294 + !t296 = mul# a t295 + !t297 = sqr# t296 + !t298 = mul# a t297 + !t299 = sqr# t298 + !t300 = mul# a t299 + !t301 = sqr# t300 + !t302 = sqr# t301 + !t303 = sqr# t302 + !t304 = mul# a t303 + !t305 = sqr# t304 + !t306 = mul# a t305 + !t307 = sqr# t306 + !t308 = sqr# t307 + !t309 = mul# a t308 + !t310 = sqr# t309 + !t311 = sqr# t310 + !t312 = mul# a t311 + !t313 = sqr# t312 + !t314 = sqr# t313 + !t315 = mul# a t314 + !t316 = sqr# t315 + !t317 = mul# a t316 + !t318 = sqr# t317 + !t319 = mul# a t318 + !t320 = sqr# t319 + !t321 = mul# a t320 + !t322 = sqr# t321 + !t323 = sqr# t322 + !t324 = mul# a t323 + !t325 = sqr# t324 + !t326 = sqr# t325 + !t327 = sqr# t326 + !t328 = mul# a t327 + !t329 = sqr# t328 + !t330 = sqr# t329 + !t331 = sqr# t330 + !t332 = sqr# t331 + !t333 = mul# a t332 + !t334 = sqr# t333 + !t335 = sqr# t334 + !t336 = mul# a t335 + !t337 = sqr# t336 + !t338 = sqr# t337 + !t339 = sqr# t338 + !t340 = sqr# t339 + !t341 = sqr# t340 + !t342 = sqr# t341 + !t343 = sqr# t342 + !t344 = sqr# t343 + !t345 = mul# a t344 + !t346 = sqr# t345 + !t347 = mul# a t346 + !t348 = sqr# t347 + !t349 = mul# a t348 + !t350 = sqr# t349 + !t351 = sqr# t350 + !t352 = mul# a t351 + !t353 = sqr# t352 + !t354 = mul# a t353 + !t355 = sqr# t354 + !t356 = mul# a t355 + !t357 = sqr# t356 + !t358 = sqr# t357 + !t359 = mul# a t358 + !t360 = sqr# t359 + !t361 = mul# a t360 + !t362 = sqr# t361 + !t363 = mul# a t362 + !t364 = sqr# t363 + !t365 = mul# a t364 + !t366 = sqr# t365 + !t367 = mul# a t366 + !t368 = sqr# t367 + !t369 = mul# a t368 + !t370 = sqr# t369 + !t371 = mul# a t370 + !t372 = sqr# t371 + !t373 = mul# a t372 + !t374 = sqr# t373 + !t375 = sqr# t374 + !t376 = mul# a t375 + !t377 = sqr# t376 + !t378 = sqr# t377 + !t379 = sqr# t378 + !t380 = mul# a t379 + !t381 = sqr# t380 + !t382 = sqr# t381 + !t383 = sqr# t382 + !t384 = mul# a t383 + !t385 = sqr# t384 + !t386 = sqr# t385 + !t387 = mul# a t386 + !t388 = sqr# t387 + !t389 = mul# a t388 + !t390 = sqr# t389 + !t391 = mul# a t390 + !t392 = sqr# t391 + !t393 = mul# a t392 + !t394 = sqr# t393 + !t395 = sqr# t394 + !t396 = mul# a t395 + !t397 = sqr# t396 + !t398 = sqr# t397 + !t399 = sqr# t398 + !t400 = sqr# t399 + !t401 = mul# a t400 + !t402 = sqr# t401 + !t403 = mul# a t402 + !t404 = sqr# t403 + !t405 = sqr# t404 + !t406 = sqr# t405 + !t407 = mul# a t406 + !t408 = sqr# t407 + !t409 = mul# a t408 + !t410 = sqr# t409 + !t411 = sqr# t410 + !t412 = mul# a t411 + !t413 = sqr# t412 + !t414 = sqr# t413 + !t415 = sqr# t414 + !t416 = sqr# t415 + !t417 = sqr# t416 + !t418 = sqr# t417 + !t419 = sqr# t418 + !t420 = mul# a t419 + !t421 = sqr# t420 + !t422 = mul# a t421 + !t423 = sqr# t422 + !t424 = sqr# t423 + !t425 = mul# a t424 + !t426 = sqr# t425 + !t427 = mul# a t426 + !t428 = sqr# t427 + !t429 = sqr# t428 + !t430 = sqr# t429 + !t431 = mul# a t430 + !t432 = sqr# t431 + !t433 = sqr# t432 + !t434 = sqr# t433 + !t435 = sqr# t434 + !t436 = sqr# t435 + !t437 = sqr# t436 + !t438 = mul# a t437 + !t439 = sqr# t438 + !t440 = sqr# t439 + !t441 = sqr# t440 + !t442 = mul# a t441 + !t443 = sqr# t442 + !t444 = mul# a t443 + !t445 = sqr# t444 + !t446 = mul# a t445 + !t447 = sqr# t446 + !t448 = mul# a t447 + !t449 = sqr# t448 + !t450 = mul# a t449 + !t451 = sqr# t450 + !t452 = mul# a t451 + !r = t452 + in r +{-# INLINE inv# #-} + +-- | Multiplicative inverse in the Montgomery domain. +-- +-- >> inv 2 +-- 57896044618658097711785492504343953926418782139537452191302581570759080747169 +-- >> inv 2 * 2 +-- 1 +inv + :: Montgomery -- ^ argument + -> Montgomery -- ^ inverse +inv (Montgomery w) = Montgomery (inv# w) + +-- | Exponentiation in the Montgomery domain. +-- +-- >>> exp 2 3 +-- 8 +-- >>> exp 2 10 +-- 1024 +exp :: Montgomery -> Wider -> Montgomery +exp (Montgomery b) (Wider e) = + let !one# = (# Limb 0x402DA1732FC9BEBF##, Limb 0x4551231950B75FC4## + , Limb 0x0000000000000001##, Limb 0x0000000000000000## #) + loop !r !_ !_ 0 = r + loop !r !m !ex !n = + let !(# ne, bit #) = WW.shr1_c# ex + !candidate = mul# r m + !nr = select# r candidate bit + !nm = sqr# m + in loop nr nm ne (n - 1) + in Montgomery (loop one# b e (256 :: Word)) + +odd# :: (# Limb, Limb, Limb, Limb #) -> C.Choice +odd# = WW.odd# +{-# INLINE odd #-} + +-- | Check if a 'Montgomery' value is odd. +-- +-- >>> odd 1 +-- True +-- >>> odd 2 +-- False +-- >>> Data.Word.Wider.odd (retr 3) -- parity is preserved +-- True +odd :: Montgomery -> Bool +odd (Montgomery m) = C.decide (odd# m) + +-- constant-time selection ---------------------------------------------------- + +select# + :: (# Limb, Limb, Limb, Limb #) -- ^ a + -> (# Limb, Limb, Limb, Limb #) -- ^ b + -> C.Choice -- ^ c + -> (# Limb, Limb, Limb, Limb #) -- ^ result +select# = WW.select# +{-# INLINE select# #-} + +-- | Return a if c is truthy, otherwise return b. +-- +-- >>> import qualified Data.Choice as C +-- >>> select 0 1 (C.true# ()) +-- 1 +select + :: Montgomery -- ^ a + -> Montgomery -- ^ b + -> C.Choice -- ^ c + -> Montgomery -- ^ result +select (Montgomery a) (Montgomery b) c = Montgomery (select# a b c) + diff --git a/ppad-fixed.cabal b/ppad-fixed.cabal new file mode 100644 --- /dev/null +++ b/ppad-fixed.cabal @@ -0,0 +1,95 @@ +cabal-version: 3.0 +name: ppad-fixed +version: 0.1.0 +synopsis: Large fixed-width words and constant-time arithmetic. +license: MIT +license-file: LICENSE +author: Jared Tobin +maintainer: jared@ppad.tech +category: Data +build-type: Simple +tested-with: GHC == { 9.8.1 } +extra-doc-files: CHANGELOG +description: + A pure high-performance implementation of large fixed-width integers + and supporting constant-time operations, including Montgomery-form + arithmetic on domains related to the the elliptic curve secp256k1. + +flag llvm + description: Use GHC's LLVM backend. + default: False + manual: True + +source-repository head + type: git + location: git.ppad.tech/fixed.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + if flag(llvm) + ghc-options: -fllvm -O2 + exposed-modules: + Data.Choice + , Data.Word.Limb + , Data.Word.Wide + , Data.Word.Wider + , Numeric.Montgomery.Secp256k1.Curve + , Numeric.Montgomery.Secp256k1.Scalar + build-depends: + base >= 4.9 && < 5 + , deepseq >= 1.5 && < 1.6 + +test-suite fixed-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Limb + Wide + Wider + Montgomery.Curve + Montgomery.Scalar + + ghc-options: + -rtsopts -Wall -O2 + + build-depends: + base + , ppad-fixed + , tasty + , tasty-hunit + , tasty-quickcheck + +benchmark fixed-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + + ghc-options: + -rtsopts -O2 -Wall -fno-warn-orphans + + build-depends: + base + , criterion + , ppad-fixed + +benchmark fixed-weigh + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Weight.hs + + ghc-options: + -rtsopts -O2 -Wall -fno-warn-orphans + + build-depends: + base + , deepseq + , ppad-fixed + , weigh + diff --git a/test/Limb.hs b/test/Limb.hs new file mode 100644 --- /dev/null +++ b/test/Limb.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Limb ( + tests + ) where + +import qualified Data.Choice as C +import qualified Data.Word.Limb as L +import GHC.Exts +import Test.Tasty +import qualified Test.Tasty.HUnit as H + +overflowing_add_no_carry :: H.Assertion +overflowing_add_no_carry = do + let !(# r, c #) = L.add_o# (L.Limb 0##) (L.Limb 1##) + H.assertBool mempty (L.eq_vartime# r (L.Limb 1##)) + H.assertBool mempty (L.eq_vartime# c (L.Limb 0##)) + +overflowing_add_with_carry :: H.Assertion +overflowing_add_with_carry = do + let !(# r, c #) = L.add_o# (L.Limb (not# 0##)) (L.Limb 1##) + H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) + H.assertBool mempty (L.eq_vartime# c (L.Limb 1##)) + +wrapping_add_no_carry :: H.Assertion +wrapping_add_no_carry = do + let !r = L.add_w# (L.Limb 0##) (L.Limb 1##) + H.assertBool mempty (L.eq_vartime# r (L.Limb 1##)) + +wrapping_add_with_carry :: H.Assertion +wrapping_add_with_carry = do + let !r = L.add_w# (L.Limb (not# 0##)) (L.Limb 1##) + H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) + +borrowing_sub_no_borrow :: H.Assertion +borrowing_sub_no_borrow = do + let !(# r, c #) = L.sub_b# (L.Limb 1##) (L.Limb 1##) (L.Limb 0##) + H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) + H.assertBool mempty (L.eq_vartime# c (L.Limb 0##)) + +borrowing_sub_with_borrow :: H.Assertion +borrowing_sub_with_borrow = do + let !(# r, c #) = L.sub_b# (L.Limb 0##) (L.Limb 1##) (L.Limb 0##) + H.assertBool mempty (L.eq_vartime# r (L.Limb (not# 0##))) + H.assertBool mempty (L.eq_vartime# c (L.Limb (not# 0##))) + +wrapping_sub_no_borrow :: H.Assertion +wrapping_sub_no_borrow = do + let !r = L.sub_w# (L.Limb 1##) (L.Limb 1##) + H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) + +wrapping_sub_with_borrow :: H.Assertion +wrapping_sub_with_borrow = do + let !r = L.sub_w# (L.Limb 0##) (L.Limb 1##) + H.assertBool mempty (L.eq_vartime# r (L.Limb (not# 0##))) + +shl1 :: H.Assertion +shl1 = do + let !r = L.shl# (L.Limb 1##) 1# + H.assertBool mempty (L.eq_vartime# r (L.Limb 2##)) + +shl2 :: H.Assertion +shl2 = do + let !r = L.shl# (L.Limb 1##) 2# + H.assertBool mempty (L.eq_vartime# r (L.Limb 4##)) + +shr1 :: H.Assertion +shr1 = do + let !r = L.shr# (L.Limb 2##) 1# + H.assertBool mempty (L.eq_vartime# r (L.Limb 1##)) + +shr2 :: H.Assertion +shr2 = do + let !r = L.shr# (L.Limb 16##) 2# + H.assertBool mempty (L.eq_vartime# r (L.Limb 4##)) + +eq :: H.Assertion +eq = do + let !a = L.Limb 0## + !b = L.Limb (not# 0##) + H.assertBool mempty (C.decide (L.eq# a a)) + H.assertBool mempty (not (C.decide (L.eq# a b))) + H.assertBool mempty (not (C.decide (L.eq# b a))) + H.assertBool mempty (C.decide (L.eq# b b)) + +gt :: H.Assertion +gt = do + let !a = L.Limb 0## + !b = L.Limb 1## + !c = L.Limb (not# 0##) + H.assertBool mempty (C.decide (L.gt# b a)) + H.assertBool mempty (C.decide (L.gt# c a)) + H.assertBool mempty (C.decide (L.gt# c b)) + + H.assertBool mempty (not (C.decide (L.gt# a a))) + H.assertBool mempty (not (C.decide (L.gt# b b))) + H.assertBool mempty (not (C.decide (L.gt# c c))) + + H.assertBool mempty (not (C.decide (L.gt# a b))) + H.assertBool mempty (not (C.decide (L.gt# a c))) + H.assertBool mempty (not (C.decide (L.gt# b c))) + +lt :: H.Assertion +lt = do + let !a = L.Limb 0## + !b = L.Limb 1## + !c = L.Limb (not# 0##) + H.assertBool mempty (C.decide (L.lt# a b)) + H.assertBool mempty (C.decide (L.lt# a c)) + H.assertBool mempty (C.decide (L.lt# b c)) + + H.assertBool mempty (not (C.decide (L.lt# a a))) + H.assertBool mempty (not (C.decide (L.lt# b b))) + H.assertBool mempty (not (C.decide (L.lt# c c))) + + H.assertBool mempty (not (C.decide (L.lt# b a))) + H.assertBool mempty (not (C.decide (L.lt# c a))) + H.assertBool mempty (not (C.decide (L.lt# c b))) + +cswap :: H.Assertion +cswap = do + let !a = L.Limb (not# 0##) + !b = L.Limb 0## + !(# a0, b0 #) = L.cswap# a b (C.false# ()) + H.assertBool mempty (L.eq_vartime# a0 (L.Limb (not# 0##))) + H.assertBool mempty (L.eq_vartime# b0 (L.Limb 0##)) + let !(# a1, b1 #) = L.cswap# a0 b0 (C.true# ()) + H.assertBool mempty (L.eq_vartime# a1 (L.Limb 0##)) + H.assertBool mempty (L.eq_vartime# b1 (L.Limb (not# 0##))) + +tests :: TestTree +tests = testGroup "limb tests" [ + H.testCase "overflowing add, no carry" overflowing_add_no_carry + , H.testCase "overflowing add, carry" overflowing_add_with_carry + , H.testCase "wrapping add, no carry" wrapping_add_no_carry + , H.testCase "wrapping add, carry" wrapping_add_with_carry + , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow + , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow + , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow + , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow + , H.testCase "left shift (1)" shl1 + , H.testCase "left shift (2)" shl2 + , H.testCase "right shift (1)" shr1 + , H.testCase "right shift (2)" shr2 + , H.testCase "eq" eq + , H.testCase "gt" gt + , H.testCase "lt" lt + , H.testCase "cswap" cswap + ] + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import qualified Montgomery.Curve as Curve +import qualified Montgomery.Scalar as Scalar +import qualified Limb +import qualified Wide +import qualified Wider +import Test.Tasty + +main :: IO () +main = defaultMain $ testGroup "ppad-fixed" [ + Limb.tests + , Wide.tests + , Wider.tests + , Curve.tests + , Scalar.tests + ] + diff --git a/test/Montgomery/Curve.hs b/test/Montgomery/Curve.hs new file mode 100644 --- /dev/null +++ b/test/Montgomery/Curve.hs @@ -0,0 +1,164 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +module Montgomery.Curve ( + tests + ) where + +import qualified Data.Word.Wider as W +import qualified GHC.Num.Integer as I +import GHC.Natural +import qualified Numeric.Montgomery.Secp256k1.Curve as C +import Test.Tasty +import qualified Test.Tasty.HUnit as H +import qualified Test.Tasty.QuickCheck as Q + +-- generic modular exponentiation +-- b ^ e mod m +modexp :: Integer -> Natural -> Natural -> Integer +modexp b (fromIntegral -> e) p = case I.integerPowMod# b e p of + (# fromIntegral -> n | #) -> n + (# | _ #) -> error "bang" +{-# INLINE modexp #-} + +-- modulus +m :: W.Wider +m = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F + +-- modulus +mm :: C.Montgomery +mm = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F + +repr :: H.Assertion +repr = H.assertBool mempty (W.eq_vartime 0 (C.from mm)) + +add_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion +add_case t a b s = do + H.assertEqual "sanity" ((W.from a + W.from b) `mod` W.from m) (W.from s) + H.assertBool t (W.eq_vartime s (C.from (C.to a + C.to b))) + +add :: H.Assertion +add = do + add_case "small" 1 2 3 + add_case "wrap to 0 mod m" + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2E 1 0 + add_case "wrap to 1" + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2D 3 1 + add_case "random" + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210FEDCBA987654321 + 0x0FEEEEEEEEEEEEEEFEEEEEEEEEEEEEEEFEEEEEEEEEEEEEEEFEEEEEEEEEEEEEEE + add_case "near R" + 0xAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + 0x5555555555555555555555555555555555555555555555555555555555555555 + 0x00000000000000000000000000000000000000000000000000000001000003D0 + +sub_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion +sub_case t b a d = do + H.assertEqual "sanity" ((W.from b - W.from a) `mod` W.from m) (W.from d) + H.assertBool t (W.eq_vartime d (C.from (C.to b - C.to a))) + +sub :: H.Assertion +sub = do + sub_case "small" 3 2 1 + sub_case "wrap from 0 mod m" 0 1 + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2E + sub_case "wrap to 0" 1 1 0 + sub_case "random" + 0x0FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210FEDCBA987654321 + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0FECA8641FDB975320ECA8641FDB975320ECA8641FDB975320ECA8641FDB9754 + sub_case "near R" + 0x00000000000000000000000000000000000000000000000000000001000003D0 + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2E + 0x00000000000000000000000000000000000000000000000000000001000003D1 + +mul_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion +mul_case t a b p = do + H.assertEqual "sanity" ((W.from a * W.from b) `mod` W.from m) (W.from p) + H.assertBool t (W.eq_vartime p (C.from (C.to a * C.to b))) + +mul :: H.Assertion +mul = do + mul_case "small" 2 3 6 + mul_case "wrap to 1 mod m" + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2E + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2E + 0x1 + mul_case "zero" + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0 + 0x0 + mul_case "random" + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210FEDCBA987654321 + 0xCEF9C520FC3502A4BA6F1CE3B2550511D5E474A66875077EF159DE87E15148FC + mul_case "near R" + 0x00000000000000000000000000000000000000000000000000000001000003D1 + 0x00000000000000000000000000000000000000000000000000000001000003D1 + 0x000000000000000000000000000000000000000000000001000007A2000E90A1 + +instance Q.Arbitrary W.Wider where + arbitrary = fmap W.to Q.arbitrary + +instance Q.Arbitrary C.Montgomery where + arbitrary = fmap C.to Q.arbitrary + +add_matches :: W.Wider -> W.Wider -> Bool +add_matches a b = + let ma = C.to a + mb = C.to b + ia = W.from a + ib = W.from b + im = W.from m + in W.eq_vartime (W.to ((ia + ib) `mod` im)) (C.from (ma + mb)) + +mul_matches :: W.Wider -> W.Wider -> Bool +mul_matches a b = + let ma = C.to a + mb = C.to b + ia = W.from a + ib = W.from b + im = W.from m + in W.eq_vartime (W.to ((ia * ib) `mod` im)) (C.from (ma * mb)) + +sqr_matches :: W.Wider -> Bool +sqr_matches a = + let ma = C.to a + ia = W.from a + im = W.from m + in W.eq_vartime (W.to ((ia * ia) `mod` im)) (C.from (C.sqr ma)) + +exp_matches :: C.Montgomery -> W.Wider -> Bool +exp_matches a b = + let ia = W.from (C.from a) + nb = fromIntegral (W.from b) + nm = fromIntegral (W.from m) + in W.eq_vartime (W.to (modexp ia nb nm)) (C.from (C.exp a b)) + +inv_valid :: Q.NonZero C.Montgomery -> Bool +inv_valid (Q.NonZero s) = C.eq_vartime (C.inv s * s) 1 + +odd_correct :: C.Montgomery -> Bool +odd_correct w = C.odd w == I.integerTestBit (W.from (C.from w)) 0 + +tests :: TestTree +tests = testGroup "montgomery tests (curve)" [ + H.testCase "representation" repr + , H.testCase "add" add + , H.testCase "sub" sub + , H.testCase "mul" mul + , Q.testProperty "a + b mod m ~ ma + mb" $ Q.withMaxSuccess 500 add_matches + , Q.testProperty "a * b mod m ~ ma * mb" $ Q.withMaxSuccess 500 mul_matches + , Q.testProperty "a ^ 2 mod m ~ ma ^ 2" $ Q.withMaxSuccess 500 sqr_matches + , Q.testProperty "a ^ b mod m ~ ma ^ mb" $ Q.withMaxSuccess 500 exp_matches + , Q.testProperty "n ^ -1 mod m * n ~ 1" $ Q.withMaxSuccess 500 inv_valid + , Q.testProperty "odd m ~ odd (from m)" $ Q.withMaxSuccess 500 odd_correct + ] + diff --git a/test/Montgomery/Scalar.hs b/test/Montgomery/Scalar.hs new file mode 100644 --- /dev/null +++ b/test/Montgomery/Scalar.hs @@ -0,0 +1,160 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +module Montgomery.Scalar ( + tests + ) where + +import qualified Data.Word.Wider as W +import qualified GHC.Num.Integer as I +import GHC.Natural +import qualified Numeric.Montgomery.Secp256k1.Scalar as S +import Test.Tasty +import qualified Test.Tasty.HUnit as H +import qualified Test.Tasty.QuickCheck as Q + +-- generic modular exponentiation +-- b ^ e mod m +modexp :: Integer -> Natural -> Natural -> Integer +modexp b (fromIntegral -> e) q = case I.integerPowMod# b e q of + (# fromIntegral -> n | #) -> n + (# | _ #) -> error "bang" +{-# INLINE modexp #-} + +-- modulus +m :: W.Wider +m = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 + +-- modulus +mm :: S.Montgomery +mm = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 + +repr :: H.Assertion +repr = H.assertBool mempty (W.eq_vartime 0 (S.from mm)) + +add_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion +add_case t a b s = do + H.assertEqual "sanity" ((W.from a + W.from b) `mod` W.from m) (W.from s) + H.assertBool t (W.eq_vartime s (S.from (S.to a + S.to b))) + +add :: H.Assertion +add = do + add_case "small" 1 2 3 + add_case "wrap to 0 mod m" + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364140 1 0 + add_case "wrap to 1" + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD036413F 3 1 + add_case "random" + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210FEDCBA987654321 + 0x0FEEEEEEEEEEEEEEFEEEEEEEEEEEEEEEFEEEEEEEEEEEEEEEFEEEEEEEEEEEEEEE + add_case "near R" + 0xAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + 0x5555555555555555555555555555555555555555555555555555555555555555 + 0x000000000000000000000000000000014551231950B75FC4402DA1732FC9BEBE + +sub_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion +sub_case t b a d = do + H.assertEqual "sanity" ((W.from b - W.from a) `mod` W.from m) (W.from d) + H.assertBool t (W.eq_vartime d (S.from (S.to b - S.to a))) + +sub :: H.Assertion +sub = do + sub_case "small" 3 2 1 + sub_case "wrap from 0 mod m" 0 1 + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364140 + sub_case "wrap to 0" 1 1 0 + sub_case "random" + 0x0FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210FEDCBA987654321 + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0FECA8641FDB975320ECA8641FDB975320ECA8641FDB975320ECA8641FDB9754 + sub_case "near R" + 0x000000000000000000000000000000014551231950B75FC4402DA1732FC9BEBE + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364140 + 0x000000000000000000000000000000014551231950B75FC4402DA1732FC9BEBF + +mul_case :: String -> W.Wider -> W.Wider -> W.Wider -> H.Assertion +mul_case t a b p = do + H.assertEqual "sanity" ((W.from a * W.from b) `mod` W.from m) (W.from p) + H.assertBool t (W.eq_vartime p (S.from (S.to a * S.to b))) + +mul :: H.Assertion +mul = do + mul_case "small" 2 3 6 + mul_case "wrap to 1 mod m" + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364140 + 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364140 + 0x1 + mul_case "zero" + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0 + 0x0 + mul_case "random" + 0x000123456789ABCDEF0123456789ABCDEF0123456789ABCDEF0123456789ABCD + 0x0FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210FEDCBA987654321 + 0x1A9B526FE2B5CE72CE59A8E81612BC5785CED8C6B231B643B36DA80BE2A60636 + mul_case "near R" + 0x000000000000000000000000000000014551231950B75FC4402DA1732FC9BEBF + 0x000000000000000000000000000000014551231950B75FC4402DA1732FC9BEBF + 0x9D671CD581C69BC5E697F5E45BCD07C6741496C20E7CF878896CF21467D7D140 + +instance Q.Arbitrary W.Wider where + arbitrary = fmap W.to Q.arbitrary + +instance Q.Arbitrary S.Montgomery where + arbitrary = fmap S.to Q.arbitrary + +add_matches :: W.Wider -> W.Wider -> Bool +add_matches a b = + let ma = S.to a + mb = S.to b + ia = W.from a + ib = W.from b + im = W.from m + in W.eq_vartime (W.to ((ia + ib) `mod` im)) (S.from (ma + mb)) + +mul_matches :: W.Wider -> W.Wider -> Bool +mul_matches a b = + let ma = S.to a + mb = S.to b + ia = W.from a + ib = W.from b + im = W.from m + in W.eq_vartime (W.to ((ia * ib) `mod` im)) (S.from (ma * mb)) + +sqr_matches :: W.Wider -> Bool +sqr_matches a = + let ma = S.to a + ia = W.from a + im = W.from m + in W.eq_vartime (W.to ((ia * ia) `mod` im)) (S.from (S.sqr ma)) + +exp_matches :: S.Montgomery -> W.Wider -> Bool +exp_matches a b = + let ia = W.from (S.from a) + nb = fromIntegral (W.from b) + nm = fromIntegral (W.from m) + in W.eq_vartime (W.to (modexp ia nb nm)) (S.from (S.exp a b)) + +inv_valid :: Q.NonZero S.Montgomery -> Bool +inv_valid (Q.NonZero s) = S.eq_vartime (S.inv s * s) 1 + +tests :: TestTree +tests = testGroup "montgomery tests (scalar)" [ + H.testCase "representation" repr + , H.testCase "add" add + , H.testCase "sub" sub + , H.testCase "mul" mul + , Q.testProperty "a + b mod m ~ ma + mb" $ Q.withMaxSuccess 500 add_matches + , Q.testProperty "a * b mod m ~ ma * mb" $ Q.withMaxSuccess 500 mul_matches + , Q.testProperty "a ^ 2 mod m ~ ma ^ 2" $ Q.withMaxSuccess 500 sqr_matches + , Q.testProperty "a ^ b mod m ~ ma ^ mb" $ Q.withMaxSuccess 500 exp_matches + , Q.testProperty "n ^ -1 mod m * n ~ 1" $ Q.withMaxSuccess 500 inv_valid + ] + diff --git a/test/Wide.hs b/test/Wide.hs new file mode 100644 --- /dev/null +++ b/test/Wide.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Wide ( + tests + ) where + +import qualified Data.Word.Wide as W +import Test.Tasty +import qualified Test.Tasty.HUnit as H + +overflowing_add_no_carry :: H.Assertion +overflowing_add_no_carry = do + let !(r, c) = W.add_o 1 0 + H.assertBool mempty (W.eq_vartime r 1) + H.assertBool mempty (c == 0) + +overflowing_add_with_carry :: H.Assertion +overflowing_add_with_carry = do + let !(r, c) = W.add_o (2 ^ (128 :: Word) - 1) 1 + H.assertBool mempty (W.eq_vartime r 0) + H.assertBool mempty (c == 1) + +wrapping_add_no_carry :: H.Assertion +wrapping_add_no_carry = do + let !r = W.add 0 1 + H.assertBool mempty (W.eq_vartime r 1) + +wrapping_add_with_carry :: H.Assertion +wrapping_add_with_carry = do + let !r = W.add (2 ^ (128 :: Word) - 1) 1 + H.assertBool mempty (W.eq_vartime r 0) + +tests :: TestTree +tests = testGroup "wide tests" [ + H.testCase "overflowing add, no carry" overflowing_add_no_carry + , H.testCase "overflowing add, carry" overflowing_add_with_carry + , H.testCase "wrapping add, no carry" wrapping_add_no_carry + , H.testCase "wrapping add, carry" wrapping_add_with_carry + ] + diff --git a/test/Wider.hs b/test/Wider.hs new file mode 100644 --- /dev/null +++ b/test/Wider.hs @@ -0,0 +1,171 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE UnboxedTuples #-} + +module Wider ( + tests + ) where + +import qualified Data.Choice as C +import qualified Data.Word.Wider as W +import qualified GHC.Num.Integer as I +import Test.Tasty +import qualified Test.Tasty.HUnit as H +import qualified Test.Tasty.QuickCheck as Q + +overflowing_add_no_carry :: H.Assertion +overflowing_add_no_carry = do + let !(r, c) = W.add_o 1 0 + H.assertBool mempty (W.eq_vartime r 1) + H.assertBool mempty (c == 0) + +overflowing_add_with_carry :: H.Assertion +overflowing_add_with_carry = do + let !(r, c) = W.add_o (2 ^ (256 :: Word) - 1) 1 + H.assertBool mempty (W.eq_vartime r 0) + H.assertBool mempty (c == 1) + +wrapping_add_no_carry :: H.Assertion +wrapping_add_no_carry = do + let !r = W.add 0 1 + H.assertBool mempty (W.eq_vartime r 1) + +wrapping_add_with_carry :: H.Assertion +wrapping_add_with_carry = do + let !r = W.add (2 ^ (256 :: Word) - 1) 1 + H.assertBool mempty (W.eq_vartime r 0) + +borrowing_sub_no_borrow :: H.Assertion +borrowing_sub_no_borrow = do + let !(d, b) = W.sub_b 1 1 + H.assertBool mempty (W.eq_vartime d 0) + H.assertBool mempty (b == 0) + +borrowing_sub_with_borrow :: H.Assertion +borrowing_sub_with_borrow = do + let !(d, b) = W.sub_b 0 1 + H.assertBool mempty (W.eq_vartime d (2 ^ (256 :: Word) - 1)) + H.assertBool mempty (b == (2 ^ (64 :: Word) - 1)) + +wrapping_sub_no_borrow :: H.Assertion +wrapping_sub_no_borrow = do + let !r = W.sub 1 1 + H.assertBool mempty (W.eq_vartime r 0) + +wrapping_sub_with_borrow :: H.Assertion +wrapping_sub_with_borrow = do + let !r = W.sub 0 1 + H.assertBool mempty (W.eq_vartime r (2 ^ (256 :: Word) - 1)) + +eq :: H.Assertion +eq = do + let !(W.Wider a) = 0 + !(W.Wider b) = 2 ^ (256 :: Word) - 1 + H.assertBool mempty (C.decide (W.eq# a a)) + H.assertBool mempty (not (C.decide (W.eq# a b))) + H.assertBool mempty (not (C.decide (W.eq# b a))) + H.assertBool mempty (C.decide (W.eq# b b)) + +gt :: H.Assertion +gt = do + let !(W.Wider a) = 0 + !(W.Wider b) = 1 + !(W.Wider c) = 2 ^ (256 :: Word) - 1 + H.assertBool mempty (C.decide (W.gt# b a)) + H.assertBool mempty (C.decide (W.gt# c a)) + H.assertBool mempty (C.decide (W.gt# c b)) + + H.assertBool mempty (not (C.decide (W.gt# a a))) + H.assertBool mempty (not (C.decide (W.gt# b b))) + H.assertBool mempty (not (C.decide (W.gt# c c))) + + H.assertBool mempty (not (C.decide (W.gt# a b))) + H.assertBool mempty (not (C.decide (W.gt# a c))) + H.assertBool mempty (not (C.decide (W.gt# b c))) + +lt :: H.Assertion +lt = do + let !(W.Wider a) = 0 + !(W.Wider b) = 1 + !(W.Wider c) = 2 ^ (256 :: Word) - 1 + H.assertBool mempty (C.decide (W.lt# a b)) + H.assertBool mempty (C.decide (W.lt# a c)) + H.assertBool mempty (C.decide (W.lt# b c)) + + H.assertBool mempty (not (C.decide (W.lt# a a))) + H.assertBool mempty (not (C.decide (W.lt# b b))) + H.assertBool mempty (not (C.decide (W.lt# c c))) + + H.assertBool mempty (not (C.decide (W.lt# b a))) + H.assertBool mempty (not (C.decide (W.lt# c a))) + H.assertBool mempty (not (C.decide (W.lt# c b))) + +cmp :: H.Assertion +cmp = do + let !a = 0 + !b = 1 + !c = 2 ^ (256 :: Word) - 1 + H.assertEqual mempty (W.cmp a b) LT + H.assertEqual mempty (W.cmp a c) LT + H.assertEqual mempty (W.cmp b c) LT + + H.assertEqual mempty (W.cmp a a) EQ + H.assertEqual mempty (W.cmp b b) EQ + H.assertEqual mempty (W.cmp c c) EQ + + H.assertEqual mempty (W.cmp b a) GT + H.assertEqual mempty (W.cmp c a) GT + H.assertEqual mempty (W.cmp c b) GT + +sqr :: H.Assertion +sqr = do + let !n = 2 ^ (256 :: Word) - 1 + !(l, h ) = W.sqr n + H.assertBool mempty (W.eq_vartime l 1) + H.assertBool mempty (W.eq_vartime h (n - 1)) + +mul :: H.Assertion +mul = do + let !n = 2 ^ (256 :: Word) - 1 + H.assertBool mempty (W.eq_vartime (W.mul 0 n) 0) + H.assertBool mempty (W.eq_vartime (W.mul n 0) 0) + H.assertBool mempty (W.eq_vartime (W.mul n n) 1) + H.assertBool mempty (W.eq_vartime (W.mul 1 n) n) + +sub_mod :: H.Assertion +sub_mod = do + let !a = 0x1a2472fde50286541d97ca6a3592dd75beb9c9646e40c511b82496cfc3926956 + !b = 0xd5777c45019673125ad240f83094d4252d829516fac8601ed01979ec1ec1a251 + !n = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551 + !o = W.sub_mod a b n + !e = 0x44acf6b7e36c1342c2c5897204fe09504e1e2efb1a900377dbc4e7a6a133ec56 + H.assertBool mempty (W.eq_vartime o e) + +instance Q.Arbitrary W.Wider where + arbitrary = fmap W.to Q.arbitrary + +odd_correct :: W.Wider -> Bool +odd_correct w = C.decide (W.odd w) == I.integerTestBit (W.from w) 0 + +tests :: TestTree +tests = testGroup "wider tests" [ + H.testCase "overflowing add, no carry" overflowing_add_no_carry + , H.testCase "overflowing add, carry" overflowing_add_with_carry + , H.testCase "wrapping add, no carry" wrapping_add_no_carry + , H.testCase "wrapping add, carry" wrapping_add_with_carry + , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow + , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow + , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow + , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow + , H.testCase "eq" eq + , H.testCase "gt" gt + , H.testCase "lt" lt + , H.testCase "cmp" cmp + , H.testCase "sqr" sqr + , H.testCase "mul" mul + , H.testCase "sub_mod" sub_mod + , Q.testProperty "odd w ~ odd (from w)" $ Q.withMaxSuccess 500 odd_correct + ] +