commit 92adba2d27185cb2d719b73e95398b0ae739b5d6
parent 3531be4d01b2d343b5ebe08f40a1243cc05f6e16
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 21 Dec 2025 17:38:58 -0330
Merge branch 'unboxed'
Diffstat:
12 files changed, 1410 insertions(+), 413 deletions(-)
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -27,9 +27,11 @@ main :: IO ()
main = defaultMain [
parse_point
, add
+ , double
, mul
- , precompute
+ , mul_vartime
, mul_wnaf
+ , precompute
, derive_pub
, schnorr
, ecdsa
@@ -67,13 +69,23 @@ mul_fixed = bgroup "mul_fixed" [
]
add :: Benchmark
-add = bgroup "add" [
- bench "2 p (double, trivial projective point)" $ nf (S.add p) p
- , bench "2 r (double, nontrivial projective point)" $ nf (S.add r) r
- , bench "p + q (trivial projective points)" $ nf (S.add p) q
- , bench "p + s (nontrivial mixed points)" $ nf (S.add p) s
- , bench "s + r (nontrivial projective points)" $ nf (S.add s) r
- ]
+add = env setup $ \ ~(!pl, !ql, !rl, !sl) ->
+ bgroup "add" [
+ bench "p + q (trivial projective points)" $ nf (S.add pl) ql
+ , bench "p + s (nontrivial mixed points)" $ nf (S.add pl) sl
+ , bench "s + r (nontrivial projective points)" $ nf (S.add sl) rl
+ ]
+ where
+ setup = pure (p, q, r, s)
+
+double :: Benchmark
+double = env setup $ \ ~(!pl, !rl) ->
+ bgroup "double" [
+ bench "2 p (double, trivial projective point)" $ nf (S.add pl) pl
+ , bench "2 r (double, nontrivial projective point)" $ nf (S.add rl) rl
+ ]
+ where
+ setup = pure (p, r)
mul :: Benchmark
mul = env setup $ \x ->
@@ -85,6 +97,16 @@ mul = env setup $ \x ->
setup = pure . parse_int256 $ decodeLenient
"7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"
+mul_vartime :: Benchmark
+mul_vartime = env setup $ \x ->
+ bgroup "mul_vartime" [
+ bench "2 G" $ nf (S.mul_vartime S._CURVE_G) 2
+ , bench "(2 ^ 255 - 19) G" $ nf (S.mul_vartime S._CURVE_G) x
+ ]
+ where
+ setup = pure . parse_int256 $ decodeLenient
+ "7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed"
+
precompute :: Benchmark
precompute = bench "precompute" $ nfIO (pure S.precompute)
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -2,12 +2,11 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
--- XX need to make sure arguments aren't allocating in the benchmarks
-
module Main where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
+import Data.Maybe (fromJust)
import Data.Word.Wider (Wider(..))
import Control.DeepSeq
import qualified Crypto.Curve.Secp256k1 as S
@@ -28,22 +27,28 @@ parse_int bs = case S.parse_int256 bs of
Nothing -> error "bang"
Just v -> v
-big :: Wider
-big = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
-
-- note that 'weigh' doesn't work properly in a repl
main :: IO ()
main = W.mainWith $ do
parse_int256
+ ge
add
+ double
mul
- mul_unsafe
mul_wnaf
derive_pub
schnorr
ecdsa
ecdh
+ge :: W.Weigh ()
+ge =
+ let !t = 2
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+ in W.wgroup "ge" $ do
+ W.func' "small" S.ge t
+ W.func' "large" S.ge b
+
parse_int256 :: W.Weigh ()
parse_int256 =
let !a = BS.replicate 32 0x00
@@ -54,156 +59,104 @@ parse_int256 =
add :: W.Weigh ()
add =
- let !pl = p
- !rl = r
- !ql = q
- !sl = s
- in W.wgroup " add" $ do
- W.func "2 p (double, trivial projective point)" (S.add pl) pl
- W.func "2 r (double, nontrivial projective point)" (S.add rl) rl
- W.func "p + q (trivial projective points)" (S.add pl) ql
- W.func "p + s (nontrivial mixed points)" (S.add pl) sl
- W.func "s + r (nontrivial projective points)" (S.add sl) rl
+ let !p = fromJust . S.parse_point . decodeLenient $
+ "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
+ !r = fromJust . S.parse_point . decodeLenient $
+ "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8"
+ !q = fromJust . S.parse_point . decodeLenient $
+ "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9"
+ !s = fromJust . S.parse_point . decodeLenient $
+ "0306413898a49c93cccf3db6e9078c1b6a8e62568e4a4770e0d7d96792d1c580ad"
+ in W.wgroup "add" $ do
+ W.func' "p + q (trivial projective points)" (S.add p) q
+ W.func' "s + p (nontrivial mixed points)" (S.add s) p
+ W.func' "r + s (nontrivial projective points)" (S.add r) s
+
+double :: W.Weigh ()
+double =
+ let !p = fromJust . S.parse_point . decodeLenient $
+ "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
+ !r = fromJust . S.parse_point . decodeLenient $
+ "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8"
+ in W.wgroup "double" $ do
+ W.func' "2 p (double, trivial projective point)" S.double p
+ W.func' "2 r (double, nontrivial projective point)" S.double r
mul :: W.Weigh ()
mul =
let !g = S._CURVE_G
!t = 2
- !bigl = big
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
in W.wgroup "mul" $ do
- W.func "2 G" (S.mul g) t
- W.func "(2 ^ 255 - 19) G" (S.mul g) bigl
-
-mul_unsafe :: W.Weigh ()
-mul_unsafe =
- let !g = S._CURVE_G
- !t = 2
- !bigl = big
- in W.wgroup "mul_unsafe" $ do
- W.func "2 G" (S.mul_unsafe g) t
- W.func "(2 ^ 255 - 19) G" (S.mul_unsafe g) bigl
+ W.func' "2 G" (S.mul g) t
+ W.func' "(2 ^ 255 - 19) G" (S.mul g) b
mul_wnaf :: W.Weigh ()
mul_wnaf =
let !t = 2
- !bigl = big
- !con = S._precompute 8
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+ !con = S.precompute
in W.wgroup "mul_wnaf" $ do
- W.func "precompute" S._precompute (8 :: Int)
- W.func "2 G" (S.mul_wnaf con) t
- W.func "(2 ^ 255 - 19) G" (S.mul_wnaf con) bigl
+ W.func' "precompute" S._precompute (8 :: Int)
+ W.func' "2 G" (S.mul_wnaf con) t
+ W.func' "(2 ^ 255 - 19) G" (S.mul_wnaf con) b
derive_pub :: W.Weigh ()
derive_pub =
let !t = 2
- !bigl = big
- !con = S._precompute 8
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+ !con = S.precompute
in W.wgroup "derive_pub" $ do
- W.func "sk = 2" S.derive_pub t
- W.func "sk = 2 ^ 255 - 19" S.derive_pub bigl
- W.func "wnaf, sk = 2" (S.derive_pub' con) t
- W.func "wnaf, sk = 2 ^ 255 - 19" (S.derive_pub' con) bigl
+ W.func' "sk = 2" S.derive_pub t
+ W.func' "sk = 2 ^ 255 - 19" S.derive_pub b
+ W.func' "wnaf, sk = 2" (S.derive_pub' con) t
+ W.func' "wnaf, sk = 2 ^ 255 - 19" (S.derive_pub' con) b
schnorr :: W.Weigh ()
schnorr =
let !t = 2
- !s_msgl = s_msg
- !s_auxl = s_aux
- !s_sigl = s_sig
- !s_pkl = s_pk
- !con = S._precompute 8
- !bigl = big
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+ !con = S.precompute
+ !s_msg = decodeLenient
+ "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89"
+ !s_aux = decodeLenient
+ "0000000000000000000000000000000000000000000000000000000000000001"
+ !s_sig = decodeLenient
+ "6896BD60EEAE296DB48A229FF71DFE071BDE413E6D43F917DC8DCF8C78DE33418906D11AC976ABCCB20B091292BFF4EA897EFCB639EA871CFA95F6DE339E4B0A"
+ !(Just !s_pk) = S.parse_point . decodeLenient $
+ "DFF1D77F2A671C5F36183726DB2341BE58FEAE1DA2DECED843240F7B502BA659"
in W.wgroup "schnorr" $ do
- W.func "sign_schnorr (small)" (S.sign_schnorr t s_msgl) s_auxl
- W.func "sign_schnorr (large)" (S.sign_schnorr bigl s_msgl) s_auxl
- W.func "sign_schnorr' (small)" (S.sign_schnorr' con t s_msgl) s_auxl
- W.func "sign_schnorr' (large)" (S.sign_schnorr' con big s_msgl) s_auxl
- W.func "verify_schnorr" (S.verify_schnorr s_msgl s_pkl) s_sigl
- W.func "verify_schnorr'" (S.verify_schnorr' con s_msgl s_pkl) s_sigl
+ W.func "sign_schnorr (small)" (S.sign_schnorr t s_msg) s_aux
+ W.func "sign_schnorr (large)" (S.sign_schnorr b s_msg) s_aux
+ W.func "sign_schnorr' (small)" (S.sign_schnorr' con t s_msg) s_aux
+ W.func "sign_schnorr' (large)" (S.sign_schnorr' con b s_msg) s_aux
+ W.func "verify_schnorr" (S.verify_schnorr s_msg s_pk) s_sig
+ W.func "verify_schnorr'" (S.verify_schnorr' con s_msg s_pk) s_sig
ecdsa :: W.Weigh ()
ecdsa =
let !t = 2
- !s_msgl = s_msg
- !con = S._precompute 8
- !bigl = big
- !msg = "i approve of this message"
- Just !pub = S.derive_pub bigl
- Just !sig = S.sign_ecdsa bigl s_msgl
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+ !con = S.precompute
+ !msg = "i approve of this message"
+ !s_msg = decodeLenient
+ "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89"
+ !(Just !pub) = S.derive_pub b
+ !(Just !sig) = S.sign_ecdsa b s_msg
in W.wgroup "ecdsa" $ do
- W.func "sign_ecdsa (small)" (S.sign_ecdsa t) s_msgl
- W.func "sign_ecdsa (large)" (S.sign_ecdsa bigl) s_msgl
- W.func "sign_ecdsa' (small)" (S.sign_ecdsa' con t) s_msgl
- W.func "sign_ecdsa' (large)" (S.sign_ecdsa' con bigl) s_msgl
+ W.func "sign_ecdsa (small)" (S.sign_ecdsa t) s_msg
+ W.func "sign_ecdsa (large)" (S.sign_ecdsa b) s_msg
+ W.func "sign_ecdsa' (small)" (S.sign_ecdsa' con t) s_msg
+ W.func "sign_ecdsa' (large)" (S.sign_ecdsa' con b) s_msg
W.func "verify_ecdsa" (S.verify_ecdsa msg pub) sig
W.func "verify_ecdsa'" (S.verify_ecdsa' con msg pub) sig
ecdh :: W.Weigh ()
-ecdh = W.wgroup "ecdh" $ do
- W.func "ecdh (small)" (S.ecdh pub) 2
- W.func "ecdh (large)" (S.ecdh pub) b
- where
- !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- Just !pub = S.parse_point . decodeLenient $
- "bd02b9dfc8ef760708950bd972f2dc244893b61b6b46c3b19be1b2da7b034ac5"
-
-s_sk :: Wider
-s_sk = parse_int . decodeLenient $
- "B7E151628AED2A6ABF7158809CF4F3C762E7160F38B4DA56A784D9045190CFEF"
-
-s_sig :: BS.ByteString
-s_sig = decodeLenient "6896BD60EEAE296DB48A229FF71DFE071BDE413E6D43F917DC8DCF8C78DE33418906D11AC976ABCCB20B091292BFF4EA897EFCB639EA871CFA95F6DE339E4B0A"
-
-s_pk_raw :: BS.ByteString
-s_pk_raw = decodeLenient
- "DFF1D77F2A671C5F36183726DB2341BE58FEAE1DA2DECED843240F7B502BA659"
-
-s_pk :: S.Projective
-s_pk = case S.parse_point s_pk_raw of
- Nothing -> error "bang"
- Just !pt -> pt
-
-s_msg :: BS.ByteString
-s_msg = decodeLenient
- "243F6A8885A308D313198A2E03707344A4093822299F31D0082EFA98EC4E6C89"
-
-s_aux :: BS.ByteString
-s_aux = decodeLenient
- "0000000000000000000000000000000000000000000000000000000000000001"
-
-p_bs :: BS.ByteString
-p_bs = decodeLenient
- "0279be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
-
-p :: S.Projective
-p = case S.parse_point p_bs of
- Nothing -> error "bang"
- Just !pt -> pt
-
-q_bs :: BS.ByteString
-q_bs = decodeLenient
- "02f9308a019258c31049344f85f89d5229b531c845836f99b08601f113bce036f9"
-
-q :: S.Projective
-q = case S.parse_point q_bs of
- Nothing -> error "bang"
- Just !pt -> pt
-
-r_bs :: BS.ByteString
-r_bs = decodeLenient
- "03a2113cf152585d96791a42cdd78782757fbfb5c6b2c11b59857eb4f7fda0b0e8"
-
-r :: S.Projective
-r = case S.parse_point r_bs of
- Nothing -> error "bang"
- Just !pt -> pt
-
-s_bs :: BS.ByteString
-s_bs = decodeLenient
- "0306413898a49c93cccf3db6e9078c1b6a8e62568e4a4770e0d7d96792d1c580ad"
-
-s :: S.Projective
-s = case S.parse_point s_bs of
- Nothing -> error "bang"
- Just !pt -> pt
+ecdh =
+ let !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+ !(Just !pub) = S.parse_point . decodeLenient $
+ "bd02b9dfc8ef760708950bd972f2dc244893b61b6b46c3b19be1b2da7b034ac5"
+ in W.wgroup "ecdh" $ do
+ W.func "ecdh (small)" (S.ecdh pub) 2
+ W.func "ecdh (large)" (S.ecdh pub) b
diff --git a/flake.lock b/flake.lock
@@ -184,11 +184,11 @@
]
},
"locked": {
- "lastModified": 1766269174,
- "narHash": "sha256-vgg86sfxwxc1dmeajNCPvlzZl24+aNFKxCX3+DdAXfA=",
+ "lastModified": 1766351184,
+ "narHash": "sha256-+fXHSabk0hjARotjB65uPRktAlvbH02orI/SNyyBub0=",
"ref": "master",
- "rev": "a9d4855bedf548913fcfe1e4eaf6e5dca540f524",
- "revCount": 249,
+ "rev": "497ffce0197e28b28e7534a278d52002accfd5b9",
+ "revCount": 251,
"type": "git",
"url": "git://git.ppad.tech/fixed.git"
},
diff --git a/lib/Crypto/Curve/Secp256k1.hs b/lib/Crypto/Curve/Secp256k1.hs
@@ -27,7 +27,6 @@ module Crypto.Curve.Secp256k1 (
-- * Field and group parameters
_CURVE_Q
, _CURVE_P
- , modQ
-- * secp256k1 points
, Pub
@@ -35,6 +34,8 @@ module Crypto.Curve.Secp256k1 (
, derive_pub'
, _CURVE_G
, _CURVE_ZERO
+ , ge
+ , fe
-- * Parsing
, parse_int256
@@ -72,9 +73,11 @@ module Crypto.Curve.Secp256k1 (
-- Elliptic curve group operations
, neg
, add
+ , add_mixed
+ , add_proj
, double
, mul
- , mul_unsafe
+ , mul_vartime
, mul_wnaf
-- Coordinate systems and transformations
@@ -91,21 +94,21 @@ module Crypto.Curve.Secp256k1 (
, roll32
, unsafe_roll32
, unroll32
+ , select_proj
) where
import Control.Monad (guard)
import Control.Monad.ST
import qualified Crypto.DRBG.HMAC as DRBG
import qualified Crypto.Hash.SHA256 as SHA256
-import Data.Bits ((.&.))
import qualified Data.Bits as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
import qualified Data.Choice as CT
import qualified Data.Maybe as M
-import qualified Data.Primitive.Array as A
-import Data.STRef
+import Data.Primitive.ByteArray (ByteArray(..), MutableByteArray(..))
+import qualified Data.Primitive.ByteArray as BA
import Data.Word (Word8)
import Data.Word.Limb (Limb(..))
import qualified Data.Word.Limb as L
@@ -114,25 +117,36 @@ import qualified Data.Word.Wider as W
import qualified Foreign.Storable as Storable (pokeByteOff)
import qualified GHC.Exts as Exts
import GHC.Generics
-import qualified GHC.Int (Int(..))
import qualified GHC.Word (Word(..), Word8(..))
import qualified Numeric.Montgomery.Secp256k1.Curve as C
import qualified Numeric.Montgomery.Secp256k1.Scalar as S
import Prelude hiding (sqrt)
+-- convenience synonyms -------------------------------------------------------
+
+-- Unboxed Wider/Montgomery synonym.
+type Limb4 = (# Limb, Limb, Limb, Limb #)
+
+-- Unboxed Projective synonym.
+type Proj = (# Limb4, Limb4, Limb4 #)
+
+pattern Zero :: Wider
+pattern Zero = Wider Z
+
+pattern Z :: Limb4
+pattern Z = (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #)
+
+pattern P :: Limb4 -> Limb4 -> Limb4 -> Projective
+pattern P x y z =
+ Projective (C.Montgomery x) (C.Montgomery y) (C.Montgomery z)
+{-# COMPLETE P #-}
+
-- utilities ------------------------------------------------------------------
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
{-# INLINE fi #-}
--- dumb strict pair
-data Pair a b = Pair !a !b
-
--- convenience pattern
-pattern Zero :: Wider
-pattern Zero = Wider (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #)
-
-- convert a Word8 to a Limb
limb :: Word8 -> Limb
limb (GHC.Word.W8# (Exts.word8ToWord# -> w)) = Limb w
@@ -155,10 +169,6 @@ word8_to_wider :: Word8 -> Wider
word8_to_wider w = Wider (# limb w, Limb 0##, Limb 0##, Limb 0## #)
{-# INLINABLE word8_to_wider #-}
-wider_to_int :: Wider -> Int
-wider_to_int (Wider (# Limb l, _, _, _ #)) = GHC.Int.I# (Exts.word2Int# l)
-{-# INLINABLE wider_to_int #-}
-
-- unsafely extract the first 64-bit word from a big-endian-encoded bytestring
unsafe_word0 :: BS.ByteString -> Limb
unsafe_word0 bs =
@@ -281,6 +291,7 @@ modQ = S.from . S.to
-- bytewise xor
xor :: BS.ByteString -> BS.ByteString -> BS.ByteString
xor = BS.packZipWith B.xor
+{-# INLINABLE xor #-}
-- constants ------------------------------------------------------------------
@@ -327,7 +338,7 @@ fe n = n > 0 && n < _CURVE_P
-- Is group element?
ge :: Wider -> Bool
-ge n = n > 0 && n < _CURVE_Q
+ge (Wider n) = CT.decide (ge# n)
{-# INLINE ge #-}
-- curve points ---------------------------------------------------------------
@@ -357,12 +368,9 @@ type Pub = Projective
-- Convert to affine coordinates.
affine :: Projective -> Affine
-affine = \case
- Projective 0 1 0 -> Affine 0 0
- Projective x y 1 -> Affine x y
- Projective x y z ->
- let !iz = C.inv z
- in Affine (x * iz) (y * iz)
+affine (Projective x y z) =
+ let !iz = C.inv z
+ in Affine (x * iz) (y * iz)
{-# INLINABLE affine #-}
-- Convert to projective coordinates.
@@ -373,13 +381,15 @@ projective = \case
-- | secp256k1 generator point.
_CURVE_G :: Projective
-_CURVE_G = Projective x y C.one where
+_CURVE_G = Projective x y z where
!x = C.Montgomery
(# Limb 15507633332195041431##, Limb 2530505477788034779##
, Limb 10925531211367256732##, Limb 11061375339145502536## #)
!y = C.Montgomery
(# Limb 12780836216951778274##, Limb 10231155108014310989##
, Limb 8121878653926228278##, Limb 14933801261141951190## #)
+ !z = C.Montgomery
+ (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #)
-- | secp256k1 zero point, point at infinity, or monoidal identity.
_CURVE_ZERO :: Projective
@@ -424,215 +434,261 @@ lift_vartime x = do
even_y_vartime :: Projective -> Projective
even_y_vartime p = case affine p of
Affine _ (C.retr -> y)
- | CT.decide (W.odd y) -> neg p -- XX
+ | CT.decide (W.odd y) -> neg p
| otherwise -> p
+-- Constant-time selection of Projective points.
+select_proj :: Projective -> Projective -> CT.Choice -> Projective
+select_proj (P ax ay az) (P bx by bz) c =
+ P (W.select# ax bx c) (W.select# ay by c) (W.select# az bz c)
+{-# INLINE select_proj #-}
+
+-- unboxed internals ----------------------------------------------------------
+
+-- algo 7, renes et al, 2015
+add_proj# :: Proj -> Proj -> Proj
+add_proj# (# x1, y1, z1 #) (# x2, y2, z2 #) =
+ let !(C.Montgomery b3) = _CURVE_Bm3
+ !t0a = C.mul# x1 x2
+ !t1a = C.mul# y1 y2
+ !t2a = C.mul# z1 z2
+ !t3a = C.add# x1 y1
+ !t4a = C.add# x2 y2
+ !t3b = C.mul# t3a t4a
+ !t4b = C.add# t0a t1a
+ !t3c = C.sub# t3b t4b
+ !t4c = C.add# y1 z1
+ !x3a = C.add# y2 z2
+ !t4d = C.mul# t4c x3a
+ !x3b = C.add# t1a t2a
+ !t4e = C.sub# t4d x3b
+ !x3c = C.add# x1 z1
+ !y3a = C.add# x2 z2
+ !x3d = C.mul# x3c y3a
+ !y3b = C.add# t0a t2a
+ !y3c = C.sub# x3d y3b
+ !x3e = C.add# t0a t0a
+ !t0b = C.add# x3e t0a
+ !t2b = C.mul# b3 t2a
+ !z3a = C.add# t1a t2b
+ !t1b = C.sub# t1a t2b
+ !y3d = C.mul# b3 y3c
+ !x3f = C.mul# t4e y3d
+ !t2c = C.mul# t3c t1b
+ !x3g = C.sub# t2c x3f
+ !y3e = C.mul# y3d t0b
+ !t1c = C.mul# t1b z3a
+ !y3f = C.add# t1c y3e
+ !t0c = C.mul# t0b t3c
+ !z3b = C.mul# z3a t4e
+ !z3c = C.add# z3b t0c
+ in (# x3g, y3f, z3c #)
+{-# INLINE add_proj# #-}
+
+-- algo 8, renes et al, 2015
+add_mixed# :: Proj -> Proj -> Proj
+add_mixed# (# x1, y1, z1 #) (# x2, y2, _z2 #) =
+ let !(C.Montgomery b3) = _CURVE_Bm3
+ !t0a = C.mul# x1 x2
+ !t1a = C.mul# y1 y2
+ !t3a = C.add# x2 y2
+ !t4a = C.add# x1 y1
+ !t3b = C.mul# t3a t4a
+ !t4b = C.add# t0a t1a
+ !t3c = C.sub# t3b t4b
+ !t4c = C.mul# y2 z1
+ !t4d = C.add# t4c y1
+ !y3a = C.mul# x2 z1
+ !y3b = C.add# y3a x1
+ !x3a = C.add# t0a t0a
+ !t0b = C.add# x3a t0a
+ !t2a = C.mul# b3 z1
+ !z3a = C.add# t1a t2a
+ !t1b = C.sub# t1a t2a
+ !y3c = C.mul# b3 y3b
+ !x3b = C.mul# t4d y3c
+ !t2b = C.mul# t3c t1b
+ !x3c = C.sub# t2b x3b
+ !y3d = C.mul# y3c t0b
+ !t1c = C.mul# t1b z3a
+ !y3e = C.add# t1c y3d
+ !t0c = C.mul# t0b t3c
+ !z3b = C.mul# z3a t4d
+ !z3c = C.add# z3b t0c
+ in (# x3c, y3e, z3c #)
+{-# INLINE add_mixed# #-}
+
+-- algo 9, renes et al, 2015
+double# :: Proj -> Proj
+double# (# x, y, z #) =
+ let !(C.Montgomery b3) = _CURVE_Bm3
+ !t0 = C.sqr# y
+ !z3a = C.add# t0 t0
+ !z3b = C.add# z3a z3a
+ !z3c = C.add# z3b z3b
+ !t1 = C.mul# y z
+ !t2a = C.sqr# z
+ !t2b = C.mul# b3 t2a
+ !x3a = C.mul# t2b z3c
+ !y3a = C.add# t0 t2b
+ !z3d = C.mul# t1 z3c
+ !t1b = C.add# t2b t2b
+ !t2c = C.add# t1b t2b
+ !t0b = C.sub# t0 t2c
+ !y3b = C.mul# t0b y3a
+ !y3c = C.add# x3a y3b
+ !t1c = C.mul# x y
+ !x3b = C.mul# t0b t1c
+ !x3c = C.add# x3b x3b
+ in (# x3c, y3c, z3d #)
+{-# INLINE double# #-}
+
+select_proj# :: Proj -> Proj -> CT.Choice -> Proj
+select_proj# (# ax, ay, az #) (# bx, by, bz #) c =
+ (# W.select# ax bx c, W.select# ay by c, W.select# az bz c #)
+{-# INLINE select_proj# #-}
+
+neg# :: Proj -> Proj
+neg# (# x, y, z #) = (# x, C.neg# y, z #)
+{-# INLINE neg# #-}
+
+mul# :: Proj -> Limb4 -> (# () | Proj #)
+mul# (# px, py, pz #) s
+ | CT.decide (CT.not# (ge# s)) = (# () | #)
+ | otherwise =
+ let !(P gx gy gz) = _CURVE_G
+ !(C.Montgomery o) = C.one
+ in loop (0 :: Int) (# Z, o, Z #) (# gx, gy, gz #) (# px, py, pz #) s
+ where
+ loop !j !a !f !d !_SECRET
+ | j == _CURVE_Q_BITS = (# | a #)
+ | otherwise =
+ let !nd = double# d
+ !(# nm, lsb_set #) = W.shr1_c# _SECRET
+ !nacc = select_proj# a (add_proj# a d) lsb_set
+ !nf = select_proj# (add_proj# f d) f lsb_set
+ in loop (succ j) nacc nf nd nm
+{-# INLINE mul# #-}
+
+ge# :: Limb4 -> CT.Choice
+ge# n =
+ let !(Wider q) = _CURVE_Q
+ in CT.and# (W.gt# n Z) (W.lt# n q)
+{-# INLINE ge# #-}
+
+mul_wnaf# :: ByteArray -> Int -> Limb4 -> (# () | Proj #)
+mul_wnaf# ctxArray ctxW ls
+ | CT.decide (CT.not# (ge# ls)) = (# () | #)
+ | otherwise =
+ let !(P zx zy zz) = _CURVE_ZERO
+ !(P gx gy gz) = _CURVE_G
+ in (# | loop 0 (# zx, zy, zz #) (# gx, gy, gz #) ls #)
+ where
+ !one = (# Limb 1##, Limb 0##, Limb 0##, Limb 0## #)
+ !wins = fi (256 `quot` ctxW + 1)
+ !size@(GHC.Word.W# s) = 2 ^ (ctxW - 1)
+ !(GHC.Word.W# mask) = 2 ^ ctxW - 1
+ !(GHC.Word.W# texW) = fi ctxW
+ !(GHC.Word.W# mnum) = 2 ^ ctxW
+
+ loop !j@(GHC.Word.W# w) !acc !f !n@(# Limb lo, _, _, _ #)
+ | j == wins = acc
+ | otherwise =
+ let !(GHC.Word.W# off0) = j * size
+ !b0 = Exts.and# lo mask
+ !bor = CT.from_word_gt# b0 s
+
+ !(# n0, _ #) = W.shr_limb# n (Exts.word2Int# texW)
+ !n0_plus_1 = W.add_w# n0 one
+ !n1 = W.select# n0 n0_plus_1 bor
+
+ !abs_b = CT.select_word# b0 (Exts.minusWord# mnum b0) bor
+ !is_zero = CT.from_word_eq# b0 0##
+ !c0 = CT.from_word# (Exts.and# w 1##)
+ !off_nz = Exts.minusWord# (Exts.plusWord# off0 abs_b) 1##
+ !off = CT.select_word# off0 off_nz (CT.not# is_zero)
+
+ !pr = index_proj# ctxArray (Exts.word2Int# off)
+ !neg_pr = neg# pr
+ !pt_zero = select_proj# pr neg_pr c0
+ !pt_nonzero = select_proj# pr neg_pr bor
+
+ !f_added = add_proj# f pt_zero
+ !acc_added = add_proj# acc pt_nonzero
+ !nacc = select_proj# acc_added acc is_zero
+ !nf = select_proj# f f_added is_zero
+ in loop (succ j) nacc nf n1
+{-# INLINE mul_wnaf# #-}
+
+-- retrieve a point (as an unboxed tuple) from a context array
+index_proj# :: ByteArray -> Exts.Int# -> Proj
+index_proj# (ByteArray arr#) i# =
+ let !base# = i# Exts.*# 12#
+ !x = (# Limb (Exts.indexWordArray# arr# base#)
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 01#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 02#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 03#)) #)
+ !y = (# Limb (Exts.indexWordArray# arr# (base# Exts.+# 04#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 05#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 06#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 07#)) #)
+ !z = (# Limb (Exts.indexWordArray# arr# (base# Exts.+# 08#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 09#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 10#))
+ , Limb (Exts.indexWordArray# arr# (base# Exts.+# 11#)) #)
+ in (# x, y, z #)
+{-# INLINE index_proj# #-}
+
-- ec arithmetic --------------------------------------------------------------
-- Negate secp256k1 point.
neg :: Projective -> Projective
-neg (Projective x y z) = Projective x (negate y) z
-
--- Constant-time selection of Projective points.
-select_proj :: Projective -> Projective -> CT.Choice -> Projective
-select_proj (Projective ax ay az) (Projective bx by bz) c =
- Projective (C.select ax bx c) (C.select ay by c) (C.select az bz c)
-{-# INLINE select_proj #-}
+neg (P x y z) =
+ let !(# px, py, pz #) = neg# (# x, y, z #)
+ in P px py pz
+{-# INLINABLE neg #-}
-- Elliptic curve addition on secp256k1.
add :: Projective -> Projective -> Projective
-add p q@(Projective _ _ z)
- | z == 1 = add_mixed p q -- algo 8
- | otherwise = add_proj p q -- algo 7
+add p q = add_proj p q
+{-# INLINABLE add #-}
-- algo 7, "complete addition formulas for prime order elliptic curves,"
-- renes et al, 2015
--
-- https://eprint.iacr.org/2015/1060.pdf
add_proj :: Projective -> Projective -> Projective
-add_proj (Projective x1 y1 z1) (Projective x2 y2 z2) = runST $ do
- x3 <- newSTRef 0
- y3 <- newSTRef 0
- z3 <- newSTRef 0
- t0 <- newSTRef (x1 * x2) -- 1
- t1 <- newSTRef (y1 * y2)
- t2 <- newSTRef (z1 * z2)
- t3 <- newSTRef (x1 + y1) -- 4
- t4 <- newSTRef (x2 + y2)
- readSTRef t4 >>= \r4 ->
- modifySTRef' t3 (\r3 -> r3 * r4)
- readSTRef t0 >>= \r0 ->
- readSTRef t1 >>= \r1 ->
- writeSTRef t4 (r0 + r1)
- readSTRef t4 >>= \r4 ->
- modifySTRef' t3 (\r3 -> r3 - r4) -- 8
- writeSTRef t4 (y1 + z1)
- writeSTRef x3 (y2 + z2)
- readSTRef x3 >>= \rx3 ->
- modifySTRef' t4 (\r4 -> r4 * rx3)
- readSTRef t1 >>= \r1 ->
- readSTRef t2 >>= \r2 ->
- writeSTRef x3 (r1 + r2) -- 12
- readSTRef x3 >>= \rx3 ->
- modifySTRef' t4 (\r4 -> r4 - rx3)
- writeSTRef x3 (x1 + z1)
- writeSTRef y3 (x2 + z2)
- readSTRef y3 >>= \ry3 ->
- modifySTRef' x3 (\rx3 -> rx3 * ry3) -- 16
- readSTRef t0 >>= \r0 ->
- readSTRef t2 >>= \r2 ->
- writeSTRef y3 (r0 + r2)
- readSTRef x3 >>= \rx3 ->
- modifySTRef' y3 (\ry3 -> rx3 - ry3)
- readSTRef t0 >>= \r0 ->
- writeSTRef x3 (r0 + r0)
- readSTRef x3 >>= \rx3 ->
- modifySTRef t0 (\r0 -> rx3 + r0) -- 20
- modifySTRef' t2 (\r2 -> _CURVE_Bm3 * r2)
- readSTRef t1 >>= \r1 ->
- readSTRef t2 >>= \r2 ->
- writeSTRef z3 (r1 + r2)
- readSTRef t2 >>= \r2 ->
- modifySTRef' t1 (\r1 -> r1 - r2)
- modifySTRef' y3 (\ry3 -> _CURVE_Bm3 * ry3) -- 24
- readSTRef t4 >>= \r4 ->
- readSTRef y3 >>= \ry3 ->
- writeSTRef x3 (r4 * ry3)
- readSTRef t3 >>= \r3 ->
- readSTRef t1 >>= \r1 ->
- writeSTRef t2 (r3 * r1)
- readSTRef t2 >>= \r2 ->
- modifySTRef' x3 (\rx3 -> r2 - rx3)
- readSTRef t0 >>= \r0 ->
- modifySTRef' y3 (\ry3 -> ry3 * r0) -- 28
- readSTRef z3 >>= \rz3 ->
- modifySTRef' t1 (\r1 -> r1 * rz3)
- readSTRef t1 >>= \r1 ->
- modifySTRef' y3 (\ry3 -> r1 + ry3)
- readSTRef t3 >>= \r3 ->
- modifySTRef' t0 (\r0 -> r0 * r3)
- readSTRef t4 >>= \r4 ->
- modifySTRef' z3 (\rz3 -> rz3 * r4) -- 32
- readSTRef t0 >>= \r0 ->
- modifySTRef' z3 (\rz3 -> rz3 + r0)
- Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3
+add_proj (P ax ay az) (P bx by bz) =
+ let !(# x, y, z #) = add_proj# (# ax, ay, az #) (# bx, by, bz #)
+ in P x y z
+{-# INLINABLE add_proj #-}
-- algo 8, renes et al, 2015
add_mixed :: Projective -> Projective -> Projective
-add_mixed (Projective x1 y1 z1) (Projective x2 y2 z2)
- | z2 /= 1 = error "ppad-secp256k1 (add_mixed): internal error"
- | otherwise = runST $ do
- x3 <- newSTRef 0
- y3 <- newSTRef 0
- z3 <- newSTRef 0
- t0 <- newSTRef (x1 * x2) -- 1
- t1 <- newSTRef (y1 * y2)
- t3 <- newSTRef (x2 + y2)
- t4 <- newSTRef (x1 + y1) -- 4
- readSTRef t4 >>= \r4 ->
- modifySTRef' t3 (\r3 -> r3 * r4)
- readSTRef t0 >>= \r0 ->
- readSTRef t1 >>= \r1 ->
- writeSTRef t4 (r0 + r1)
- readSTRef t4 >>= \r4 ->
- modifySTRef' t3 (\r3 -> r3 - r4) -- 7
- writeSTRef t4 (y2 * z1)
- modifySTRef' t4 (\r4 -> r4 + y1)
- writeSTRef y3 (x2 * z1) -- 10
- modifySTRef' y3 (\ry3 -> ry3 + x1)
- readSTRef t0 >>= \r0 ->
- writeSTRef x3 (r0 + r0)
- readSTRef x3 >>= \rx3 ->
- modifySTRef' t0 (\r0 -> rx3 + r0) -- 13
- t2 <- newSTRef (_CURVE_Bm3 * z1)
- readSTRef t1 >>= \r1 ->
- readSTRef t2 >>= \r2 ->
- writeSTRef z3 (r1 + r2)
- readSTRef t2 >>= \r2 ->
- modifySTRef' t1 (\r1 -> r1 - r2) -- 16
- modifySTRef' y3 (\ry3 -> _CURVE_Bm3 * ry3)
- readSTRef t4 >>= \r4 ->
- readSTRef y3 >>= \ry3 ->
- writeSTRef x3 (r4 * ry3)
- readSTRef t3 >>= \r3 ->
- readSTRef t1 >>= \r1 ->
- writeSTRef t2 (r3 * r1) -- 19
- readSTRef t2 >>= \r2 ->
- modifySTRef' x3 (\rx3 -> r2 - rx3)
- readSTRef t0 >>= \r0 ->
- modifySTRef' y3 (\ry3 -> ry3 * r0)
- readSTRef z3 >>= \rz3 ->
- modifySTRef' t1 (\r1 -> r1 * rz3) -- 22
- readSTRef t1 >>= \r1 ->
- modifySTRef' y3 (\ry3 -> r1 + ry3)
- readSTRef t3 >>= \r3 ->
- modifySTRef' t0 (\r0 -> r0 * r3)
- readSTRef t4 >>= \r4 ->
- modifySTRef' z3 (\rz3 -> rz3 * r4) -- 25
- readSTRef t0 >>= \r0 ->
- modifySTRef' z3 (\rz3 -> rz3 + r0)
- Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3
+add_mixed (P ax ay az) (P bx by bz) =
+ let !(# x, y, z #) = add_mixed# (# ax, ay, az #) (# bx, by, bz #)
+ in P x y z
+{-# INLINABLE add_mixed #-}
-- algo 9, renes et al, 2015
double :: Projective -> Projective
-double (Projective x y z) = runST $ do
- x3 <- newSTRef 0
- y3 <- newSTRef 0
- z3 <- newSTRef 0
- t0 <- newSTRef (y * y) -- 1
- readSTRef t0 >>= \r0 ->
- writeSTRef z3 (r0 + r0)
- modifySTRef' z3 (\rz3 -> rz3 + rz3)
- modifySTRef' z3 (\rz3 -> rz3 + rz3) -- 4
- t1 <- newSTRef (y * z)
- t2 <- newSTRef (z * z)
- modifySTRef t2 (\r2 -> _CURVE_Bm3 * r2) -- 7
- readSTRef z3 >>= \rz3 ->
- readSTRef t2 >>= \r2 ->
- writeSTRef x3 (r2 * rz3)
- readSTRef t0 >>= \r0 ->
- readSTRef t2 >>= \r2 ->
- writeSTRef y3 (r0 + r2)
- readSTRef t1 >>= \r1 ->
- modifySTRef' z3 (\rz3 -> r1 * rz3) -- 10
- readSTRef t2 >>= \r2 ->
- writeSTRef t1 (r2 + r2)
- readSTRef t1 >>= \r1 ->
- modifySTRef' t2 (\r2 -> r1 + r2)
- readSTRef t2 >>= \r2 ->
- modifySTRef' t0 (\r0 -> r0 - r2) -- 13
- readSTRef t0 >>= \r0 ->
- modifySTRef' y3 (\ry3 -> r0 * ry3)
- readSTRef x3 >>= \rx3 ->
- modifySTRef' y3 (\ry3 -> rx3 + ry3)
- writeSTRef t1 (x * y) -- 16
- readSTRef t0 >>= \r0 ->
- readSTRef t1 >>= \r1 ->
- writeSTRef x3 (r0 * r1)
- modifySTRef' x3 (\rx3 -> rx3 + rx3)
- Projective <$> readSTRef x3 <*> readSTRef y3 <*> readSTRef z3
+double (Projective (C.Montgomery ax) (C.Montgomery ay) (C.Montgomery az)) =
+ let !(# x, y, z #) = double# (# ax, ay, az #)
+ in P x y z
+{-# INLINABLE double #-}
-- Timing-safe scalar multiplication of secp256k1 points.
mul :: Projective -> Wider -> Maybe Projective
-mul p sec = do
- guard (ge sec)
- pure $! loop (0 :: Int) _CURVE_ZERO _CURVE_G p sec
- where
- loop !j !acc !f !d !_SECRET
- | j == _CURVE_Q_BITS = acc
- | otherwise =
- let !nd = double d
- !(# nm, lsb_set #) = W.shr1_c _SECRET
- !nacc = select_proj acc (add acc d) lsb_set
- !nf = select_proj (add f d) f lsb_set
- in loop (succ j) nacc nf nd nm
-{-# INLINE mul #-}
+mul (P x y z) (Wider s) = case mul# (# x, y, z #) s of
+ (# () | #) -> Nothing
+ (# | (# px, py, pz #) #) -> Just $! P px py pz
+{-# INLINABLE mul #-}
-- Timing-unsafe scalar multiplication of secp256k1 points.
--
-- Don't use this function if the scalar could potentially be a secret.
-mul_unsafe :: Projective -> Wider -> Maybe Projective
-mul_unsafe p = \case
+mul_vartime :: Projective -> Wider -> Maybe Projective
+mul_vartime p = \case
Zero -> pure _CURVE_ZERO
n | not (ge n) -> Nothing
| otherwise -> pure $! loop _CURVE_ZERO p n
@@ -641,14 +697,14 @@ mul_unsafe p = \case
Zero -> r
m ->
let !nd = double d
- !(# !nm, !lsb_set #) = W.shr1_c m
- !nr = if CT.decide lsb_set then add r d else r -- XX
+ !(# nm, lsb_set #) = W.shr1_c m
+ !nr = if CT.decide lsb_set then add r d else r
in loop nr nd nm
-- | Precomputed multiples of the secp256k1 base or generator point.
data Context = Context {
ctxW :: {-# UNPACK #-} !Int
- , ctxArray :: !(A.Array Projective)
+ , ctxArray :: {-# UNPACK #-} !ByteArray
} deriving Generic
instance Show Context where
@@ -666,66 +722,79 @@ instance Show Context where
precompute :: Context
precompute = _precompute 8
--- translation of noble-secp256k1's 'precompute'
+-- This is a highly-optimized version of a function originally
+-- translated from noble-secp256k1's "precompute". Points are stored in
+-- a ByteArray by arranging each limb into slices of 12 consecutive
+-- slots (each Projective point consists of three Montgomery values,
+-- each of which consists of four limbs, summing to twelve limbs in
+-- total).
+--
+-- Each point takes 96 bytes to store in this fashion, so the total size of
+-- the ByteArray is (size * 96) bytes.
_precompute :: Int -> Context
_precompute ctxW = Context {..} where
- ctxArray = A.arrayFromListN size (loop_w mempty _CURVE_G 0)
capJ = (2 :: Int) ^ (ctxW - 1)
ws = 256 `quot` ctxW + 1
size = ws * capJ
- loop_w !acc !p !w
- | w == ws = reverse acc
- | otherwise =
- let b = p
- !(Pair nacc nb) = loop_j p (b : acc) b 1
- np = double nb
- in loop_w nacc np (succ w)
-
- loop_j !p !acc !b !j
- | j == capJ = Pair acc b
- | otherwise =
- let nb = add b p
- in loop_j p (nb : acc) nb (succ j)
+ -- construct the context array
+ ctxArray = runST $ do
+ marr <- BA.newByteArray (size * 96)
+ loop_w marr _CURVE_G 0
+ BA.unsafeFreezeByteArray marr
+
+ -- write a point into the i^th 12-slot slice in the array
+ write :: MutableByteArray s -> Int -> Projective -> ST s ()
+ write marr i
+ (P (# Limb x0, Limb x1, Limb x2, Limb x3 #)
+ (# Limb y0, Limb y1, Limb y2, Limb y3 #)
+ (# Limb z0, Limb z1, Limb z2, Limb z3 #)) = do
+ let !base = i * 12
+ BA.writeByteArray marr (base + 00) (GHC.Word.W# x0)
+ BA.writeByteArray marr (base + 01) (GHC.Word.W# x1)
+ BA.writeByteArray marr (base + 02) (GHC.Word.W# x2)
+ BA.writeByteArray marr (base + 03) (GHC.Word.W# x3)
+ BA.writeByteArray marr (base + 04) (GHC.Word.W# y0)
+ BA.writeByteArray marr (base + 05) (GHC.Word.W# y1)
+ BA.writeByteArray marr (base + 06) (GHC.Word.W# y2)
+ BA.writeByteArray marr (base + 07) (GHC.Word.W# y3)
+ BA.writeByteArray marr (base + 08) (GHC.Word.W# z0)
+ BA.writeByteArray marr (base + 09) (GHC.Word.W# z1)
+ BA.writeByteArray marr (base + 10) (GHC.Word.W# z2)
+ BA.writeByteArray marr (base + 11) (GHC.Word.W# z3)
+
+ -- loop over windows
+ loop_w :: MutableByteArray s -> Projective -> Int -> ST s ()
+ loop_w !marr !p !w
+ | w == ws = pure ()
+ | otherwise = do
+ nb <- loop_j marr p p (w * capJ) 0
+ let np = double nb
+ loop_w marr np (succ w)
+
+ -- loop within windows
+ loop_j
+ :: MutableByteArray s
+ -> Projective
+ -> Projective
+ -> Int
+ -> Int
+ -> ST s Projective
+ loop_j !marr !p !b !idx !j = do
+ write marr idx b
+ if j == capJ - 1
+ then pure b
+ else do
+ let !nb = add b p
+ loop_j marr p nb (succ idx) (succ j)
-- Timing-safe wNAF (w-ary non-adjacent form) scalar multiplication of
-- secp256k1 points.
mul_wnaf :: Context -> Wider -> Maybe Projective
-mul_wnaf Context {..} _SECRET = do
- guard (ge _SECRET)
- pure $! loop 0 _CURVE_ZERO _CURVE_G _SECRET
- where
- wins = 256 `quot` ctxW + 1
- wsize = 2 ^ (ctxW - 1)
- mask = 2 ^ ctxW - 1
- mnum = 2 ^ ctxW
-
- loop !w !acc !f !n
- | w == wins = acc
- | otherwise =
- let !off0 = w * wsize
-
- !b0 = wider_to_int n .&. mask
- !n0 = n `W.shr_limb` ctxW
-
- !(Pair b1 n1) | b0 > wsize = Pair (b0 - mnum) (n0 + 1)
- | otherwise = Pair b0 n0
-
- !c0 = B.testBit w 0
- !c1 = b1 < 0
-
- !off1 = off0 + fi (abs b1) - 1
-
- in if b1 == 0
- then let !pr = A.indexArray ctxArray off0
- !pt | c0 = neg pr
- | otherwise = pr
- in loop (w + 1) acc (add f pt) n1
- else let !pr = A.indexArray ctxArray off1
- !pt | c1 = neg pr
- | otherwise = pr
- in loop (w + 1) (add acc pt) f n1
-{-# INLINE mul_wnaf #-}
+mul_wnaf Context {..} (Wider s) = case mul_wnaf# ctxArray ctxW s of
+ (# () | #) -> Nothing
+ (# | (# px, py, pz #) #) -> Just $! P px py pz
+{-# INLINABLE mul_wnaf #-}
-- | Derive a public key (i.e., a secp256k1 point) from the provided
-- secret.
@@ -761,6 +830,7 @@ parse_int256 :: BS.ByteString -> Maybe Wider
parse_int256 bs = do
guard (BS.length bs == 32)
pure $! unsafe_roll32 bs
+{-# INLINABLE parse_int256 #-}
-- | Parse compressed secp256k1 point (33 bytes), uncompressed point (65
-- bytes), or BIP0340-style point (32 bytes).
@@ -796,8 +866,7 @@ _parse_compressed h (unsafe_roll32 -> x)
| otherwise = do
let !mx = C.to x
!my <- C.sqrt (weierstrass mx)
- let !(W.Wider (# Limb w, _, _, _ #)) = C.retr my
- !yodd = B.testBit (GHC.Word.W# w) 0
+ let !yodd = CT.decide (W.odd (C.retr my))
!hodd = B.testBit h 0
pure $!
if hodd /= yodd
@@ -919,9 +988,8 @@ _sign_schnorr
_sign_schnorr _mul _SECRET m a = do
p <- _mul _SECRET
let Affine (C.retr -> x_p) (C.retr -> y_p) = affine p
- s = S.to _SECRET
- d | CT.decide (W.odd y_p) = negate s -- XX
- | otherwise = s
+ s = S.to _SECRET
+ d = S.select s (negate s) (W.odd y_p)
bytes_d = unroll32 (S.retr d)
bytes_p = unroll32 x_p
t = xor bytes_d (hash_aux a)
@@ -930,8 +998,7 @@ _sign_schnorr _mul _SECRET m a = do
guard (k' /= 0) -- negligible probability
pt <- _mul (S.retr k')
let Affine (C.retr -> x_r) (C.retr -> y_r) = affine pt
- k | CT.decide (W.odd y_r) = negate k' -- XX
- | otherwise = k'
+ k = S.select k' (negate k') (W.odd y_r)
bytes_r = unroll32 x_r
rand' = hash_challenge (bytes_r <> bytes_p <> m)
e = S.to (unsafe_roll32 rand')
@@ -956,7 +1023,7 @@ verify_schnorr
-> Pub -- ^ public key
-> BS.ByteString -- ^ 64-byte Schnorr signature
-> Bool
-verify_schnorr = _verify_schnorr (mul_unsafe _CURVE_G)
+verify_schnorr = _verify_schnorr (mul_vartime _CURVE_G)
-- | The same as 'verify_schnorr', except uses a 'Context' to optimise
-- internal calculations.
@@ -993,7 +1060,7 @@ _verify_schnorr _mul m p sig
e = modQ . unsafe_roll32 $
hash_challenge (unroll32 r <> unroll32 x_P <> m)
pt0 <- _mul s
- pt1 <- mul_unsafe capP e
+ pt1 <- mul_vartime capP e
let dif = add pt0 (neg pt1)
guard (dif /= _CURVE_ZERO)
let Affine (C.from -> x_R) (C.from -> y_R) = affine dif
@@ -1066,9 +1133,7 @@ data HashFlag =
-- Convert an ECDSA signature to low-S form.
low :: ECDSA -> ECDSA
-low (ECDSA r s) = ECDSA r ms where
- ms | s > _CURVE_QH = _CURVE_Q - s
- | otherwise = s
+low (ECDSA r s) = ECDSA r (W.select s (_CURVE_Q - s) (W.gt s _CURVE_QH))
{-# INLINE low #-}
-- | Produce an ECDSA signature for the provided message, using the
@@ -1256,7 +1321,7 @@ verify_ecdsa_unrestricted
-> Pub -- ^ public key
-> ECDSA -- ^ signature
-> Bool
-verify_ecdsa_unrestricted = _verify_ecdsa_unrestricted (mul_unsafe _CURVE_G)
+verify_ecdsa_unrestricted = _verify_ecdsa_unrestricted (mul_vartime _CURVE_G)
-- | The same as 'verify_ecdsa_unrestricted', except uses a 'Context' to
-- optimise internal calculations.
@@ -1294,7 +1359,7 @@ _verify_ecdsa_unrestricted _mul m p (ECDSA r0 s0) = M.isJust $ do
u1 = S.retr (e * si)
u2 = S.retr (r * si)
pt0 <- _mul u1
- pt1 <- mul_unsafe p u2
+ pt1 <- mul_vartime p u2
let capR = add pt0 pt1
guard (capR /= _CURVE_ZERO)
let Affine (S.to . C.retr -> v) _ = affine capR
diff --git a/weigh-0.0.18/CHANGELOG b/weigh-0.0.18/CHANGELOG
@@ -0,0 +1,49 @@
+0.0.18:
+ * Fix compatibility with `mtl`, whenever different version from the one that is wired with ghc is used.
+
+0.0.17:
+ * Changes to make compatible for GHC 9.6
+
+0.0.16:
+ * Add MaxOS parameter to indicate memory in use by RTS
+ * Add haddock docmentation to the 'Column' type
+ * Fix bug in treating words as int, use only Word as reported by GHC.
+
+0.0.14:
+ * Use the correct data source for final live bytes total
+
+0.0.13:
+ * Forward arguments to the child process
+
+0.0.12:
+ * Fix bug in non-unique groupings
+
+0.0.10:
+ * Export Grouped
+
+0.0.9:
+ * Support markdown output
+
+0.0.8:
+ * Support grouping
+
+0.0.6:
+ * Support GHC 8.2
+ * Use more reliable calculations
+
+0.0.4:
+ * Added more system-independent word size calculation
+
+0.0.3:
+ * Added more docs to haddocks
+ * Export more internal combinators
+
+0.0.2:
+ * Remove magic numbers from weighing code, better accuracy
+ * Add additional `io` combinator
+
+0.0.1:
+ * Support GHC 8.
+
+0.0.0:
+ * First release.
diff --git a/weigh-0.0.18/LICENSE b/weigh-0.0.18/LICENSE
@@ -0,0 +1,30 @@
+Copyright Chris Done (c) 2016
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Chris Done nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+\ No newline at end of file
diff --git a/weigh-0.0.18/README.md b/weigh-0.0.18/README.md
@@ -0,0 +1,37 @@
+# weigh [](https://github.com/fpco/weigh/actions/workflows/tests.yml)
+
+Measures the memory usage of a Haskell value or function
+
+# Limitations
+
+* :warning: Turn off the `-threaded` flag, otherwise it will cause inconsistent results.
+
+## Example use
+
+``` haskell
+import Weigh
+
+main :: IO ()
+main =
+ mainWith
+ (do func "integers count 0" count 0
+ func "integers count 1" count 1
+ func "integers count 10" count 10
+ func "integers count 100" count 100)
+ where
+ count :: Integer -> ()
+ count 0 = ()
+ count a = count (a - 1)
+```
+
+Output results:
+
+|Case|Allocated|GCs|
+|:---|---:|---:|
+|integers count 0|16|0|
+|integers count 1|88|0|
+|integers count 10|736|0|
+|integers count 100|7,216|0|
+
+Output by default is plain text table; pass `--markdown` to get a
+markdown output like the above.
diff --git a/weigh-0.0.18/Setup.hs b/weigh-0.0.18/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/weigh-0.0.18/src/Weigh.hs b/weigh-0.0.18/src/Weigh.hs
@@ -0,0 +1,637 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+
+-- | Framework for seeing how much a function allocates.
+--
+-- WARNING: weigh is incompatible with profiling. It reports much more
+-- allocations with profiling turned on.
+--
+-- Example:
+--
+-- @
+-- import Weigh
+-- main =
+-- mainWith (do func "integers count 0" count 0
+-- func "integers count 1" count 1
+-- func "integers count 2" count 2
+-- func "integers count 3" count 3
+-- func "integers count 10" count 10
+-- func "integers count 100" count 100)
+-- where count :: Integer -> ()
+-- count 0 = ()
+-- count a = count (a - 1)
+-- @
+--
+-- Use 'wgroup' to group sets of tests.
+
+module Weigh
+ (-- * Main entry points
+ mainWith
+ ,weighResults
+ -- * Configuration
+ ,setColumns
+ ,Column(..)
+ ,setFormat
+ ,Format (..)
+ ,setConfig
+ ,Config (..)
+ ,defaultConfig
+ -- * Simple combinators
+ ,func
+ ,func'
+ ,io
+ ,value
+ ,action
+ ,wgroup
+ -- * Validating combinators
+ ,validateAction
+ ,validateFunc
+ -- * Validators
+ ,maxAllocs
+ -- * Types
+ ,Weigh
+ ,Weight(..)
+ -- * Handy utilities
+ ,commas
+ ,reportGroup
+ -- * Internals
+ ,weighDispatch
+ ,weighFunc
+ ,weighFuncResult
+ ,weighAction
+ ,weighActionResult
+ ,Grouped(..)
+ )
+ where
+
+import Control.Applicative
+import Control.Arrow
+import Control.DeepSeq
+import Control.Monad (unless)
+import Control.Monad.State (State, execState, get, gets, modify)
+import Criterion.Measurement
+import qualified Data.Foldable as Foldable
+import qualified Data.List as List
+import Data.List.Split
+import Data.Maybe
+import qualified Data.Traversable as Traversable
+import Data.Word
+import GHC.Generics
+import Prelude
+import System.Environment
+import System.Exit
+import System.IO
+import System.IO.Temp
+import System.Mem
+import System.Process
+import Text.Printf
+import qualified Weigh.GHCStats as GHCStats
+
+--------------------------------------------------------------------------------
+-- Types
+
+-- | Table column.
+data Column
+ = Case -- ^ Case name for the column
+ | Allocated -- ^ Total bytes allocated
+ | GCs -- ^ Total number of GCs
+ | Live -- ^ Total amount of live data in the heap
+ | Check -- ^ Table column indicating about the test status
+ | Max -- ^ Maximum residency memory in use
+ | MaxOS -- ^ Maximum memory in use by the RTS. Valid only for
+ -- GHC >= 8.2.2. For unsupported GHC, this is reported
+ -- as 0.
+ | WallTime -- ^ Rough execution time. For general indication, not a benchmark tool.
+ deriving (Show, Eq, Enum)
+
+-- | Weigh configuration.
+data Config = Config
+ { configColumns :: [Column]
+ , configPrefix :: String
+ , configFormat :: !Format
+ } deriving (Show)
+
+data Format = Plain | Markdown
+ deriving (Show)
+
+-- | Weigh specification monad.
+newtype Weigh a =
+ Weigh {runWeigh :: State (Config, [Grouped Action]) a}
+ deriving (Monad,Functor,Applicative)
+
+-- | How much a computation weighed in at.
+data Weight =
+ Weight {weightLabel :: !String
+ ,weightAllocatedBytes :: !Word64
+ ,weightGCs :: !Word32
+ ,weightLiveBytes :: !Word64
+ ,weightMaxBytes :: !Word64
+ ,weightMaxOSBytes :: !Word64
+ ,weightWallTime :: !Double
+ }
+ deriving (Read,Show)
+
+-- | Some grouped thing.
+data Grouped a
+ = Grouped String [Grouped a]
+ | Singleton a
+ deriving (Eq, Show, Functor, Traversable.Traversable, Foldable.Foldable, Generic)
+instance NFData a => NFData (Grouped a)
+
+-- | An action to run.
+data Action =
+ forall a b. (NFData a) =>
+ Action {_actionRun :: !(Either (b -> IO a) (b -> a))
+ ,_actionArg :: !b
+ ,actionName :: !String
+ ,actionCheck :: Weight -> Maybe String}
+instance NFData Action where rnf _ = ()
+
+--------------------------------------------------------------------------------
+-- Main-runners
+
+-- | Just run the measuring and print a report. Uses 'weighResults'.
+mainWith :: Weigh a -> IO ()
+mainWith m = do
+ (results, config) <- weighResults m
+ unless
+ (null results)
+ (do putStrLn ""
+ putStrLn (report config results))
+ case mapMaybe
+ (\(w, r) -> do
+ msg <- r
+ return (w, msg))
+ (concatMap Foldable.toList (Foldable.toList results)) of
+ [] -> return ()
+ errors -> do
+ putStrLn "\nCheck problems:"
+ mapM_
+ (\(w, r) -> putStrLn (" " ++ weightLabel w ++ "\n " ++ r))
+ errors
+ exitWith (ExitFailure (-1))
+
+-- | Run the measuring and return all the results, each one may have
+-- an error.
+weighResults
+ :: Weigh a -> IO ([Grouped (Weight,Maybe String)], Config)
+weighResults m = do
+ args <- getArgs
+ weighEnv <- lookupEnv "WEIGH_CASE"
+ let (config, cases) = execState (runWeigh m) (defaultConfig, [])
+ result <- weighDispatch weighEnv cases
+ case result of
+ Nothing -> return ([], config)
+ Just weights ->
+ return
+ ( fmap
+ (fmap
+ (\w ->
+ case glookup (weightLabel w) cases of
+ Nothing -> (w, Nothing)
+ Just a -> (w, actionCheck a w)))
+ weights
+ , config
+ { configFormat =
+ if any (== "--markdown") args
+ then Markdown
+ else configFormat config
+ })
+
+--------------------------------------------------------------------------------
+-- User DSL
+
+-- | Default columns to display.
+defaultColumns :: [Column]
+defaultColumns = [Case, Allocated, GCs]
+
+-- | Default config.
+defaultConfig :: Config
+defaultConfig =
+ Config
+ {configColumns = defaultColumns, configPrefix = "", configFormat = Plain}
+
+-- | Set the columns to display in the config
+setColumns :: [Column] -> Weigh ()
+setColumns cs = Weigh (modify (first (\c -> c {configColumns = cs})))
+
+-- | Set the output format in the config
+setFormat :: Format -> Weigh ()
+setFormat fm = Weigh (modify (first (\c -> c {configFormat = fm})))
+
+-- | Set the config. Default is: 'defaultConfig'.
+setConfig :: Config -> Weigh ()
+setConfig = Weigh . modify . first . const
+
+-- | Weigh a function applied to an argument.
+--
+-- Implemented in terms of 'validateFunc'.
+func :: (NFData a)
+ => String -- ^ Name of the case.
+ -> (b -> a) -- ^ Function that does some action to measure.
+ -> b -- ^ Argument to that function.
+ -> Weigh ()
+func name !f !x = validateFunc name f x (const Nothing)
+
+-- | Weigh a function applied to an argument. Unlike 'func', the argument
+-- is evaluated to normal form before the function is applied.
+func' :: (NFData a, NFData b)
+ => String
+ -> (b -> a)
+ -> b
+ -> Weigh ()
+func' name !f (force -> !x) = validateFunc name f x (const Nothing)
+
+-- | Weigh an action applied to an argument.
+--
+-- Implemented in terms of 'validateAction'.
+io :: (NFData a)
+ => String -- ^ Name of the case.
+ -> (b -> IO a) -- ^ Action that does some IO to measure.
+ -> b -- ^ Argument to that function.
+ -> Weigh ()
+io name !f !x = validateAction name f x (const Nothing)
+
+-- | Weigh a value.
+--
+-- Implemented in terms of 'action'.
+value :: NFData a
+ => String -- ^ Name for the value.
+ -> a -- ^ The value to measure.
+ -> Weigh ()
+value name !v = func name id v
+
+-- | Weigh an IO action.
+--
+-- Implemented in terms of 'validateAction'.
+action :: NFData a
+ => String -- ^ Name for the value.
+ -> IO a -- ^ The action to measure.
+ -> Weigh ()
+action name !m = io name (const m) ()
+
+-- | Make a validator that set sthe maximum allocations.
+maxAllocs :: Word64 -- ^ The upper bound.
+ -> (Weight -> Maybe String)
+maxAllocs n =
+ \w ->
+ if weightAllocatedBytes w > n
+ then Just ("Allocated bytes exceeds " ++
+ commas n ++ ": " ++ commas (weightAllocatedBytes w))
+ else Nothing
+
+-- | Weigh an IO action, validating the result.
+validateAction :: (NFData a)
+ => String -- ^ Name of the action.
+ -> (b -> IO a) -- ^ The function which performs some IO.
+ -> b -- ^ Argument to the function. Doesn't have to be forced.
+ -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error.
+ -> Weigh ()
+validateAction name !m !arg !validate =
+ tellAction name $ flip (Action (Left m) arg) validate
+
+-- | Weigh a function, validating the result
+validateFunc :: (NFData a)
+ => String -- ^ Name of the function.
+ -> (b -> a) -- ^ The function which calculates something.
+ -> b -- ^ Argument to the function. Doesn't have to be forced.
+ -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error.
+ -> Weigh ()
+validateFunc name !f !x !validate =
+ tellAction name $ flip (Action (Right f) x) validate
+
+-- | Write out an action.
+tellAction :: String -> (String -> Action) -> Weigh ()
+tellAction name act =
+ Weigh (do prefix <- gets (configPrefix . fst)
+ modify (second (\x -> x ++ [Singleton $ act (prefix ++ "/" ++ name)])))
+
+-- | Make a grouping of tests.
+wgroup :: String -> Weigh () -> Weigh ()
+wgroup str wei = do
+ (orig, start) <- Weigh get
+ let startL = length $ start
+ Weigh (modify (first (\c -> c {configPrefix = configPrefix orig ++ "/" ++ str})))
+ wei
+ Weigh $ do
+ modify $ second $ \x -> take startL x ++ [Grouped str $ drop startL x]
+ modify (first (\c -> c {configPrefix = configPrefix orig}))
+
+--------------------------------------------------------------------------------
+-- Internal measuring actions
+
+-- | Weigh a set of actions. The value of the actions are forced
+-- completely to ensure they are fully allocated.
+weighDispatch :: Maybe String -- ^ The content of then env variable WEIGH_CASE.
+ -> [Grouped Action] -- ^ Weigh name:action mapping.
+ -> IO (Maybe [(Grouped Weight)])
+weighDispatch args cases =
+ case args of
+ Just var -> do
+ let (label:fp:_) = read var
+ let !_ = force fp
+ let !cases' = force cases
+ performGC -- flush CAF initialization allocations before measurement
+ case glookup label cases' of
+ Nothing -> error "No such case!"
+ Just act -> do
+ case act of
+ Action !run arg _ _ -> do
+ initializeTime
+ start <- getTime
+ (bytes, gcs, liveBytes, maxByte, maxOSBytes) <-
+ case run of
+ Right f -> weighFunc f arg
+ Left m -> weighAction m arg
+ end <- getTime
+ writeFile
+ fp
+ (show
+ (Weight
+ { weightLabel = label
+ , weightAllocatedBytes = bytes
+ , weightGCs = gcs
+ , weightLiveBytes = liveBytes
+ , weightMaxBytes = maxByte
+ , weightMaxOSBytes = maxOSBytes
+ , weightWallTime = end - start
+ }))
+ return Nothing
+ _ -> fmap Just (Traversable.traverse (Traversable.traverse fork) cases)
+
+-- | Lookup an action.
+glookup :: String -> [Grouped Action] -> Maybe Action
+glookup label =
+ Foldable.find ((== label) . actionName) .
+ concat . map Foldable.toList . Foldable.toList
+
+-- | Fork a case and run it.
+fork :: Action -- ^ Label for the case.
+ -> IO Weight
+fork act =
+ withSystemTempFile
+ "weigh"
+ (\fp h -> do
+ hClose h
+ setEnv "WEIGH_CASE" $ show $ [actionName act,fp]
+ me <- getExecutablePath
+ args <- getArgs
+ (exit, _, err) <-
+ readProcessWithExitCode
+ me
+ (args ++ ["+RTS", "-T", "-RTS"])
+ ""
+ case exit of
+ ExitFailure {} ->
+ error
+ ("Error in case (" ++ show (actionName act) ++ "):\n " ++ err)
+ ExitSuccess -> do
+ out <- readFile fp
+ case reads out of
+ [(!r, _)] -> return r
+ _ ->
+ error
+ (concat
+ [ "Malformed output from subprocess. Weigh"
+ , " (currently) communicates with its sub-"
+ , "processes via a temporary file."
+ ]))
+
+-- | Weigh a pure function. This function is built on top of `weighFuncResult`,
+-- which is heavily documented inside
+weighFunc
+ :: (NFData a)
+ => (b -> a) -- ^ A function whose memory use we want to measure.
+ -> b -- ^ Argument to the function. Doesn't have to be forced.
+ -> IO (Word64,Word32,Word64,Word64,Word64) -- ^ Bytes allocated and garbage collections.
+weighFunc run !arg = snd <$> weighFuncResult run arg
+
+-- | Weigh a pure function and return the result. This function is heavily
+-- documented inside.
+weighFuncResult
+ :: (NFData a)
+ => (b -> a) -- ^ A function whose memory use we want to measure.
+ -> b -- ^ Argument to the function. Doesn't have to be forced.
+ -> IO (a, (Word64,Word32,Word64,Word64,Word64)) -- ^ Result, Bytes allocated, GCs.
+weighFuncResult run !arg = do
+ ghcStatsSizeInBytes <- GHCStats.getGhcStatsSizeInBytes
+ performGC
+ -- The above forces getStats data to be generated NOW.
+ !bootupStats <- GHCStats.getStats
+ -- We need the above to subtract "program startup" overhead. This
+ -- operation itself adds n bytes for the size of GCStats, but we
+ -- subtract again that later.
+ let !result = force (run arg)
+ performGC
+ -- The above forces getStats data to be generated NOW.
+ !actionStats <- GHCStats.getStats
+ let reflectionGCs = 1 -- We performed an additional GC.
+ actionBytes =
+ (GHCStats.totalBytesAllocated actionStats `subtracting`
+ GHCStats.totalBytesAllocated bootupStats) `subtracting`
+ -- We subtract the size of "bootupStats", which will be
+ -- included after we did the performGC.
+ fromIntegral ghcStatsSizeInBytes
+ actionGCs =
+ GHCStats.gcCount actionStats `subtracting` GHCStats.gcCount bootupStats `subtracting`
+ reflectionGCs
+ -- If overheadBytes is too large, we conservatively just
+ -- return zero. It's not perfect, but this library is for
+ -- measuring large quantities anyway.
+ actualBytes = max 0 actionBytes
+ liveBytes =
+ (GHCStats.liveBytes actionStats `subtracting`
+ GHCStats.liveBytes bootupStats)
+ maxBytes =
+ (GHCStats.maxBytesInUse actionStats `subtracting`
+ GHCStats.maxBytesInUse bootupStats)
+ maxOSBytes =
+ (GHCStats.maxOSBytes actionStats `subtracting`
+ GHCStats.maxOSBytes bootupStats)
+ return (result, (actualBytes, actionGCs, liveBytes, maxBytes, maxOSBytes))
+
+subtracting :: (Ord p, Num p) => p -> p -> p
+subtracting x y =
+ if x > y
+ then x - y
+ else 0
+
+-- | Weigh an IO action. This function is based on `weighActionResult`, which is
+-- heavily documented inside.
+weighAction
+ :: (NFData a)
+ => (b -> IO a) -- ^ A function whose memory use we want to measure.
+ -> b -- ^ Argument to the function. Doesn't have to be forced.
+ -> IO (Word64,Word32,Word64,Word64,Word64) -- ^ Bytes allocated and garbage collections.
+weighAction run !arg = snd <$> weighActionResult run arg
+
+-- | Weigh an IO action, and return the result. This function is heavily
+-- documented inside.
+weighActionResult
+ :: (NFData a)
+ => (b -> IO a) -- ^ A function whose memory use we want to measure.
+ -> b -- ^ Argument to the function. Doesn't have to be forced.
+ -> IO (a, (Word64,Word32,Word64,Word64,Word64)) -- ^ Result, Bytes allocated and GCs.
+weighActionResult run !arg = do
+ ghcStatsSizeInBytes <- GHCStats.getGhcStatsSizeInBytes
+ performGC
+ -- The above forces getStats data to be generated NOW.
+ !bootupStats <- GHCStats.getStats
+ -- We need the above to subtract "program startup" overhead. This
+ -- operation itself adds n bytes for the size of GCStats, but we
+ -- subtract again that later.
+ !result <- fmap force (run arg)
+ performGC
+ -- The above forces getStats data to be generated NOW.
+ !actionStats <- GHCStats.getStats
+ let reflectionGCs = 1 -- We performed an additional GC.
+ actionBytes =
+ (GHCStats.totalBytesAllocated actionStats `subtracting`
+ GHCStats.totalBytesAllocated bootupStats) `subtracting`
+ -- We subtract the size of "bootupStats", which will be
+ -- included after we did the performGC.
+ fromIntegral ghcStatsSizeInBytes
+ actionGCs =
+ GHCStats.gcCount actionStats `subtracting` GHCStats.gcCount bootupStats `subtracting`
+ reflectionGCs
+ -- If overheadBytes is too large, we conservatively just
+ -- return zero. It's not perfect, but this library is for
+ -- measuring large quantities anyway.
+ actualBytes = max 0 actionBytes
+ liveBytes =
+ max 0 (GHCStats.liveBytes actionStats `subtracting` GHCStats.liveBytes bootupStats)
+ maxBytes =
+ max
+ 0
+ (GHCStats.maxBytesInUse actionStats `subtracting`
+ GHCStats.maxBytesInUse bootupStats)
+ maxOSBytes =
+ max
+ 0
+ (GHCStats.maxOSBytes actionStats `subtracting`
+ GHCStats.maxOSBytes bootupStats)
+ return (result,
+ ( actualBytes
+ , actionGCs
+ , liveBytes
+ , maxBytes
+ , maxOSBytes
+ ))
+
+--------------------------------------------------------------------------------
+-- Formatting functions
+
+report :: Config -> [Grouped (Weight,Maybe String)] -> String
+report config gs =
+ List.intercalate
+ "\n\n"
+ (filter
+ (not . null)
+ [ if null singletons
+ then []
+ else reportTabular config singletons
+ , List.intercalate "\n\n" (map (uncurry (reportGroup config)) groups)
+ ])
+ where
+ singletons =
+ mapMaybe
+ (\case
+ Singleton v -> Just v
+ _ -> Nothing)
+ gs
+ groups =
+ mapMaybe
+ (\case
+ Grouped title vs -> Just (title, vs)
+ _ -> Nothing)
+ gs
+
+reportGroup :: Config -> [Char] -> [Grouped (Weight, Maybe String)] -> [Char]
+reportGroup config title gs =
+ case configFormat config of
+ Plain -> title ++ "\n\n" ++ indent (report config gs)
+ Markdown -> "#" ++ title ++ "\n\n" ++ report config gs
+
+-- | Make a report of the weights.
+reportTabular :: Config -> [(Weight,Maybe String)] -> String
+reportTabular config = tabled
+ where
+ tabled =
+ (case configFormat config of
+ Plain -> tablize
+ Markdown -> mdtable) .
+ (select headings :) . map (select . toRow)
+ select row = mapMaybe (\name -> lookup name row) (configColumns config)
+ headings =
+ [ (Case, (True, "Case"))
+ , (Allocated, (False, "Allocated"))
+ , (GCs, (False, "GCs"))
+ , (Live, (False, "Live"))
+ , (Check, (True, "Check"))
+ , (Max, (False, "Max"))
+ , (MaxOS, (False, "MaxOS"))
+ , (WallTime, (False, "Wall Time"))
+ ]
+ toRow (w, err) =
+ [ (Case, (True, takeLastAfterBk $ weightLabel w))
+ , (Allocated, (False, commas (weightAllocatedBytes w)))
+ , (GCs, (False, commas (weightGCs w)))
+ , (Live, (False, commas (weightLiveBytes w)))
+ , (Max, (False, commas (weightMaxBytes w)))
+ , (MaxOS, (False, commas (weightMaxOSBytes w)))
+ , (WallTime, (False, printf "%.3fs" (weightWallTime w)))
+ , ( Check
+ , ( True
+ , case err of
+ Nothing -> "OK"
+ Just {} -> "INVALID"))
+ ]
+ takeLastAfterBk w = case List.elemIndices '/' w of
+ [] -> w
+ x -> drop (1+last x) w
+
+-- | Make a markdown table.
+mdtable ::[[(Bool,String)]] -> String
+mdtable rows = List.intercalate "\n" [heading, align, body]
+ where
+ heading = columns (map (\(_, str) -> str) (fromMaybe [] (listToMaybe rows)))
+ align =
+ columns
+ (map
+ (\(shouldAlignLeft, _) ->
+ if shouldAlignLeft
+ then ":---"
+ else "---:")
+ (fromMaybe [] (listToMaybe rows)))
+ body =
+ List.intercalate "\n" (map (\row -> columns (map snd row)) (drop 1 rows))
+ columns xs = "|" ++ List.intercalate "|" xs ++ "|"
+
+-- | Make a table out of a list of rows.
+tablize :: [[(Bool,String)]] -> String
+tablize xs =
+ List.intercalate "\n" (map (List.intercalate " " . map fill . zip [0 ..]) xs)
+ where
+ fill (x', (left', text')) =
+ printf ("%" ++ direction ++ show width ++ "s") text'
+ where
+ direction =
+ if left'
+ then "-"
+ else ""
+ width = maximum (map (length . snd . (!! x')) xs)
+
+-- | Formatting an integral number to 1,000,000, etc.
+commas :: (Num a,Integral a,Show a) => a -> String
+commas = reverse . List.intercalate "," . chunksOf 3 . reverse . show
+
+-- | Indent all lines in a string.
+indent :: [Char] -> [Char]
+indent = List.intercalate "\n" . map (replicate 2 ' '++) . lines
diff --git a/weigh-0.0.18/src/Weigh/GHCStats.hs b/weigh-0.0.18/src/Weigh/GHCStats.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+
+-- | Calculate the size of GHC.Stats statically.
+
+module Weigh.GHCStats
+ (getGhcStatsSizeInBytes
+ ,getStats
+ ,gcCount
+ ,totalBytesAllocated
+ ,liveBytes
+ ,maxBytesInUse
+ ,maxOSBytes
+ )
+ where
+
+import Data.Word
+import GHC.Stats
+import System.Mem
+
+-- | Get GHC's statistics.
+getStats :: IO RTSStats
+getStats = getRTSStats
+
+gcCount :: RTSStats -> Word32
+gcCount = gcs
+
+totalBytesAllocated :: RTSStats -> Word64
+totalBytesAllocated = allocated_bytes
+
+liveBytes :: RTSStats -> Word64
+liveBytes = gcdetails_live_bytes . gc
+
+maxBytesInUse :: RTSStats -> Word64
+maxBytesInUse = max_live_bytes
+
+maxOSBytes :: RTSStats -> Word64
+maxOSBytes = max_mem_in_use_bytes
+
+-- | Get the size of a 'RTSStats' object in bytes.
+getGhcStatsSizeInBytes :: IO Word64
+getGhcStatsSizeInBytes = do
+ s1 <- oneGetStats
+ s2 <- twoGetStats
+ return (fromIntegral (totalBytesAllocated s2 - totalBytesAllocated s1))
+ where
+ oneGetStats = do
+ performGC
+ !s <- getStats
+ return s
+ twoGetStats = do
+ performGC
+ !_ <- getStats
+ !s <- getStats
+ return s
diff --git a/weigh-0.0.18/src/test/Main.hs b/weigh-0.0.18/src/test/Main.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+-- | Example uses of Weigh which should work.
+
+module Main where
+
+import Control.DeepSeq
+import Weigh
+import GHC.Generics
+
+import Data.List (nub)
+
+-- | Weigh integers.
+main :: IO ()
+main =
+ mainWith
+ (do wgroup "Integers" integers
+ wgroup "IO actions" ioactions
+ wgroup "Ints" ints
+ wgroup "Structs" struct
+ wgroup "Packing" packing
+ wgroup "fst" aFuncNamedId
+ wgroup "snd" anotherFuncNamedId
+ )
+
+-- | Weigh IO actions.
+ioactions :: Weigh ()
+ioactions =
+ do action "integers count IO CAF 0" (return (count 0))
+ io "integers count IO func 0" (return . count) 0
+ action "integers count IO CAF 1" (return (count 1))
+ io "integers count IO func 1" (return . count) 1
+ where count :: Integer -> ()
+ count 0 = ()
+ count a = count (a - 1)
+
+-- | Just counting integers.
+integers :: Weigh ()
+integers = do
+ func "integers count 0" count 0
+ func "integers count 1" count 1
+ func "integers count 2" count 2
+ func "integers count 3" count 3
+ func "integers count 10" count 10
+ func "integers count 100" count 100
+ where
+ count :: Integer -> ()
+ count 0 = ()
+ count a = count (a - 1)
+
+-- | We count ints and ensure that the allocations are optimized away
+-- to only two 64-bit Ints (16 bytes).
+ints :: Weigh ()
+ints =
+ do validateFunc "ints count 1" count 1 (maxAllocs 0)
+ validateFunc "ints count 10" count 10 (maxAllocs 0)
+ validateFunc "ints count 1000000" count 1000000 (maxAllocs 0)
+ where count :: Int -> ()
+ count 0 = ()
+ count a = count (a - 1)
+
+-- | Some simple data structure of two ints.
+data IntegerStruct = IntegerStruct !Integer !Integer
+ deriving (Generic)
+instance NFData IntegerStruct
+
+-- | Weigh allocating a user-defined structure.
+struct :: Weigh ()
+struct =
+ do func "\\_ -> IntegerStruct 0 0" (\_ -> IntegerStruct 0 0) (5 :: Integer)
+ func "\\x -> IntegerStruct x 0" (\x -> IntegerStruct x 0) 5
+ func "\\x -> IntegerStruct x x" (\x -> IntegerStruct x x) 5
+ func "\\x -> IntegerStruct (x+1) x" (\x -> IntegerStruct (x+1) x) 5
+ func "\\x -> IntegerStruct (x+1) (x+1)" (\x -> IntegerStruct (x+1) (x+1)) 5
+ func "\\x -> IntegerStruct (x+1) (x+2)" (\x -> IntegerStruct (x+1) (x+2)) 5
+
+-- | A simple structure with an Int in it.
+data HasInt = HasInt !Int
+ deriving (Generic)
+instance NFData HasInt
+
+-- | A simple structure with an Int in it.
+data HasPacked = HasPacked HasInt
+ deriving (Generic)
+instance NFData HasPacked
+
+-- | A simple structure with an Int in it.
+data HasUnpacked = HasUnpacked {-# UNPACK #-} !HasInt
+ deriving (Generic)
+instance NFData HasUnpacked
+
+-- | Weigh: packing vs no packing.
+packing :: Weigh ()
+packing =
+ do func "\\x -> HasInt x" (\x -> HasInt x) 5
+ func "\\x -> HasUnpacked (HasInt x)" (\x -> HasUnpacked (HasInt x)) 5
+ func "\\x -> HasPacked (HasInt x)" (\x -> HasPacked (HasInt x)) 5
+
+aFuncNamedId :: Weigh ()
+aFuncNamedId = func "id" id (1::Int)
+
+anotherFuncNamedId :: Weigh ()
+anotherFuncNamedId = func "id" nub ([1,2,3,4,5,1]::[Int])
diff --git a/weigh-0.0.18/weigh.cabal b/weigh-0.0.18/weigh.cabal
@@ -0,0 +1,41 @@
+name: weigh
+version: 0.0.18
+synopsis: Measure allocations of a Haskell functions/values
+description: Please see README.md
+homepage: https://github.com/fpco/weigh#readme
+license: BSD3
+license-file: LICENSE
+author: Chris Done
+maintainer: chrisdone@fpcomplete.com
+copyright: FP Complete
+category: Web
+build-type: Simple
+extra-source-files: README.md
+ CHANGELOG
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ ghc-options: -Wall -O2
+ exposed-modules: Weigh
+ other-modules: Weigh.GHCStats
+ build-depends: base >= 4.7 && < 5
+ , process
+ , deepseq
+ , mtl
+ , split
+ , temporary
+ , criterion-measurement
+ default-language: Haskell2010
+ if impl(ghc < 8.2.1)
+ buildable: False
+
+test-suite weigh-test
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+ hs-source-dirs: src/test
+ ghc-options: -O2 -Wall
+ main-is: Main.hs
+ build-depends: base
+ , weigh
+ , deepseq
