commit 952e56058fc2ae5a4f232d5c51ccecfc79cc5a76
parent 2fcee73a944287c53d55d94e594abfab539e7f45
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 21 Dec 2025 11:00:58 -0330
bench: improve weigh suite
It's apparently important to avoid a bunch of CAFs floating around in
the Weigh suite as they can really mess with allocation benchmarks. This
commit cleans them up so that we get accurate benchmarks for e.g. 'ge',
'mul'.
Diffstat:
12 files changed, 1105 insertions(+), 163 deletions(-)
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -27,6 +27,7 @@ main :: IO ()
main = defaultMain [
parse_point
, add
+ , double
, mul
, precompute
, mul_wnaf
@@ -67,13 +68,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 ->
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,14 +27,13 @@ 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
@@ -44,6 +42,14 @@ main = W.mainWith $ do
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 +60,113 @@ 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
+ W.func' "2 G" (S.mul g) t
+ W.func' "(2 ^ 255 - 19) G" (S.mul g) b
mul_unsafe :: W.Weigh ()
mul_unsafe =
let !g = S._CURVE_G
!t = 2
- !bigl = big
+ !b = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
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_unsafe g) t
+ W.func' "(2 ^ 255 - 19) G" (S.mul_unsafe 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": 1766326001,
+ "narHash": "sha256-F4jW49qqBoHe/QqrKU0evVttXbHFzZxLrWKpdYgV/XE=",
"ref": "master",
- "rev": "a9d4855bedf548913fcfe1e4eaf6e5dca540f524",
- "revCount": 249,
+ "rev": "92b527cd0141dbd24b28e92290c0b5949d1a4a0c",
+ "revCount": 250,
"type": "git",
"url": "git://git.ppad.tech/fixed.git"
},
diff --git a/lib/Crypto/Curve/Secp256k1.hs b/lib/Crypto/Curve/Secp256k1.hs
@@ -35,6 +35,8 @@ module Crypto.Curve.Secp256k1 (
, derive_pub'
, _CURVE_G
, _CURVE_ZERO
+ , ge
+ , fe
-- * Parsing
, parse_int256
@@ -72,6 +74,8 @@ module Crypto.Curve.Secp256k1 (
-- Elliptic curve group operations
, neg
, add
+ , add_mixed
+ , add_proj
, double
, mul
, mul_unsafe
@@ -91,6 +95,7 @@ module Crypto.Curve.Secp256k1 (
, roll32
, unsafe_roll32
, unroll32
+ , select_proj
) where
import Control.Monad (guard)
@@ -128,9 +133,23 @@ fi = fromIntegral
-- dumb strict pair
data Pair a b = Pair !a !b
--- convenience pattern
+-- Unboxed Montgomery synonym.
+type Mont = (# Limb, Limb, Limb, Limb #)
+
+-- Unboxed Projective synonym.
+type Proj = (# Mont, Mont, Mont #)
+
+-- convenience patterns
pattern Zero :: Wider
-pattern Zero = Wider (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #)
+pattern Zero = Wider Z
+
+pattern Z :: Mont
+pattern Z = (# Limb 0##, Limb 0##, Limb 0##, Limb 0## #)
+
+pattern P :: Mont -> Mont -> Mont -> Projective
+pattern P x y z =
+ Projective (C.Montgomery x) (C.Montgomery y) (C.Montgomery z)
+{-# COMPLETE P #-}
-- convert a Word8 to a Limb
limb :: Word8 -> Limb
@@ -372,13 +391,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
@@ -428,12 +449,6 @@ even_y_vartime p = case affine p of
-- unboxed internals ----------------------------------------------------------
--- Unboxed Montgomery synonym.
-type Mont = (# Limb, Limb, Limb, Limb #)
-
--- Unboxed Projective synonym.
-type Proj = (# Mont, Mont, Mont #)
-
-- algo 9, renes et al, 2015
double# :: Proj -> Proj
double# (# x, y, z #) =
@@ -532,33 +547,26 @@ add_mixed# (# x1, y1, z1 #) (# x2, y2, _z2 #) =
in (# x3c, y3e, z3c #)
{-# INLINE add_mixed# #-}
--- Constant-time selection of Projective points.
select_proj# :: Proj -> Proj -> CT.Choice -> Proj
select_proj# (# ax, ay, az #) (# bx, by, bz #) c =
- (# C.select# ax bx c, C.select# ay by c, C.select# az bz c #)
+ (# W.select# ax bx c, W.select# ay by c, W.select# az bz c #)
{-# INLINE select_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)
+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 #-}
+-- Negate secp256k1 point.
+neg :: Projective -> Projective
+neg (Projective x y z) = Projective x (negate y) z
+
-- 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
-
-pattern P :: Mont -> Mont -> Mont -> Projective
-pattern P x y z = Projective (C.Montgomery x) (C.Montgomery y) (C.Montgomery z)
-{-# COMPLETE P #-}
+add p q = add_proj p q
-- algo 7, "complete addition formulas for prime order elliptic curves,"
-- renes et al, 2015
@@ -583,17 +591,20 @@ double (Projective (C.Montgomery ax) (C.Montgomery ay) (C.Montgomery az)) =
-- Timing-safe scalar multiplication of secp256k1 points.
mul :: Projective -> Wider -> Maybe Projective
-mul p sec@(Wider s) = do
+mul (P px py pz) sec@(Wider s) = do
guard (ge sec)
- pure $! loop (0 :: Int) _CURVE_ZERO _CURVE_G p s
+ let !(P gx gy gz) = _CURVE_G
+ !o = (# Limb 0x1000003D1##, Limb 0##, Limb 0##, Limb 0## #)
+ pure $!
+ loop (0 :: Int) (# Z, o, Z #) (# gx, gy, gz #) (# px, py, pz #) s
where
- loop !j !acc !f !d !_SECRET
- | j == _CURVE_Q_BITS = acc
+ loop !j !a@(# ax, ay, az #) !f !d !_SECRET
+ | j == _CURVE_Q_BITS = P ax ay az
| otherwise =
- let !nd = double d
+ let !nd = double# d
!(# nm, lsb_set #) = W.shr1_c# _SECRET
- !nacc = select_proj acc (add acc d) lsb_set -- XX
- !nf = select_proj (add f d) f lsb_set -- XX
+ !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 #-}
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
