commit bbe5cf300c2e9ad9238cab2ab243a081f8923bc9
parent 43ca6ac31f3d98bc6c6ab0591a0ca70c1e17ea0f
Author: Jared Tobin <jared@jtobin.io>
Date: Fri, 12 Dec 2025 09:09:22 +0400
lib: add exp for montgomery (and sqrt for curve)
Diffstat:
5 files changed, 100 insertions(+), 16 deletions(-)
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -7,6 +7,7 @@ module Main where
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 [
@@ -15,6 +16,8 @@ main = defaultMain [
, mul
, sqr
, inv
+ , exp
+ , sqrt
, redc
, retr
]
@@ -67,6 +70,20 @@ inv = bgroup "inv" [
, bench "scalar: M(2 ^ 255 - 19) ^ -1" $ nf S.inv (2 ^ 255 - 19)
]
+sqrt :: Benchmark
+sqrt = bgroup "sqrt" [
+ bench "curve: sqrt M(2)" $ nf C.sqrt 2
+ , bench "curve: sqrt M(2 ^ 255 - 19)" $ nf C.sqrt (2 ^ 255 - 19)
+ ]
+
+exp :: Benchmark
+exp = bgroup "exp" [
+ bench "curve: M(2) ^ 2" $ nf C.exp 2
+ , bench "curve: M(2 ^ 255 - 19) ^ 2" $ nf C.exp (2 ^ 255 - 19)
+ , bench "scalar: M(2) ^ 2" $ nf S.exp 2
+ , bench "scalar: M(2 ^ 255 - 19) ^ 2" $ nf S.exp (2 ^ 255 - 19)
+ ]
+
redc :: Benchmark
redc = bgroup "redc" [
bench "curve: REDC(M(2), M(2))" $ nf (C.redc 2) 2
diff --git a/lib/Numeric/Montgomery/Secp256k1/Curve.hs b/lib/Numeric/Montgomery/Secp256k1/Curve.hs
@@ -48,6 +48,7 @@ module Numeric.Montgomery.Secp256k1.Curve (
, inv
, inv#
, sqrt
+ , exp
) where
import Control.DeepSeq
@@ -59,7 +60,7 @@ 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, sqrt)
+import Prelude hiding (div, mod, or, and, not, quot, rem, recip, sqrt, exp)
-- montgomery arithmetic, specialized to the secp256k1 field prime modulus
-- 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F
@@ -991,17 +992,25 @@ inv (Montgomery w) = Montgomery (inv# w)
-- Just 15
sqrt :: Montgomery -> Maybe Montgomery
sqrt n =
- let !e0 = 0x3fffffffffffffffffffffffffffffffffffffffffffffffffffffffbfffff0c
- !rv = loop 1 n e0
- in if C.decide (eq (rv * rv) n)
- then Just $! rv
- else Nothing
- where
- loop !r !m !e@(Wider (# Limb (W# -> w), _, _, _ #)) = case WW.cmp e 0 of
- GT ->
- let !nm = m * m
- !ne = WW.shr1 e
- !nr | B.testBit w 0 = r * m
- | otherwise = r
- in loop nr nm ne
- _ -> r
+ let !e0 = 0x3fffffffffffffffffffffffffffffffffffffffffffffffffffffffbfffff0c
+ !rv = exp n e0
+ in if C.decide (eq (sqr rv) n)
+ then Just $! rv
+ else Nothing
+
+-- | Exponentiation in the Montgomery domain.
+--
+-- >>> exp 2 3
+-- 8
+-- >>> exp 2 10
+-- 1024
+exp :: Montgomery -> Wider -> Montgomery
+exp b = loop 1 b where
+ loop !r !m !e@(Wider (# Limb (W# -> w), _, _, _ #)) = case WW.cmp e 0 of
+ GT ->
+ let !nm = sqr m
+ !ne = WW.shr1 e
+ !nr | B.testBit w 0 = r * m
+ | otherwise = r
+ in loop nr nm ne
+ _ -> r
diff --git a/lib/Numeric/Montgomery/Secp256k1/Scalar.hs b/lib/Numeric/Montgomery/Secp256k1/Scalar.hs
@@ -47,9 +47,11 @@ module Numeric.Montgomery.Secp256k1.Scalar (
, neg#
, inv
, inv#
+ , exp
) where
import Control.DeepSeq
+import qualified Data.Bits as B
import qualified Data.Choice as C
import Data.Word.Limb (Limb(..))
import qualified Data.Word.Limb as L
@@ -57,7 +59,7 @@ 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)
+import Prelude hiding (div, mod, or, and, not, quot, rem, recip, exp)
-- montgomery arithmetic, specialized to the secp256k1 scalar group order
-- 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141
@@ -934,3 +936,19 @@ inv
-> 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 b = loop 1 b where
+ loop !r !m !e@(Wider (# Limb (W# -> w), _, _, _ #)) = case WW.cmp e 0 of
+ GT ->
+ let !nm = sqr m
+ !ne = WW.shr1 e
+ !nr | B.testBit w 0 = r * m
+ | otherwise = r
+ in loop nr nm ne
+ _ -> r
diff --git a/test/Montgomery/Curve.hs b/test/Montgomery/Curve.hs
@@ -3,18 +3,30 @@
{-# 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
@@ -116,6 +128,13 @@ mul_matches a b =
im = W.from m
in W.eq_vartime (W.to ((ia * ib) `mod` im)) (C.from (ma * mb))
+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
@@ -127,6 +146,7 @@ tests = testGroup "montgomery tests (curve)" [
, 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 ^ b mod m ~ ma ^ mb" $ Q.withMaxSuccess 500 exp_matches
, Q.testProperty "n ^ -1 mod m * n ~ 1" $ Q.withMaxSuccess 500 inv_valid
]
diff --git a/test/Montgomery/Scalar.hs b/test/Montgomery/Scalar.hs
@@ -3,18 +3,30 @@
{-# 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
@@ -116,6 +128,13 @@ mul_matches a b =
im = W.from m
in W.eq_vartime (W.to ((ia * ib) `mod` im)) (S.from (ma * mb))
+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
@@ -127,6 +146,7 @@ tests = testGroup "montgomery tests (scalar)" [
, 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 ^ b mod m ~ ma ^ mb" $ Q.withMaxSuccess 500 exp_matches
, Q.testProperty "n ^ -1 mod m * n ~ 1" $ Q.withMaxSuccess 500 inv_valid
]
