commit 47485a53cbe569a40736140c8f3fd9cf7bb3b596
parent 6a3b7c52bc6fb4924b0fe86d5f2bb8019f72b13a
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 30 Nov 2025 23:11:09 +0400
test: initial montgomery skeletons
Diffstat:
8 files changed, 97 insertions(+), 3 deletions(-)
diff --git a/lib/Data/Word/Wider.hs b/lib/Data/Word/Wider.hs
@@ -319,16 +319,23 @@ sub_mod# a b (# p0, p1, p2, p3 #) =
in add_w# (# o0, o1, o2, o3 #) ba
{-# INLINE sub_mod# #-}
+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 -- ^ 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.and# (L.not# (L.neg# c)) bb
+ !(# _, 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# #-}
diff --git a/lib/Numeric/Montgomery/Secp256k1/Curve.hs b/lib/Numeric/Montgomery/Secp256k1/Curve.hs
@@ -34,11 +34,12 @@ data Montgomery = Montgomery !(# Limb, Limb, Limb, Limb #)
instance Show Montgomery where
show = show . from
+-- XX replace with 'eq', remove instance
instance Eq Montgomery where
Montgomery a == Montgomery b =
let !(# Limb a0, Limb a1, Limb a2, Limb a3 #) = a
!(# Limb b0, Limb b1, Limb b2, Limb b3 #) = b
- in C.decide (C.ct_eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #)) -- XX sane?
+ in C.decide (C.ct_eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #))
instance Num Montgomery where
a + b = add a b
diff --git a/lib/Numeric/Montgomery/Secp256k1/Scalar.hs b/lib/Numeric/Montgomery/Secp256k1/Scalar.hs
@@ -24,6 +24,7 @@ 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 (div, mod, or, and, not, quot, rem, recip)
-- montgomery arithmetic, specialized to the secp256k1 scalar group order
@@ -34,6 +35,12 @@ data Montgomery = Montgomery !(# Limb, Limb, Limb, Limb #)
instance Show Montgomery where
show = show . from
+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) <> ")"
+
+-- XX replace with 'eq', remove instance
instance Eq Montgomery where
Montgomery a == Montgomery b =
let !(# Limb a0, Limb a1, Limb a2, Limb a3 #) = a
diff --git a/ppad-fixed.cabal b/ppad-fixed.cabal
@@ -49,6 +49,8 @@ test-suite fixed-tests
Limb
Wide
Wider
+ Montgomery.Curve
+ Montgomery.Scalar
ghc-options:
-rtsopts -Wall -O2
diff --git a/test/Main.hs b/test/Main.hs
@@ -4,6 +4,8 @@
module Main where
+import qualified Montgomery.Curve as Curve
+import qualified Montgomery.Scalar as Scalar
import qualified Limb
import qualified Wide
import qualified Wider
@@ -14,5 +16,7 @@ main = defaultMain $ testGroup "ppad-fixed" [
Limb.tests
, Wide.tests
, Wider.tests
+ , Curve.tests
+ , Scalar.tests
]
diff --git a/test/Montgomery/Curve.hs b/test/Montgomery/Curve.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Montgomery.Curve (
+ tests
+ ) where
+
+import qualified Data.Word.Wider as W
+import qualified Numeric.Montgomery.Secp256k1.Curve as C
+import Test.Tasty
+import qualified Test.Tasty.HUnit as H
+
+add :: H.Assertion
+add = do
+ H.assertBool mempty (W.eq_vartime (1 + 1) (C.from (1 + 1)))
+ H.assertBool mempty (W.eq_vartime (0 + 1) (C.from (0 + 1)))
+ let !m = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F
+ !x = 2 ^ (256 :: Word) - 1
+ !mm = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F
+ !mx = 2 ^ (256 :: Word) - 1
+ H.assertBool mempty (W.eq_vartime 0 (C.from mm))
+ H.assertBool mempty (W.eq_vartime (x - m) (C.from (mx - mm)))
+
+tests :: TestTree
+tests = testGroup "montgomery tests (curve)" [
+ H.testCase "add" add
+ ]
+
diff --git a/test/Montgomery/Scalar.hs b/test/Montgomery/Scalar.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Montgomery.Scalar (
+ tests
+ ) where
+
+import qualified Data.Word.Wider as W
+import qualified Numeric.Montgomery.Secp256k1.Scalar as S
+import Test.Tasty
+import qualified Test.Tasty.HUnit as H
+
+-- modulus :: S.Montgomery
+-- modulus = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141
+
+add :: H.Assertion
+add = do
+ H.assertBool mempty (W.eq_vartime (1 + 1) (S.from (1 + 1)))
+ H.assertBool mempty (W.eq_vartime (0 + 1) (S.from (0 + 1)))
+ let !m = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141
+ !x = 2 ^ (256 :: Word) - 1
+ !mm = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141
+ !mx = 2 ^ (256 :: Word) - 1
+ H.assertBool mempty (W.eq_vartime 0 (S.from mm))
+ H.assertBool mempty (W.eq_vartime (x - m) (S.from (mx - mm)))
+
+tests :: TestTree
+tests = testGroup "montgomery tests (scalar)" [
+ H.testCase "add" add
+ ]
+
diff --git a/test/Wider.hs b/test/Wider.hs
@@ -131,6 +131,15 @@ mul = do
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)
+
tests :: TestTree
tests = testGroup "wider tests" [
H.testCase "overflowing add, no carry" overflowing_add_no_carry
@@ -147,5 +156,6 @@ tests = testGroup "wider tests" [
, H.testCase "cmp" cmp
, H.testCase "sqr" sqr
, H.testCase "mul" mul
+ , H.testCase "sub_mod" sub_mod
]
