ppad-fixed (empty) → 0.1.0
raw patch · 17 files changed
+5539/−0 lines, 17 filesdep +basedep +criteriondep +deepseq
Dependencies added: base, criterion, deepseq, ppad-fixed, tasty, tasty-hunit, tasty-quickcheck, weigh
Files
- CHANGELOG +6/−0
- LICENSE +20/−0
- bench/Main.hs +147/−0
- bench/Weight.hs +153/−0
- lib/Data/Choice.hs +454/−0
- lib/Data/Word/Limb.hs +386/−0
- lib/Data/Word/Wide.hs +246/−0
- lib/Data/Word/Wider.hs +749/−0
- lib/Numeric/Montgomery/Secp256k1/Curve.hs +1573/−0
- lib/Numeric/Montgomery/Secp256k1/Scalar.hs +999/−0
- ppad-fixed.cabal +95/−0
- test/Limb.hs +152/−0
- test/Main.hs +22/−0
- test/Montgomery/Curve.hs +164/−0
- test/Montgomery/Scalar.hs +160/−0
- test/Wide.hs +42/−0
- test/Wider.hs +171/−0
+ CHANGELOG view
@@ -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.+
+ LICENSE view
@@ -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.
+ bench/Main.hs view
@@ -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+ ]
+ bench/Weight.hs view
@@ -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
+ lib/Data/Choice.hs view
@@ -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 <jared@ppad.tech>+--+-- 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# #-}+
+ lib/Data/Word/Limb.hs view
@@ -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 <jared@ppad.tech>+--+-- 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# #-}+
+ lib/Data/Word/Wide.hs view
@@ -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 <jared@ppad.tech>+--+-- 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)+
+ lib/Data/Word/Wider.hs view
@@ -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 <jared@ppad.tech>+--+-- 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+
+ lib/Numeric/Montgomery/Secp256k1/Curve.hs view
@@ -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 <jared@ppad.tech>+--+-- 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)+
+ lib/Numeric/Montgomery/Secp256k1/Scalar.hs view
@@ -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 <jared@ppad.tech>+--+-- 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)+
+ ppad-fixed.cabal view
@@ -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+
+ test/Limb.hs view
@@ -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+ ]+
+ test/Main.hs view
@@ -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+ ]+
+ test/Montgomery/Curve.hs view
@@ -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+ ]+
+ test/Montgomery/Scalar.hs view
@@ -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+ ]+
+ test/Wide.hs view
@@ -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+ ]+
+ test/Wider.hs view
@@ -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+ ]+