commit dbfca99d6d99325c846ab35fbde595a34d355852
parent 07414ae8fe4328082bd5a5b7fc77948c689ea3df
Author: Jared Tobin <jared@jtobin.io>
Date: Tue, 28 Jan 2025 10:21:18 +0400
lib: extremely messy wip snapshot
Diffstat:
| A | .ghci | | | 2 | ++ |
| M | bench/Main.hs | | | 258 | +++++++++++++++++++++++++++++++++++++++++-------------------------------------- |
| M | bench/Weight.hs | | | 14 | ++++++++++++-- |
| M | lib/Data/Word/Extended.hs | | | 933 | +++++++++++++++++++++++++++++++++++++++++++++++++++---------------------------- |
| M | src/Main.hs | | | 36 | +++++++++++++++++++----------------- |
| M | test/Main.hs | | | 411 | +++++++++++++++++++++++++++++++++++++++++++++++++------------------------------ |
6 files changed, 1025 insertions(+), 629 deletions(-)
diff --git a/.ghci b/.ghci
@@ -0,0 +1,2 @@
+:set -XMagicHash
+:set prompt "> "
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -9,44 +9,23 @@ import qualified Data.Word.Extended as W
import Prelude hiding (or, and, div, mod)
import qualified Prelude (div)
-or_baseline :: Benchmark
-or_baseline = bench "or (baseline)" $ nf ((.|.) w0) w1 where
- w0, w1 :: Integer
- !w0 = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- !w1 = 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
-
-or :: Benchmark
-or = bench "or" $ nf (W.or w0) w1 where
- !w0 = W.to_word256
- 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- !w1 = W.to_word256
- 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
-
-and_baseline :: Benchmark
-and_baseline = bench "and (baseline)" $ nf ((.&.) w0) w1 where
- w0, w1 :: Integer
- !w0 = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- !w1 = 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+add_sub = bgroup "addition & subtraction" [
+ add
+ , sub
+ ]
-and :: Benchmark
-and = bench "and" $ nf (W.and w0) w1 where
- !w0 = W.to_word256
- 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- !w1 = W.to_word256
- 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+multiplication = bgroup "multiplication" [
+ mul
+ ]
-xor_baseline :: Benchmark
-xor_baseline = bench "xor (baseline)" $ nf ((.^.) w0) w1 where
- w0, w1 :: Integer
- !w0 = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- !w1 = 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+division = bgroup "division" [
+ -- quotrem_r#
+ ]
-xor :: Benchmark
-xor = bench "xor" $ nf (W.xor w0) w1 where
- !w0 = W.to_word256
- 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
- !w1 = W.to_word256
- 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+main :: IO ()
+main = defaultMain [
+ division
+ ]
add_baseline :: Benchmark
add_baseline = bench "add (baseline)" $ nf ((+) w0) w1 where
@@ -88,91 +67,124 @@ mul = bench "mul" $ nf (W.mul w0) w1 where
!w1 = W.to_word256
0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
-mul128_baseline :: Benchmark
-mul128_baseline = bench "mul128 (baseline)" $ nf ((*) w0) w1 where
- w0, w1 :: Integer
- !w0 = 0x7fffffffffffffffffffffffffffffed
- !w1 = 0x7ffffffffffffffbffffffffffffffed
-
-mul128 :: Benchmark
-mul128 = bench "mul128" $ nf (W.mul w0) w1 where
- !w0 = W.to_word256 0x7fffffffffffffffffffffffffffffed
- !w1 = W.to_word256 0x7ffffffffffffffbffffffffffffffed
-
-div_baseline :: Benchmark
-div_baseline = bench "div (baseline)" $ nf (Prelude.div w0) w1 where
- w0, w1 :: Integer
- !w0 = 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
- !w1 = 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
-
-div :: Benchmark
-div = bench "div" $ nf (W.div w0) w1 where
- !w0 = W.to_word256
- 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
- !w1 = W.to_word256
- 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
-
-div_baseline_small :: Benchmark
-div_baseline_small =
- bench "div, small (baseline)" $ nf (Prelude.div w0) w1
- where
- w0, w1 :: Integer
- !w0 = 0x7fffffed
- !w1 = 0x7ffbffed
-
-mod_baseline :: Benchmark
-mod_baseline = bench "mod (baseline)" $ nf (Prelude.rem w0) w1 where
- w0, w1 :: Integer
- !w0 = 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
- !w1 = 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
-
-mod :: Benchmark
-mod = bench "mod (pure)" $ nf (W.mod w0) w1 where
- !w0 = W.to_word256
- 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
- !w1 = W.to_word256
- 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
-
-arithmetic :: Benchmark
-arithmetic = bgroup "arithmetic" [
- add
- , sub
- , mul
- , div
- , mod
- ]
-
-baseline_arithmetic :: Benchmark
-baseline_arithmetic = bgroup "baseline arithmetic" [
- add_baseline
- , sub_baseline
- , mul_baseline
- , div_baseline
- , mod_baseline
- ]
-
-baseline_comparison :: Benchmark
-baseline_comparison = bgroup "baseline comparison" [
- add_baseline
- , add
- , sub_baseline
- , sub
- , mul_baseline
- , mul
- , div_baseline
- , div
- ]
-
-bits :: Benchmark
-bits = bgroup "bits" [
- and
- , or
- , xor
- ]
-
-main :: IO ()
-main = defaultMain [
- div
- , div_baseline
- ]
-
+-- or_baseline :: Benchmark
+-- or_baseline = bench "or (baseline)" $ nf ((.|.) w0) w1 where
+-- w0, w1 :: Integer
+-- !w0 = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+-- !w1 = 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+--
+-- or :: Benchmark
+-- or = bench "or" $ nf (W.or w0) w1 where
+-- !w0 = W.to_word256
+-- 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+-- !w1 = W.to_word256
+-- 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+--
+-- and_baseline :: Benchmark
+-- and_baseline = bench "and (baseline)" $ nf ((.&.) w0) w1 where
+-- w0, w1 :: Integer
+-- !w0 = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+-- !w1 = 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+--
+-- and :: Benchmark
+-- and = bench "and" $ nf (W.and w0) w1 where
+-- !w0 = W.to_word256
+-- 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+-- !w1 = W.to_word256
+-- 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+--
+-- xor_baseline :: Benchmark
+-- xor_baseline = bench "xor (baseline)" $ nf ((.^.) w0) w1 where
+-- w0, w1 :: Integer
+-- !w0 = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+-- !w1 = 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+--
+-- xor :: Benchmark
+-- xor = bench "xor" $ nf (W.xor w0) w1 where
+-- !w0 = W.to_word256
+-- 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffed
+-- !w1 = W.to_word256
+-- 0x7fffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffed
+--
+-- mul128_baseline :: Benchmark
+-- mul128_baseline = bench "mul128 (baseline)" $ nf ((*) w0) w1 where
+-- w0, w1 :: Integer
+-- !w0 = 0x7fffffffffffffffffffffffffffffed
+-- !w1 = 0x7ffffffffffffffbffffffffffffffed
+--
+-- mul128 :: Benchmark
+-- mul128 = bench "mul128" $ nf (W.mul w0) w1 where
+-- !w0 = W.to_word256 0x7fffffffffffffffffffffffffffffed
+-- !w1 = W.to_word256 0x7ffffffffffffffbffffffffffffffed
+--
+-- div_baseline :: Benchmark
+-- div_baseline = bench "div (baseline)" $ nf (Prelude.div w0) w1 where
+-- w0, w1 :: Integer
+-- !w0 = 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
+-- !w1 = 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
+--
+-- div :: Benchmark
+-- div = bench "div" $ nf (W.div w0) w1 where
+-- !w0 = W.to_word256
+-- 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
+-- !w1 = W.to_word256
+-- 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
+--
+-- div_baseline_small :: Benchmark
+-- div_baseline_small =
+-- bench "div, small (baseline)" $ nf (Prelude.div w0) w1
+-- where
+-- w0, w1 :: Integer
+-- !w0 = 0x7fffffed
+-- !w1 = 0x7ffbffed
+--
+-- mod_baseline :: Benchmark
+-- mod_baseline = bench "mod (baseline)" $ nf (Prelude.rem w0) w1 where
+-- w0, w1 :: Integer
+-- !w0 = 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
+-- !w1 = 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
+--
+-- mod :: Benchmark
+-- mod = bench "mod (pure)" $ nf (W.mod w0) w1 where
+-- !w0 = W.to_word256
+-- 0x41cf50c7d0d65afabcf5ba37750dba71c7db29ec9f20a216d3ef013a59b9188a
+-- !w1 = W.to_word256
+-- 0x066bd4c3c10e30260cb6e7832af25f15527b089b258a1fef13b6eec3ce73bf06
+--
+-- arithmetic :: Benchmark
+-- arithmetic = bgroup "arithmetic" [
+-- add
+-- , sub
+-- , mul
+-- , div
+-- , mod
+-- ]
+--
+-- baseline_arithmetic :: Benchmark
+-- baseline_arithmetic = bgroup "baseline arithmetic" [
+-- add_baseline
+-- , sub_baseline
+-- , mul_baseline
+-- , div_baseline
+-- , mod_baseline
+-- ]
+--
+-- baseline_comparison :: Benchmark
+-- baseline_comparison = bgroup "baseline comparison" [
+-- add_baseline
+-- , add
+-- , sub_baseline
+-- , sub
+-- , mul_baseline
+-- , mul
+-- , div_baseline
+-- , div
+-- ]
+--
+-- bits :: Benchmark
+-- bits = bgroup "bits" [
+-- and
+-- , or
+-- , xor
+-- ]
+--
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -32,6 +32,16 @@ main = W.mainWith $ do
W.func "sub" (E.sub w0) w1
W.func "mul (baseline)" ((*) i0) i1
W.func "mul" (E.mul w0) w1
- W.func "div (baseline)" (Prelude.div i2) i3
- W.func "div" (E.div w2) w3
+ W.func "quotrem_r" (E.quotrem_r 2 4) 4
+
+-- main :: IO ()
+-- main = W.mainWith $ do
+-- W.func "add (baseline)" ((+) i0) i1
+-- W.func "add" (E.add w0) w1
+-- W.func "sub (baseline)" ((-) i0) i1
+-- W.func "sub" (E.sub w0) w1
+-- W.func "mul (baseline)" ((*) i0) i1
+-- W.func "mul" (E.mul w0) w1
+-- W.func "div (baseline)" (Prelude.div i2) i3
+-- W.func "div" (E.div w2) w3
diff --git a/lib/Data/Word/Extended.hs b/lib/Data/Word/Extended.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
-- |
@@ -13,49 +14,51 @@
-- Large fixed-width words, complete with support for conversion,
-- comparison, bitwise operations, arithmetic, and modular arithmetic.
-module Data.Word.Extended (
- Word256(..)
- , zero
- , one
-
- -- * Conversion
- , to_integer
- , to_word256
-
- -- * Comparison
- , lt
- , gt
- , is_zero
-
- -- * Bit Operations
- , or
- , and
- , xor
-
- -- * Arithmetic
- , add
- , sub
- , mul
- , div
-
- -- * Modular Arithmetic
- , mod
-
- -- for testing/benchmarking
- , Word128(..)
- , quotrem
- , quotrem_r
- , quotrem_by1
- , quotrem_2by1
- , quotrem_knuth
- , recip_2by1
- , to_word512
- , word512_to_integer
- , mul_512
- , mul_c
- , umul_hop
- , umul_step
- ) where
+-- module Data.Word.Extended (
+-- Word256(..)
+-- , zero
+-- , one
+--
+-- -- * Conversion
+-- , to_integer
+-- , to_word256
+--
+-- -- * Comparison
+-- , lt
+-- , gt
+-- , is_zero
+--
+-- -- * Bit Operations
+-- , or
+-- , and
+-- , xor
+--
+-- -- * Arithmetic
+-- , add
+-- , sub
+-- , mul
+-- , div
+--
+-- -- * Modular Arithmetic
+-- , mod
+--
+-- -- for testing/benchmarking
+-- , Word128(..)
+-- , quotrem
+-- , quotrem_r
+-- , quotrem_by1
+-- , quotrem_2by1
+-- , quotrem_knuth
+-- , recip_2by1
+-- , to_word512
+-- , word512_to_integer
+-- , mul_512
+-- , mul_c
+-- , umul_hop
+-- , umul_step
+-- ) where
+
+module Data.Word.Extended where
import Control.DeepSeq
import Control.Monad.Primitive
@@ -63,8 +66,9 @@ import Control.Monad.ST
import Data.Bits ((.|.), (.&.), (.<<.), (.>>.), (.^.))
import qualified Data.Bits as B
import qualified Data.Primitive.PrimArray as PA
-import Data.Word (Word64)
+import GHC.Exts
import GHC.Generics
+import GHC.Word
import Prelude hiding (div, mod, or, and)
fi :: (Integral a, Num b) => a -> b
@@ -275,6 +279,13 @@ add_c w64_0 w64_1 c =
| otherwise = 0
in P s n
+add_c# :: Word64# -> Word64# -> Word64# -> (# Word64#, Word64# #)
+add_c# w64_0 w64_1 c =
+ let !s = plusWord64# (plusWord64# w64_0 w64_1) c
+ !n | isTrue# (orI# (ltWord64# s w64_0) (ltWord64# s w64_1)) = 1#
+ | otherwise = 0#
+ in (# s, wordToWord64# (int2Word# n) #)
+
-- addition with overflow indication
add_of :: Word256 -> Word256 -> Word320
add_of (Word256 a0 a1 a2 a3) (Word256 b0 b1 b2 b3) =
@@ -284,13 +295,29 @@ add_of (Word256 a0 a1 a2 a3) (Word256 b0 b1 b2 b3) =
!(P s3 c3) = add_c a3 b3 c2
in Word320 (Word256 s0 s1 s2 s3) c3
+add_of#
+ :: (# Word64#, Word64#, Word64#, Word64# #)
+ -> (# Word64#, Word64#, Word64#, Word64# #)
+ -> (# Word64#, Word64#, Word64#, Word64#, Word64# #)
+add_of# (# a0, a1, a2, a3 #)
+ (# b0, b1, b2, b3 #) =
+ let !(# s0, c0 #) = add_c# a0 b0 (wordToWord64# 0##)
+ !(# s1, c1 #) = add_c# a1 b1 c0
+ !(# s2, c2 #) = add_c# a2 b2 c1
+ !(# s3, c3 #) = add_c# a3 b3 c2
+ in (# s0, s1, s2, s3, c3 #)
+
-- | Addition on 'Word256' values, with overflow.
--
-- >>> to_word256 0xFFFFFFFFFF `add` to_word256 0xFFFFFF
-- 18446742974181146625
add :: Word256 -> Word256 -> Word256
-add w0 w1 = s where
- !(Word320 s _) = add_of w0 w1
+add (Word256 (W64# a0) (W64# a1) (W64# a2) (W64# a3))
+ (Word256 (W64# b0) (W64# b1) (W64# b2) (W64# b3)) =
+ let !(# c0, c1, c2, c3, _ #) = add_of#
+ (# a0, a1, a2, a3 #)
+ (# b0, b1, b2, b3 #)
+ in Word256 (W64# c0) (W64# c1) (W64# c2) (W64# c3)
-- subtract-with-borrow
--
@@ -306,6 +333,13 @@ sub_b w64_0 w64_1 b =
| otherwise = 0
in P d n
+sub_b# :: Word64# -> Word64# -> Word64# -> (# Word64#, Word64# #)
+sub_b# w64_0 w64_1 b =
+ let !d = subWord64# (subWord64# w64_0 w64_1) b
+ !n | isTrue# (ltWord64# w64_0 (plusWord64# w64_1 b)) = wordToWord64# 1##
+ | otherwise = wordToWord64# 0##
+ in (# d, n #)
+
sub_of :: Word256 -> Word256 -> Word320
sub_of (Word256 a0 a1 a2 a3) (Word256 b0 b1 b2 b3) =
let !(P s0 c0) = sub_b a0 b0 0
@@ -314,13 +348,29 @@ sub_of (Word256 a0 a1 a2 a3) (Word256 b0 b1 b2 b3) =
!(P s3 c3) = sub_b a3 b3 c2
in Word320 (Word256 s0 s1 s2 s3) c3
+sub_of#
+ :: (# Word64#, Word64#, Word64#, Word64# #)
+ -> (# Word64#, Word64#, Word64#, Word64# #)
+ -> (# Word64#, Word64#, Word64#, Word64#, Word64# #)
+sub_of# (# a0, a1, a2, a3 #)
+ (# b0, b1, b2, b3 #) =
+ let !(# s0, c0 #) = sub_b# a0 b0 (wordToWord64# 0##)
+ !(# s1, c1 #) = sub_b# a1 b1 c0
+ !(# s2, c2 #) = sub_b# a2 b2 c1
+ !(# s3, c3 #) = sub_b# a3 b3 c2
+ in (# s0, s1, s2, s3, c3 #)
+
-- | Subtraction on 'Word256' values.
--
-- >>> to_word256 0xFFFFFFFFFF `sub` to_word256 0xFFFFFF
-- 1099494850560
sub :: Word256 -> Word256 -> Word256
-sub w0 w1 = d where
- !(Word320 d _) = sub_of w0 w1
+sub (Word256 (W64# a0) (W64# a1) (W64# a2) (W64# a3))
+ (Word256 (W64# b0) (W64# b1) (W64# b2) (W64# b3)) =
+ let !(# c0, c1, c2, c3, _ #) = sub_of#
+ (# a0, a1, a2, a3 #)
+ (# b0, b1, b2, b3 #)
+ in Word256 (W64# c0) (W64# c1) (W64# c2) (W64# c3)
-- multiplication -------------------------------------------------------------
@@ -348,6 +398,26 @@ mul_c x y =
!lo = x * y
in P hi lo
+mul_c# :: Word64# -> Word64# -> (# Word64#, Word64# #)
+mul_c# x y =
+ let !mask32 = wordToWord64# 0xffffffff##
+ !x0 = and64# x mask32
+ !y0 = and64# y mask32
+ !x1 = uncheckedShiftRL64# x 32#
+ !y1 = uncheckedShiftRL64# y 32#
+
+ !w0 = timesWord64# x0 y0
+ !t = plusWord64# (timesWord64# x1 y0) (uncheckedShiftRL64# w0 32#)
+ !w1 = and64# t mask32
+ !w2 = uncheckedShiftRL64# t 32#
+ !w1_1 = plusWord64# w1 (timesWord64# x0 y1)
+
+ !hi = plusWord64#
+ (timesWord64# x1 y1)
+ (plusWord64# w2 (uncheckedShiftRL64# w1_1 32#))
+ !lo = timesWord64# x y
+ in (# hi, lo #)
+
-- (hi * 2 ^ 64 + lo) = z + (x * y)
umul_hop :: Word64 -> Word64 -> Word64 -> Word128
umul_hop z x y =
@@ -356,6 +426,13 @@ umul_hop z x y =
!(P hi _) = add_c hi_0 0 c
in P hi lo
+umul_hop# :: Word64# -> Word64# -> Word64# -> (# Word64#, Word64# #)
+umul_hop# z x y =
+ let !(# hi_0, lo_0 #) = mul_c# x y
+ !(# lo, c #) = add_c# lo_0 z (wordToWord64# 0##)
+ !(# hi, _ #) = add_c# hi_0 (wordToWord64# 0##) c
+ in (# hi, lo #)
+
-- (hi * 2 ^ 64 + lo) = z + (x * y) + c
umul_step :: Word64 -> Word64 -> Word64 -> Word64 -> Word128
umul_step z x y c =
@@ -366,241 +443,51 @@ umul_step z x y c =
!(P hi _) = add_c hi_1 0 c_1
in P hi lo
+umul_step#
+ :: Word64#
+ -> Word64#
+ -> Word64#
+ -> Word64#
+ -> (# Word64#, Word64# #)
+umul_step# z x y c =
+ let !(# hi_0, lo_0 #) = mul_c# x y
+ !(# lo_1, c_0 #) = add_c# lo_0 c (wordToWord64# 0##)
+ !(# hi_1, _ #) = add_c# hi_0 (wordToWord64# 0##) c_0
+ !(# lo, c_1 #) = add_c# lo_1 z (wordToWord64# 0##)
+ !(# hi, _ #) = add_c# hi_1 (wordToWord64# 0##) c_1
+ in (# hi, lo #)
+
-- | Multiplication on 'Word256' values, with overflow.
--
-- >>> to_word256 0xFFFFFFFFFF `mul` to_word256 0xFFFFFF
-- 18446742974181146625
mul :: Word256 -> Word256 -> Word256
-mul (Word256 a0 a1 a2 a3) (Word256 b0 b1 b2 b3) =
- let !(P c0_0 s0) = mul_c a0 b0
- !(P c0_1 r0) = umul_hop c0_0 a1 b0
- !(P c0_2 r1) = umul_hop c0_1 a2 b0
-
- !(P c1_0 s1) = umul_hop r0 a0 b1
- !(P c1_1 r2) = umul_step r1 a1 b1 c1_0
-
- !(P c2 s2) = umul_hop r2 a1 b1
-
- !s3 = a3 * b0 + a2 * b1 + a0 * b3 + a1 * b2 + c0_2 + c1_1 + c2
- in Word256 s0 s1 s2 s3
-
--- | Multiplication on 'Word256' values, to 'Word512'.
-mul_512 :: Word256 -> Word256 -> Word512
-mul_512 (Word256 x0 x1 x2 x3) (Word256 y0 y1 y2 y3) =
- let !(P c4_0 r0) = mul_c x0 y0
- !(P c4_1 r0_1) = umul_hop c4_0 x1 y0
- !(P c4_2 r0_2) = umul_hop c4_1 x2 y0
- !(P c4 r0_3) = umul_hop c4_2 x3 y0
-
- !(P c5_0 r1) = umul_hop r0_1 x0 y1
- !(P c5_1 r1_2) = umul_step r0_2 x1 y1 c5_0
- !(P c5_2 r1_3) = umul_step r0_3 x2 y1 c5_1
- !(P c5 r1_4) = umul_step c4 x3 y1 c5_2
-
- !(P c6_0 r2) = umul_hop r1_2 x0 y2
- !(P c6_1 r2_3) = umul_step r1_3 x1 y2 c6_0
- !(P c6_2 r2_4) = umul_step r1_4 x2 y2 c6_1
- !(P c6 r2_5) = umul_step c5 x3 y2 c6_2
-
- !(P c7_0 r3) = umul_hop r2_3 x0 y3
- !(P c7_1 r4) = umul_step r2_4 x1 y3 c7_0
- !(P c7_2 r5) = umul_step r2_5 x2 y3 c7_1
- !(P r7 r6) = umul_step c6 x3 y3 c7_2
- in Word512 r0 r1 r2 r3 r4 r5 r6 r7
+mul (Word256 (W64# a0) (W64# a1) (W64# a2) (W64# a3))
+ (Word256 (W64# b0) (W64# b1) (W64# b2) (W64# b3)) =
+ let !(# c0_0, s0 #) = mul_c# a0 b0
+ !(# c0_1, r0 #) = umul_hop# c0_0 a1 b0
+ !(# c0_2, r1 #) = umul_hop# c0_1 a2 b0
+ !(# c1_0, s1 #) = umul_hop# r0 a0 b1
+ !(# c1_1, r2 #) = umul_step# r1 a1 b1 c1_0
+ !(# c2, s2 #) = umul_hop# r2 a1 b1
+ !s3 = plusWord64# (timesWord64# a3 b0)
+ (plusWord64# (timesWord64# a2 b1)
+ (plusWord64# (timesWord64# a0 b3)
+ (plusWord64# (timesWord64# a1 b2)
+ (plusWord64# c0_2 (plusWord64# c1_1 c2)))))
+ in Word256 (W64# s0) (W64# s1) (W64# s2) (W64# s3)
-- division -------------------------------------------------------------------
--- primitive -------------------------
+newtype Memory m = Memory (PA.MutablePrimArray (PrimState m) Word64)
+ deriving Generic
--- x =- y * m
--- requires (len x - x_offset) >= len y > 0
-sub_mul
- :: PrimMonad m
- => PA.MutablePrimArray (PrimState m) Word64
- -> Int
- -> Word256
- -> Int
- -> Word64
- -> m Word64
-sub_mul x x_offset (Word256 y0 y1 y2 y3) l m = do
- let loop !j !borrow
- | j == l = pure borrow
- | otherwise = do
- !x_j <- PA.readPrimArray x (j + x_offset)
- let !(P s carry1) = sub_b x_j borrow 0
- !(P ph pl) = case j of
- 0 -> mul_c y0 m
- 1 -> mul_c y1 m
- 2 -> mul_c y2 m
- 3 -> mul_c y3 m
- _ -> error "ppad-fixed (sub_mul): bad index"
- !(P t carry2) = sub_b s pl 0
- PA.writePrimArray x (j + x_offset) t
- loop (succ j) (ph + carry1 + carry2)
- loop 0 0
-
-quotrem_by1
- :: PrimMonad m
- => PA.MutablePrimArray (PrimState m) Word64
- -> PA.PrimArray Word64
- -> Word64
- -> m Word64
-quotrem_by1 quo u d = do
- let !rec = recip_2by1 d
- !lu = PA.sizeofPrimArray u
- !r0 = PA.indexPrimArray u (lu - 1)
- loop !j !racc
- | j < 0 = pure racc
- | otherwise = do
- let uj = PA.indexPrimArray u j
- !(P qj rnex) = quotrem_2by1 racc uj d rec
- PA.writePrimArray quo j qj
- loop (pred j) rnex
- loop (lu - 2) r0
-
-add_to
- :: PrimMonad m
- => PA.MutablePrimArray (PrimState m) Word64
- -> Int
- -> Word256
- -> Int
- -> m Word64
-add_to x x_offset (Word256 y0 y1 y2 y3) l = do
- let loop !j !cacc
- | j == l = pure cacc
- | otherwise = do
- xj <- PA.readPrimArray x (j + x_offset)
- let !(P nex carry) = case j of
- 0 -> add_c xj y0 cacc
- 1 -> add_c xj y1 cacc
- 2 -> add_c xj y2 cacc
- 3 -> add_c xj y3 cacc
- _ -> error "ppad-fixed (add_to): bad index"
- PA.writePrimArray x (j + x_offset) nex
- loop (succ j) carry
- loop 0 0
-
-quotrem
- :: PrimMonad m
- => PA.MutablePrimArray (PrimState m) Word64 -- quotient (potentially large)
- -> PA.PrimArray Word64 -- dividend (potentially large)
- -> Word256 -- divisor (256-bit)
- -> m Word256 -- remainder (256-bit)
-quotrem quo u (Word256 d0 d1 d2 d3) = do
- let -- normalize divisor
- (dlen, shift)
- | d3 /= 0 = (4, B.countLeadingZeros d3)
- | d2 /= 0 = (3, B.countLeadingZeros d2)
- | d1 /= 0 = (2, B.countLeadingZeros d1)
- | otherwise = (1, B.countLeadingZeros d0) -- zero not checked
- dn_3 = (d3 .<<. shift) .|. (d2 .>>. (64 - shift))
- dn_2 = (d2 .<<. shift) .|. (d1 .>>. (64 - shift))
- dn_1 = (d1 .<<. shift) .|. (d0 .>>. (64 - shift))
- dn_0 = d0 .<<. shift
- !dn = Word256 dn_0 dn_1 dn_2 dn_3
- -- get size of normalized dividend
- lu = PA.sizeofPrimArray u
- ulen = let loop !j
- | j < 0 = 0
- | PA.indexPrimArray u j /= 0 = j + 1
- | otherwise = loop (j - 1)
- in loop (lu - 1)
- if ulen < dlen
- then do
- -- u always has size at least 4
- let u0 = PA.indexPrimArray u 0; u1 = PA.indexPrimArray u 1
- u2 = PA.indexPrimArray u 2; u3 = PA.indexPrimArray u 3
- pure (Word256 u0 u1 u2 u3)
- else do
- -- normalize dividend
- !un <- PA.newPrimArray (ulen + 1)
- PA.setPrimArray un 0 (ulen + 1) 0
- let u_hi = PA.indexPrimArray u (ulen - 1)
- PA.writePrimArray un ulen (u_hi .>>. (64 - shift))
- let normalize_u !j !uj
- | j == 0 =
- PA.writePrimArray un 0 (PA.indexPrimArray u 0 .<<. shift)
- | otherwise = do
- let !uj_1 = PA.indexPrimArray u (j - 1)
- !val = (uj .<<. shift) .|. (uj_1 .>>. (64 - shift))
- PA.writePrimArray un j val
- normalize_u (pred j) uj_1
- normalize_u (ulen - 1) u_hi
- if dlen == 1
- then do
- -- normalized divisor is small
- !un_final <- PA.unsafeFreezePrimArray un
- !r <- quotrem_by1 quo un_final dn_0
- pure (Word256 (r .>>. shift) 0 0 0)
- else do
- quotrem_knuth quo un dn dlen
- -- compute unnormalized remainder
- let unn_rem !j !(Word256 r0 r1 r2 r3) !un_j
- | j == dlen = pure $ case j of
- 2 -> Word256 r0 (un_j .>>. shift) r2 r3
- 3 -> Word256 r0 r1 (un_j .>>. shift) r3
- 4 -> Word256 r0 r1 r2 (un_j .>>. shift)
- _ -> error "ppad-fixed (quotrem): bad index"
- | otherwise = do
- un_j_1 <- PA.readPrimArray un (j + 1)
- let !unn_j = (un_j .>>. shift) .|. (un_j_1 .<<. (64 - shift))
- !nacc = case j of
- 0 -> Word256 unn_j 0 0 0
- 1 -> Word256 r0 unn_j 0 0
- 2 -> Word256 r0 r1 unn_j 0
- 3 -> Word256 r0 r1 r2 unn_j
- _ -> error "ppad-fixed (quotrem): bad index"
- unn_rem (j + 1) nacc un_j_1
- !un_0 <- PA.readPrimArray un 0
- unn_rem 0 zero un_0
-
-quotrem_knuth
- :: PrimMonad m
- => PA.MutablePrimArray (PrimState m) Word64 -- quotient (potentially large)
- -> PA.MutablePrimArray (PrimState m) Word64 -- normalized dividend
- -> Word256 -- normalized divisor
- -> Int -- words in normalized divisor
- -> m ()
-quotrem_knuth quo u d@(Word256 d0 d1 d2 d3) ld = do
- !lu <- PA.getSizeofMutablePrimArray u
- let (dh, dl) = case ld of
- 4 -> (d3, d2)
- 3 -> (d2, d1)
- 2 -> (d1, d0)
- _ -> error "ppad-fixed (quotrem_knuth): bad index"
- !rec = recip_2by1 dh
- loop !j
- | j < 0 = pure ()
- | otherwise = do
- !u2 <- PA.readPrimArray u (j + ld)
- !u1 <- PA.readPrimArray u (j + ld - 1)
- !u0 <- PA.readPrimArray u (j + ld - 2)
- let !qhat
- | u2 >= dh = 0xffff_ffff_ffff_ffff
- | otherwise =
- let !(P qh rh) = quotrem_2by1 u2 u1 dh rec
- !(P ph pl) = mul_c qh dl
- in if ph > rh || (ph == rh && pl > u0)
- then qh - 1
- else qh
-
- borrow <- sub_mul u j d ld qhat
- PA.writePrimArray u (j + ld) (u2 - borrow)
- if u2 < borrow
- then do
- let !qh = qhat - 1
- r <- add_to u j d ld
- PA.writePrimArray u (j + ld) r
- PA.writePrimArray quo j qh
- else
- PA.writePrimArray quo j qhat
- loop (pred j)
- loop (lu - ld - 1)
+instance PrimMonad m => NFData (Memory m)
-- quotient, remainder of (hi, lo) divided by y
-- translated from Div64 in go's math/bits package
--
--- x86-64 (RDX:RAX) DIVQ
+-- x86-64 (RDX:RAX) DIV
quotrem_r :: Word64 -> Word64 -> Word64 -> Word128
quotrem_r hi lo y_0
| y_0 == 0 = error "ppad-fixed: division by zero"
@@ -644,69 +531,449 @@ quotrem_r hi lo y_0
| otherwise = qa
in go q_acc rhat_acc
+quotrem_2by1#
+ :: Word64# -> Word64# -> Word64# -> Word64# -> (# Word64#, Word64# #)
+quotrem_2by1# uh ul d rec =
+ let !(# qh_0, ql #) = mul_c# rec uh
+ !(# ql_0, c #) = add_c# ql ul (wordToWord64# 0##)
+ !(# qh_1_l, _ #) = add_c# qh_0 uh c
+ !qh_1 = plusWord64# qh_1_l (wordToWord64# 1##)
+ !r = subWord64# ul (timesWord64# qh_1 d)
+
+ !(# qh_y, r_y #)
+ | isTrue# (geWord64# r ql_0) = (# qh_1_l, plusWord64# r d #)
+ | otherwise = (# qh_1, r #)
+
+ in if isTrue# (geWord64# r_y d)
+ then (# plusWord64# qh_y (wordToWord64# 1##), subWord64# r_y d #)
+ else (# qh_y, r_y #)
+
+recip_2by1' :: Word64 -> Word64
+recip_2by1' (W64# d) = W64# (recip_2by1# d)
+
+recip_2by1# :: Word64# -> Word64#
+recip_2by1# d =
+ let !(# r, _ #) =
+ quotrem_r# (not64# d) (wordToWord64# 0xffffffffffffffff##) d
+ in r
+
recip_2by1 :: Word64 -> Word64
recip_2by1 d = r where
!(P r _) = quotrem_r (B.complement d) 0xffffffffffffffff d
-quotrem_2by1 :: Word64 -> Word64 -> Word64 -> Word64 -> Word128
-quotrem_2by1 uh ul d rec =
- let !(P qh_0 ql) = mul_c rec uh
- !(P ql_0 c) = add_c ql ul 0
- !(P (succ -> qh_1) _) = add_c qh_0 uh c
- !r = ul - qh_1 * d
-
- !(P qh_y r_y)
- | r > ql_0 = P (qh_1 - 1) (r + d)
- | otherwise = P qh_1 r
-
- in if r_y >= d
- then P (qh_y + 1) (r_y - d)
- else P qh_y r_y
-
-
-div :: Word256 -> Word256 -> Word256
-div u@(Word256 u0 u1 u2 u3) d@(Word256 d0 _ _ _)
- | is_zero d || d `gt` u = zero -- ?
- | u == d = one
- | is_word64 u = Word256 (u0 `quot` d0) 0 0 0
- | otherwise = runST $ do
- -- allocate quotient
- quo <- PA.newPrimArray 4
- PA.setPrimArray quo 0 4 0
- -- allocate dividend
- u_arr <- PA.newPrimArray 4
- PA.setPrimArray u_arr 0 4 0
- PA.writePrimArray u_arr 0 u0
- PA.writePrimArray u_arr 1 u1
- PA.writePrimArray u_arr 2 u2
- PA.writePrimArray u_arr 3 u3
- u_final <- PA.unsafeFreezePrimArray u_arr
- _ <- quotrem quo u_final d
- q0 <- PA.readPrimArray quo 0
- q1 <- PA.readPrimArray quo 1
- q2 <- PA.readPrimArray quo 2
- q3 <- PA.readPrimArray quo 3
- pure (Word256 q0 q1 q2 q3)
-
--- | Modulo operation on 'Word256' values.
---
--- >>> to_word256 0xFFFFFFFFFF `mod` to_word256 0xFFFFFF
--- 65535
-mod :: Word256 -> Word256 -> Word256
-mod u@(Word256 u0 u1 u2 u3) d@(Word256 d0 _ _ _)
- | is_zero d || d `gt` u = zero -- ?
- | u == d = one
- | is_word64 u = Word256 (u0 `quot` d0) 0 0 0
- | otherwise = runST $ do
- -- allocate quotient
- quo <- PA.newPrimArray 4
- PA.setPrimArray quo 0 4 0
- -- allocate dividend
- u_arr <- PA.newPrimArray 4
- PA.setPrimArray u_arr 0 4 0
- PA.writePrimArray u_arr 0 u0
- PA.writePrimArray u_arr 1 u1
- PA.writePrimArray u_arr 2 u2
- PA.writePrimArray u_arr 3 u3
- u_final <- PA.unsafeFreezePrimArray u_arr
- quotrem quo u_final d
+quotrem_r# :: Word64# -> Word64# -> Word64# -> (# Word64#, Word64# #)
+quotrem_r# hi lo y_0
+ | isTrue# (eqWord64# y_0 (wordToWord64# 0##)) =
+ error "ppad-fixed (quotrem_r): division by zero"
+ | isTrue# (leWord64# y_0 hi) =
+ error "ppad-fixed: overflow"
+ | isTrue# (eqWord64# hi (wordToWord64# 0##)) =
+ (# quotWord64# lo y_0, remWord64# lo y_0 #)
+ | otherwise =
+ let !s = int64ToInt# (word64ToInt64# (wordToWord64# (clz64# y_0)))
+ !y = uncheckedShiftL64# y_0 s
+
+ !yn1 = uncheckedShiftRL64# y 32#
+ !yn0 = and64# y mask32
+ !un32 = or64#
+ (uncheckedShiftL64# hi s)
+ (if (isTrue# (s ==# 0#))
+ then wordToWord64# 0##
+ else uncheckedShiftRL64# lo (64# -# s))
+ !un10 = uncheckedShiftL64# lo s
+ !un1 = uncheckedShiftRL64# un10 32#
+ !un0 = and64# un10 mask32
+ !q1 = quotWord64# un32 yn1
+ !rhat = subWord64# un32 (timesWord64# q1 yn1)
+
+ !q1_l = q_loop# q1 rhat yn0 yn1 un1
+
+ !un21 = subWord64#
+ (plusWord64# (timesWord64# un32 two32) un1)
+ (timesWord64# q1_l y)
+ !q0 = quotWord64# un21 yn1
+ !rhat_n = subWord64# un21 (timesWord64# q0 yn1)
+
+ !q0_l = q_loop# q0 rhat_n yn0 yn1 un0
+
+ !q = plusWord64# (timesWord64# q1_l two32) q0_l
+ !r = uncheckedShiftRL64#
+ (subWord64#
+ (plusWord64# (timesWord64# un21 two32) un0)
+ (timesWord64# q0_l y))
+ s
+ in (# q, r #)
+ where
+ !two32 = wordToWord64# 0x100000000##
+ !mask32 = wordToWord64# 0x0ffffffff##
+
+ q_loop# !q_acc !rhat_acc !yn_0 !yn_1 !un =
+ let go# !qa !rha
+ | isTrue# (orI#
+ (geWord64# qa two32)
+ (gtWord64#
+ (timesWord64# qa yn_0)
+ (plusWord64# (timesWord64# two32 rha) un))) =
+ let !qn = subWord64# qa (wordToWord64# 1##)
+ !rhn = plusWord64# rha yn_1
+ in if isTrue# (geWord64# rhn two32)
+ then qn
+ else go# qn rhn
+ | otherwise = qa
+ in go# q_acc rhat_acc
+ {-# INLINE q_loop# #-}
+
+-- uses manually-unboxed internals
+quotrem_r' :: Word64 -> Word64 -> Word64 -> Word128
+quotrem_r' (W64# hi) (W64# lo) (W64# y_0) =
+ let !(# q, r #) = quotrem_r# hi lo y_0
+ in P (W64# q) (W64# r)
+
+quot_r# :: Word64# -> Word64# -> Word64# -> Word64#
+quot_r# hi lo y_0
+ | isTrue# (eqWord64# y_0 (wordToWord64# 0##)) =
+ error "ppad-fixed (quotrem_r): division by zero"
+ | isTrue# (leWord64# y_0 hi) =
+ error "ppad-fixed: overflow"
+ | isTrue# (eqWord64# hi (wordToWord64# 0##)) = quotWord64# lo y_0
+ | otherwise =
+ let !s = int64ToInt# (word64ToInt64# (wordToWord64# (clz64# y_0)))
+ !y = uncheckedShiftL64# y_0 s
+
+ !yn1 = uncheckedShiftRL64# y 32#
+ !yn0 = and64# y mask32
+ !un32 = or64#
+ (uncheckedShiftL64# hi s)
+ (uncheckedShiftRL64# lo (64# -# s))
+ !un10 = uncheckedShiftL64# lo s
+ !un1 = uncheckedShiftRL64# un10 32#
+ !un0 = and64# un10 mask32
+ !q1 = quotWord64# un32 yn1
+ !rhat = subWord64# un32 (timesWord64# q1 yn1)
+
+ !q1_l = q_loop# q1 rhat yn0 yn1 un1
+
+ !un21 = subWord64#
+ (plusWord64# (timesWord64# un32 two32) un1)
+ (timesWord64# q1_l y)
+ !q0 = quotWord64# un21 yn1
+ !rhat_n = subWord64# un21 (timesWord64# q0 yn1)
+
+ !q0_l = q_loop# q0 rhat_n yn0 yn1 un0
+
+ in plusWord64# (timesWord64# q1_l two32) q0_l
+ where
+ !two32 = wordToWord64# 0x100000000##
+ !mask32 = wordToWord64# 0x0ffffffff##
+
+ q_loop# !q_acc !rhat_acc !yn_0 !yn_1 !un =
+ let go# !qa !rha
+ | isTrue# (orI#
+ (geWord64# qa two32)
+ (gtWord64#
+ (timesWord64# qa yn_0)
+ (plusWord64# (timesWord64# two32 rha) un))) =
+ let !qn = subWord64# qa (wordToWord64# 1##)
+ !rhn = plusWord64# rha yn_1
+ in if isTrue# (geWord64# rhn two32)
+ then qn
+ else go# qn rhn
+ | otherwise = qa
+ in go# q_acc rhat_acc
+ {-# INLINE q_loop# #-}
+
+-- -- remainder by normalized word
+-- rem_by_norm_word
+-- :: PrimMonad m
+-- => Memory m -- memory
+-- -> Int -- normalized dividend offset
+-- -> Int -- length of normalized dividend
+-- -> Int -- normalized divisor offset
+-- -> m Word64 -- remainder
+-- rem_by_norm_word (Memory buf) un_offset lun dn_offset = do
+-- d <- PA.readPrimArray buf dn_offset
+-- let rec = recip_2by1 d
+-- r0 <- PA.readPrimArray buf (un_offset + lun - 1)
+-- let loop !j !racc
+-- | j < 0 = pure racc
+-- | otherwise = do
+-- !uj <- PA.readPrimArray buf (un_offset + j)
+-- let !(P _ rnex) = quotrem_2by1 racc uj d rec
+-- -- PA.writePrimArray buf j qj
+-- loop (j - 1) rnex
+-- loop (lun - 2) r0
+--
+-- -- quotient & remainder by normalized word
+-- quotrem_by_norm_word
+-- :: PrimMonad m
+-- => Memory m -- memory
+-- -> Int -- normalized dividend offset
+-- -> Int -- length of normalized dividend
+-- -> Int -- normalized divisor offset
+-- -> m Word64 -- remainder
+-- quotrem_by_norm_word (Memory buf) un_offset lun dn_offset = do
+-- d <- PA.readPrimArray buf dn_offset
+-- let rec = recip_2by1 d
+-- r0 <- PA.readPrimArray buf (un_offset + lun - 1)
+-- let loop !j !racc
+-- | j < 0 = pure racc
+-- | otherwise = do
+-- !uj <- PA.readPrimArray buf (un_offset + j)
+-- let !(P _ rnex) = quotrem_2by1 racc uj d rec
+-- PA.writePrimArray buf j qj
+-- loop (j - 1) rnex
+-- loop (lun - 2) r0
+
+-- x =- y * m
+-- requires (len x - x_offset) >= len y > 0
+sub_mul
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> Int
+ -> PA.PrimArray Word64
+ -> Int
+ -> Word64
+ -> m Word64
+sub_mul x x_offset y l m = do
+ let loop !j !borrow
+ | j == l = pure borrow
+ | otherwise = do
+ !x_j <- PA.readPrimArray x (j + x_offset)
+ let !y_j = PA.indexPrimArray y j
+ let !(P s carry1) = sub_b x_j borrow 0
+ !(P ph pl) = mul_c y_j m
+ !(P t carry2) = sub_b s pl 0
+ PA.writePrimArray x (j + x_offset) t
+ loop (succ j) (ph + carry1 + carry2)
+ loop 0 0
+
+-- quotrem_by1
+-- :: PrimMonad m
+-- => PA.MutablePrimArray (PrimState m) Word64
+-- -> PA.PrimArray Word64
+-- -> Word64
+-- -> m Word64
+-- quotrem_by1 quo u d = do
+-- let !rec = recip_2by1 d
+-- !lu = PA.sizeofPrimArray u
+-- !r0 = PA.indexPrimArray u (lu - 1)
+-- loop !j !racc
+-- | j < 0 = pure racc
+-- | otherwise = do
+-- let uj = PA.indexPrimArray u j
+-- !(P qj rnex) = quotrem_2by1 racc uj d rec
+-- PA.writePrimArray quo j qj
+-- loop (pred j) rnex
+-- loop (lu - 2) r0
+--
+-- add_to
+-- :: PrimMonad m
+-- => PA.MutablePrimArray (PrimState m) Word64
+-- -> Int
+-- -> Word256
+-- -> Int
+-- -> m Word64
+-- add_to x x_offset (Word256 y0 y1 y2 y3) l = do
+-- let loop !j !cacc
+-- | j == l = pure cacc
+-- | otherwise = do
+-- xj <- PA.readPrimArray x (j + x_offset)
+-- let !(P nex carry) = case j of
+-- 0 -> add_c xj y0 cacc
+-- 1 -> add_c xj y1 cacc
+-- 2 -> add_c xj y2 cacc
+-- 3 -> add_c xj y3 cacc
+-- _ -> error "ppad-fixed (add_to): bad index"
+-- PA.writePrimArray x (j + x_offset) nex
+-- loop (succ j) carry
+-- loop 0 0
+--
+-- quotrem
+-- :: PrimMonad m
+-- => PA.MutablePrimArray (PrimState m) Word64 -- quotient (potentially large)
+-- -> PA.PrimArray Word64 -- dividend (potentially large)
+-- -> Word256 -- divisor (256-bit)
+-- -> m (PA.PrimArray Word64) -- remainder (256-bit)
+-- quotrem quo u (Word256 d0 d1 d2 d3) = do
+-- let -- normalize divisor
+-- (dlen, shift)
+-- | d3 /= 0 = (4, B.countLeadingZeros d3)
+-- | d2 /= 0 = (3, B.countLeadingZeros d2)
+-- | d1 /= 0 = (2, B.countLeadingZeros d1)
+-- | otherwise = (1, B.countLeadingZeros d0) -- zero not checked
+-- dn_3 = (d3 .<<. shift) .|. (d2 .>>. (64 - shift))
+-- dn_2 = (d2 .<<. shift) .|. (d1 .>>. (64 - shift))
+-- dn_1 = (d1 .<<. shift) .|. (d0 .>>. (64 - shift))
+-- dn_0 = d0 .<<. shift
+-- !dn = Word256 dn_0 dn_1 dn_2 dn_3
+-- -- get size of normalized dividend
+-- lu = PA.sizeofPrimArray u
+-- ulen = let loop !j
+-- | j < 0 = 0
+-- | PA.indexPrimArray u j /= 0 = j + 1
+-- | otherwise = loop (j - 1)
+-- in loop (lu - 1)
+-- if ulen < dlen
+-- then do
+-- -- u always has size at least 4
+-- !r <- PA.newPrimArray 4
+-- PA.copyPrimArray r 0 u 0 4
+-- PA.unsafeFreezePrimArray r
+-- else do
+-- -- normalize dividend
+-- !un <- PA.newPrimArray (ulen + 1)
+-- PA.setPrimArray un 0 (ulen + 1) 0
+-- let u_hi = PA.indexPrimArray u (ulen - 1)
+-- PA.writePrimArray un ulen (u_hi .>>. (64 - shift))
+-- let normalize_u !j !uj
+-- | j == 0 =
+-- PA.writePrimArray un 0 (PA.indexPrimArray u 0 .<<. shift)
+-- | otherwise = do
+-- let !uj_1 = PA.indexPrimArray u (j - 1)
+-- !val = (uj .<<. shift) .|. (uj_1 .>>. (64 - shift))
+-- PA.writePrimArray un j val
+-- normalize_u (pred j) uj_1
+-- normalize_u (ulen - 1) u_hi
+-- if dlen == 1
+-- then do
+-- -- normalized divisor is small
+-- !un_final <- PA.unsafeFreezePrimArray un
+-- !r <- quotrem_by1 quo un_final dn_0
+-- pure $ PA.primArrayFromList [r .>>. shift, 0, 0, 0] -- XX
+-- else do
+-- quotrem_knuth quo un dn dlen
+-- -- unnormalize remainder
+-- let unn_rem !j !un_j
+-- | j == dlen = do
+-- PA.writePrimArray un (j - 1) (un_j .>>. shift)
+-- PA.unsafeFreezePrimArray un
+-- | otherwise = do
+-- !un_j_1 <- PA.readPrimArray un (j + 1)
+-- let !unn_j = (un_j .>>. shift) .|. (un_j_1 .<<. (64 - shift))
+-- PA.writePrimArray un j unn_j
+-- unn_rem (j + 1) un_j_1
+--
+-- !un_0 <- PA.readPrimArray un 0
+-- {-# SCC "unn_rem" #-} unn_rem 0 un_0
+--
+-- quotrem_knuth
+-- :: PrimMonad m
+-- => PA.MutablePrimArray (PrimState m) Word64 -- quotient (potentially large)
+-- -> PA.MutablePrimArray (PrimState m) Word64 -- normalized dividend
+-- -> Word256 -- normalized divisor
+-- -> Int -- words in normalized divisor
+-- -> m ()
+-- quotrem_knuth quo u d@(Word256 d0 d1 d2 d3) ld = do
+-- !lu <- PA.getSizeofMutablePrimArray u
+-- darr <- PA.newPrimArray 4
+-- PA.writePrimArray darr 0 d0
+-- PA.writePrimArray darr 1 d1
+-- PA.writePrimArray darr 2 d2
+-- PA.writePrimArray darr 3 d3
+-- d_final <- PA.unsafeFreezePrimArray darr
+-- let (dh, dl) = case ld of
+-- 4 -> (d3, d2)
+-- 3 -> (d2, d1)
+-- 2 -> (d1, d0)
+-- _ -> error "ppad-fixed (quotrem_knuth): bad index"
+-- !rec = recip_2by1 dh
+-- loop !j
+-- | j < 0 = pure ()
+-- | otherwise = do
+-- !u2 <- PA.readPrimArray u (j + ld)
+-- !u1 <- PA.readPrimArray u (j + ld - 1)
+-- !u0 <- PA.readPrimArray u (j + ld - 2)
+-- let !qhat
+-- | u2 >= dh = 0xffff_ffff_ffff_ffff
+-- | otherwise =
+-- let !(P qh rh) = quotrem_2by1 u2 u1 dh rec
+-- !(P ph pl) = mul_c qh dl
+-- in if ph > rh || (ph == rh && pl > u0)
+-- then qh - 1
+-- else qh
+--
+-- !borrow <- sub_mul u j d_final ld qhat
+-- PA.writePrimArray u (j + ld) (u2 - borrow)
+-- if u2 < borrow
+-- then do
+-- let !qh = qhat - 1
+-- r <- add_to u j d ld
+-- PA.writePrimArray u (j + ld) r
+-- PA.writePrimArray quo j qh
+-- else
+-- PA.writePrimArray quo j qhat
+-- loop (pred j)
+-- loop (lu - ld - 1)
+
+--
+-- recip_2by1 :: Word64 -> Word64
+-- recip_2by1 d = r where
+-- !(P r _) = quotrem_r (B.complement d) 0xffffffffffffffff d
+--
+-- quotrem_2by1 :: Word64 -> Word64 -> Word64 -> Word64 -> Word128
+-- quotrem_2by1 uh ul d rec =
+-- let !(P qh_0 ql) = mul_c rec uh
+-- !(P ql_0 c) = add_c ql ul 0
+-- !(P (succ -> qh_1) _) = add_c qh_0 uh c
+-- !r = ul - qh_1 * d
+--
+-- !(P qh_y r_y)
+-- | r > ql_0 = P (qh_1 - 1) (r + d)
+-- | otherwise = P qh_1 r
+--
+-- in if r_y >= d
+-- then P (qh_y + 1) (r_y - d)
+-- else P qh_y r_y
+--
+--
+-- div :: Word256 -> Word256 -> Word256
+-- div u@(Word256 u0 u1 u2 u3) d@(Word256 d0 _ _ _)
+-- | is_zero d || d `gt` u = zero -- ?
+-- | u == d = one
+-- | is_word64 u = Word256 (u0 `quot` d0) 0 0 0
+-- | otherwise = runST $ do
+-- -- allocate quotient
+-- quo <- PA.newPrimArray 4
+-- PA.setPrimArray quo 0 4 0
+-- -- allocate dividend
+-- u_arr <- PA.newPrimArray 4
+-- PA.setPrimArray u_arr 0 4 0
+-- PA.writePrimArray u_arr 0 u0
+-- PA.writePrimArray u_arr 1 u1
+-- PA.writePrimArray u_arr 2 u2
+-- PA.writePrimArray u_arr 3 u3
+-- u_final <- PA.unsafeFreezePrimArray u_arr
+-- _ <- quotrem quo u_final d
+-- q0 <- PA.readPrimArray quo 0
+-- q1 <- PA.readPrimArray quo 1
+-- q2 <- PA.readPrimArray quo 2
+-- q3 <- PA.readPrimArray quo 3
+-- pure (Word256 q0 q1 q2 q3)
+--
+-- -- | Modulo operation on 'Word256' values.
+-- --
+-- -- >>> to_word256 0xFFFFFFFFFF `mod` to_word256 0xFFFFFF
+-- -- 65535
+-- mod :: Word256 -> Word256 -> Word256
+-- mod u@(Word256 u0 u1 u2 u3) d@(Word256 d0 _ _ _)
+-- | is_zero d || d `gt` u = zero -- ?
+-- | u == d = one
+-- | is_word64 u = Word256 (u0 `quot` d0) 0 0 0
+-- | otherwise = runST $ do
+-- -- allocate quotient
+-- quo <- PA.newPrimArray 4
+-- PA.setPrimArray quo 0 4 0
+-- -- allocate dividend
+-- u_arr <- PA.newPrimArray 4
+-- PA.setPrimArray u_arr 0 4 0
+-- PA.writePrimArray u_arr 0 u0
+-- PA.writePrimArray u_arr 1 u1
+-- PA.writePrimArray u_arr 2 u2
+-- PA.writePrimArray u_arr 3 u3
+-- u_final <- PA.unsafeFreezePrimArray u_arr
+-- r <- quotrem quo u_final d
+-- let r0 = PA.indexPrimArray r 0
+-- r1 = PA.indexPrimArray r 1
+-- r2 = PA.indexPrimArray r 2
+-- r3 = PA.indexPrimArray r 3
+-- pure (Word256 r0 r1 r2 r3)
diff --git a/src/Main.hs b/src/Main.hs
@@ -5,20 +5,22 @@ module Main where
import Data.Word.Extended
main :: IO ()
-main = do
- let !u = Word576
- 5152276743337338587
- 6823823105342984773
- 12649096328525870222
- 8811572179372364942
- 0 0 0 0 0
-
- !d = Word256
- 8849385646123010679
- 653197174784954101
- 1286679968202709238
- 3741537094902495500
-
- let foo = quotrem u d
- print foo
-
+main = pure ()
+--main :: IO ()
+--main = do
+-- let !u = Word576
+-- 5152276743337338587
+-- 6823823105342984773
+-- 12649096328525870222
+-- 8811572179372364942
+-- 0 0 0 0 0
+--
+-- !d = Word256
+-- 8849385646123010679
+-- 653197174784954101
+-- 1286679968202709238
+-- 3741537094902495500
+--
+-- let foo = quotrem u d
+-- print foo
+--
diff --git a/test/Main.hs b/test/Main.hs
@@ -1,22 +1,22 @@
+ {-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
module Main where
import Data.Bits ((.|.), (.&.), (.>>.), (.^.))
import qualified Data.Bits as B
-import Data.Word (Word64)
import Data.Word.Extended
+import GHC.Exts
+import GHC.Word
import Prelude hiding (and, or, div, mod)
import qualified Prelude (div)
import Test.Tasty
import qualified Test.Tasty.HUnit as H
import qualified Test.Tasty.QuickCheck as Q
-fi :: (Integral a, Num b) => a -> b
-fi = fromIntegral
-{-# INLINE fi #-}
-
instance Q.Arbitrary Word256 where
arbitrary = do
w0 <- Q.arbitrary
@@ -25,16 +25,6 @@ instance Q.Arbitrary Word256 where
w3 <- Q.arbitrary
pure (Word256 w0 w1 w2 w3)
-newtype Different a = Different (a, a)
- deriving Show
-
-instance (Q.Arbitrary a, Eq a) => Q.Arbitrary (Different a) where
- arbitrary = do
- a <- Q.arbitrary
- b <- Q.arbitrary `Q.suchThat` (\b -> b /= a)
- pure (Different (a, b))
-
--- second argument is no greater than first argument
newtype Monotonic = Monotonic (Integer, Integer)
deriving Show
@@ -45,91 +35,45 @@ instance Q.Arbitrary Monotonic where
`Q.suchThat` (\b -> b <= a)
pure (Monotonic (a, b))
--- second argument * third argument is no greater than first argument
-newtype MulMonotonic = MulMonotonic (Integer, Integer, Integer)
- deriving Show
-
-instance Q.Arbitrary MulMonotonic where
- arbitrary = do
- Q.NonNegative a <- Q.arbitrary
- m <- fmap fi (Q.arbitrary :: Q.Gen Word64)
- Q.NonNegative b <-
- Q.arbitrary `Q.suchThat` (\(Q.NonNegative b) -> b * m <= a)
- pure (MulMonotonic (a, b, m))
-
-newtype DivMonotonic = DivMonotonic (Integer, Integer)
- deriving Show
+-- properties -----------------------------------------------------------------
-instance Q.Arbitrary DivMonotonic where
- arbitrary = do
- a <- Q.chooseInteger (1, 2 ^ (256 :: Int) - 1)
- b <- (Q.chooseInteger (1, 2 ^ (256 :: Int) - 1))
- `Q.suchThat` (\b -> b <= a)
- pure (DivMonotonic (a, b))
+-- addition / subtraction ----------------
--- properties -----------------------------------------------------------------
+add_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
+add_matches (Q.NonNegative a) (Q.NonNegative b) =
+ to_integer (to_word256 a `add` to_word256 b) == a + b
-lt_matches :: Different (Q.NonNegative Integer) -> Bool
-lt_matches (Different (Q.NonNegative a, Q.NonNegative b))
- | a < b = to_word256 a `lt` to_word256 b
- | otherwise = to_word256 b `lt` to_word256 a
+sub_matches :: Monotonic -> Bool
+sub_matches (Monotonic (a, b)) =
+ to_integer (to_word256 a `sub` to_word256 b) == a - b
-gt_matches :: Different (Q.NonNegative Integer) -> Bool
-gt_matches (Different (Q.NonNegative a, Q.NonNegative b))
- | a > b = to_word256 a `gt` to_word256 b
- | otherwise = to_word256 b `gt` to_word256 a
+-- multiplication ------------------------
mul_c_matches :: Word64 -> Word64 -> Bool
-mul_c_matches a b =
+mul_c_matches a@(W64# a_ubox) b@(W64# b_ubox) =
let c = fi a * fi b :: Integer
c_hi = fi (c .>>. 64) :: Word64
c_lo = fi (c .&. 0xffffffffffffffff) :: Word64
- P hi lo = mul_c a b
- in hi == c_hi && lo == c_lo
+ !(# hi, lo #) = mul_c# a_ubox b_ubox
+ in (W64# hi) == c_hi && (W64# lo) == c_lo
-- (hi * 2 ^ 64 + lo) = z + (x * y)
umul_hop_predicate_holds :: Word64 -> Word64 -> Word64 -> Bool
-umul_hop_predicate_holds z x y =
- let !(P hi lo) = umul_hop z x y
- in fi hi * 2 ^ (64 :: Int) + fi lo == (fi z + (fi x * fi y) :: Integer)
+umul_hop_predicate_holds z@(W64# z_ubox) x@(W64# x_ubox) y@(W64# y_ubox) =
+ let !(# hi, lo #) = umul_hop# z_ubox x_ubox y_ubox
+ in fi (W64# hi) * 2 ^ (64 :: Int) + fi (W64# lo)
+ == (fi z + (fi x * fi y) :: Integer)
-- (hi * 2 ^ 64 + lo) = z + (x * y) + c
umul_step_predicate_holds :: Word64 -> Word64 -> Word64 -> Word64 -> Bool
-umul_step_predicate_holds z x y c =
- let !(P hi lo) = umul_step z x y c
- !left = fi hi * 2 ^ (64 :: Int) + fi lo :: Integer
+umul_step_predicate_holds
+ z@(W64# z_ubox) x@(W64# x_ubox) y@(W64# y_ubox) c@(W64# c_ubox) =
+ let !(# hi, lo #) = umul_step# z_ubox x_ubox y_ubox c_ubox
+ !left = fi (W64# hi) * 2 ^ (64 :: Int) + fi (W64# lo) :: Integer
!rite = fi z + (fi x * fi y) + fi c :: Integer
in left == rite
-to_word256_inverts_to_integer :: Word256 -> Bool
-to_word256_inverts_to_integer w256 =
- to_word256 (to_integer w256) == w256
-
-to_integer_inverts_to_word256 :: Q.NonNegative Integer -> Bool
-to_integer_inverts_to_word256 (Q.NonNegative n) =
- to_integer (to_word256 n) == n
-
-or_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
-or_matches (Q.NonNegative a) (Q.NonNegative b) =
- to_integer (to_word256 a `or` to_word256 b) == a .|. b
-
-and_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
-and_matches (Q.NonNegative a) (Q.NonNegative b) =
- to_integer (to_word256 a `and` to_word256 b) == a .&. b
-
-xor_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
-xor_matches (Q.NonNegative a) (Q.NonNegative b) =
- to_integer (to_word256 a `xor` to_word256 b) == a .^. b
-
-add_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
-add_matches (Q.NonNegative a) (Q.NonNegative b) =
- to_integer (to_word256 a `add` to_word256 b) == a + b
-
-sub_matches :: Monotonic -> Bool
-sub_matches (Monotonic (a, b)) =
- to_integer (to_word256 a `sub` to_word256 b) == a - b
-
mul_lo_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
mul_lo_matches (Q.NonNegative a) (Q.NonNegative b) =
let !mask128 = 0xffffffffffffffffffffffffffffffff
@@ -138,25 +82,7 @@ mul_lo_matches (Q.NonNegative a) (Q.NonNegative b) =
in to_word256 a_lo `mul` to_word256 b_lo == to_word256 (a_lo * b_lo)
-mul_512_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
-mul_512_matches (Q.NonNegative a) (Q.NonNegative b) =
- let !left = to_word256 a `mul_512` to_word256 b
- !rite = to_word512 (a * b)
- in left == rite
-
-div_matches :: DivMonotonic -> Bool
-div_matches (DivMonotonic (a, b)) =
- let !left = to_word256 a `div` to_word256 b
- !rite = to_word256 (a `Prelude.div` b)
- in left == rite
-
-mod_matches :: DivMonotonic -> Bool
-mod_matches (DivMonotonic (a, b)) =
- let !left = to_word256 a `mod` to_word256 b
- !rite = to_word256 (a `rem` b)
- in left == rite
-
--- assertions ------------------------------------------------------------------
+-- division ------------------------------
quotrem_r_case0 :: H.Assertion
quotrem_r_case0 = do
@@ -168,6 +94,36 @@ quotrem_r_case1 = do
let !(P q r) = quotrem_r 0 4 2
H.assertEqual mempty (P 2 0) (P q r)
+quotrem_r_case2 :: H.Assertion
+quotrem_r_case2 = do
+ let !(P q r) = quotrem_r 4 0xffffffffffffffff (B.complement 4)
+ H.assertEqual mempty (P 5 24) (P q r)
+
+quotrem_r_case0# :: H.Assertion
+quotrem_r_case0# = do
+ let !(# q, r #) =
+ quotrem_r# (wordToWord64# 2##) (wordToWord64# 4##) (wordToWord64# 4##)
+ H.assertEqual mempty (P 9223372036854775809 0) (P (W64# q) (W64# r))
+
+quotrem_r_case1# :: H.Assertion
+quotrem_r_case1# = do
+ let !(# q, r #) =
+ quotrem_r# (wordToWord64# 0##) (wordToWord64# 4##) (wordToWord64# 2##)
+ H.assertEqual mempty (P 2 0) (P (W64# q) (W64# r))
+
+quotrem_r_case2# :: H.Assertion
+quotrem_r_case2# = do
+ let !(# q, r #) =
+ quotrem_r#
+ (wordToWord64# 4##)
+ (wordToWord64# 0xffffffffffffffff##)
+ (not64# (wordToWord64# 4##))
+ H.assertEqual mempty (P 5 24) (P (W64# q) (W64# r))
+
+-- recip_2by1 :: Word64 -> Word64
+-- recip_2by1 d = r where
+-- !(P r _) = quotrem_r (B.complement d) 0xffffffffffffffff d
+
recip_2by1_case0 :: H.Assertion
recip_2by1_case0 = do
let !q = recip_2by1 (B.complement 4)
@@ -178,80 +134,227 @@ recip_2by1_case1 = do
let !q = recip_2by1 (B.complement 0xff)
H.assertEqual mempty 256 q
-quotrem_2by1_case0 :: H.Assertion
-quotrem_2by1_case0 = do
- let !d = B.complement 0xFF :: Word64
- !o = quotrem_2by1 8 4 d (recip_2by1 d)
- H.assertEqual mempty (P 8 2052) o
-
--- main -----------------------------------------------------------------------
-
-comparison :: TestTree
-comparison = testGroup "comparison" [
- Q.testProperty "lt matches" $
- Q.withMaxSuccess 1000 lt_matches
- , Q.testProperty "gt matches" $
- Q.withMaxSuccess 1000 gt_matches
- ]
-
-bits :: TestTree
-bits = testGroup "bits" [
- Q.testProperty "or matches" $
- Q.withMaxSuccess 1000 or_matches
- , Q.testProperty "and matches" $
- Q.withMaxSuccess 1000 and_matches
- , Q.testProperty "xor matches" $
- Q.withMaxSuccess 1000 xor_matches
- ]
-
-inverses :: TestTree
-inverses = testGroup "inverses" [
- Q.testProperty "to_word256 . to_integer ~ id" $
- Q.withMaxSuccess 1000 to_word256_inverts_to_integer
- , Q.testProperty "to_integer . to_word256 ~ id (nonneg input)" $
- Q.withMaxSuccess 1000 to_integer_inverts_to_word256
- ]
-
-arithmetic :: TestTree
-arithmetic = testGroup "arithmetic" [
+add_sub :: TestTree
+add_sub = testGroup "addition & subtraction" [
Q.testProperty "addition matches (nonneg)" $
Q.withMaxSuccess 1000 add_matches
, Q.testProperty "subtraction matches (nonneg, monotonic)" $
Q.withMaxSuccess 1000 sub_matches
- , Q.testProperty "512-bit multiplication matches (nonneg, low bits)" $
- Q.withMaxSuccess 1000 mul_512_matches
- , Q.testProperty "division matches" $
- Q.withMaxSuccess 1000 div_matches
- , Q.testProperty "mod matches" $
- Q.withMaxSuccess 1000 mod_matches
]
-utils :: TestTree
-utils = testGroup "utils" [
- Q.testProperty "mul_c matches integer multiplication" $
- Q.withMaxSuccess 1000 mul_c_matches
+multiplication :: TestTree
+multiplication = testGroup "arithmetic" [
+ Q.testProperty "mul_c matches integer multiplication" $
+ Q.withMaxSuccess 1000 mul_c_matches
, Q.testProperty "umul_hop: (hi * 2 ^ 64 + lo) = z + (x * y)" $
Q.withMaxSuccess 1000 umul_hop_predicate_holds
, Q.testProperty "umul_step: (hi * 2 ^ 64 + lo) = z + (x * y) + c" $
Q.withMaxSuccess 1000 umul_step_predicate_holds
+ , Q.testProperty "mul matches (nonneg, low bits)" $
+ Q.withMaxSuccess 1000 mul_lo_matches
+ -- , Q.testProperty "division matches" $
+ -- Q.withMaxSuccess 1000 div_matches
+ -- , Q.testProperty "mod matches" $
+ -- Q.withMaxSuccess 1000 mod_matches
]
main :: IO ()
-main = defaultMain $
- testGroup "ppad-fixed" [
+main = defaultMain $ testGroup "ppad-fixed" [
testGroup "property tests" [
- comparison
- , utils
- , inverses
- , bits
- , arithmetic
+ add_sub
+ , multiplication
]
, testGroup "unit tests" [
H.testCase "quotrem_r matches case0" quotrem_r_case0
, H.testCase "quotrem_r matches case1" quotrem_r_case1
+ , H.testCase "quotrem_r matches case2" quotrem_r_case2
+ , H.testCase "quotrem_r# matches case0" quotrem_r_case0#
+ , H.testCase "quotrem_r# matches case1" quotrem_r_case1#
+ , H.testCase "quotrem_r# matches case2" quotrem_r_case2#
+ -- , H.testCase "quotrem_r# matches case2" quotrem_r_case2
+ -- , H.testCase "quotrem_r' matches case2" quotrem_r_case2'
+ -- , H.testCase "quotrem_r_recip_case0 matches case0" quotrem_r_recip_case0
, H.testCase "recip_2by1 matches case0" recip_2by1_case0
, H.testCase "recip_2by1 matches case1" recip_2by1_case1
- , H.testCase "quotrem_2by1 matches case0" quotrem_2by1_case0
]
]
+-- newtype Different a = Different (a, a)
+-- deriving Show
+--
+-- instance (Q.Arbitrary a, Eq a) => Q.Arbitrary (Different a) where
+-- arbitrary = do
+-- a <- Q.arbitrary
+-- b <- Q.arbitrary `Q.suchThat` (\b -> b /= a)
+-- pure (Different (a, b))
+--
+-- -- second argument is no greater than first argument
+-- -- second argument * third argument is no greater than first argument
+-- newtype MulMonotonic = MulMonotonic (Integer, Integer, Integer)
+-- deriving Show
+--
+-- instance Q.Arbitrary MulMonotonic where
+-- arbitrary = do
+-- Q.NonNegative a <- Q.arbitrary
+-- m <- fmap fi (Q.arbitrary :: Q.Gen Word64)
+-- Q.NonNegative b <-
+-- Q.arbitrary `Q.suchThat` (\(Q.NonNegative b) -> b * m <= a)
+-- pure (MulMonotonic (a, b, m))
+--
+-- newtype DivMonotonic = DivMonotonic (Integer, Integer)
+-- deriving Show
+--
+-- instance Q.Arbitrary DivMonotonic where
+-- arbitrary = do
+-- a <- Q.chooseInteger (1, 2 ^ (256 :: Int) - 1)
+-- b <- (Q.chooseInteger (1, 2 ^ (256 :: Int) - 1))
+-- `Q.suchThat` (\b -> b <= a)
+-- pure (DivMonotonic (a, b))
+--
+-- -- properties -----------------------------------------------------------------
+--
+-- lt_matches :: Different (Q.NonNegative Integer) -> Bool
+-- lt_matches (Different (Q.NonNegative a, Q.NonNegative b))
+-- | a < b = to_word256 a `lt` to_word256 b
+-- | otherwise = to_word256 b `lt` to_word256 a
+--
+-- gt_matches :: Different (Q.NonNegative Integer) -> Bool
+-- gt_matches (Different (Q.NonNegative a, Q.NonNegative b))
+-- | a > b = to_word256 a `gt` to_word256 b
+-- | otherwise = to_word256 b `gt` to_word256 a
+--
+-- to_word256_inverts_to_integer :: Word256 -> Bool
+-- to_word256_inverts_to_integer w256 =
+-- to_word256 (to_integer w256) == w256
+--
+-- to_integer_inverts_to_word256 :: Q.NonNegative Integer -> Bool
+-- to_integer_inverts_to_word256 (Q.NonNegative n) =
+-- to_integer (to_word256 n) == n
+--
+-- or_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
+-- or_matches (Q.NonNegative a) (Q.NonNegative b) =
+-- to_integer (to_word256 a `or` to_word256 b) == a .|. b
+--
+-- and_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
+-- and_matches (Q.NonNegative a) (Q.NonNegative b) =
+-- to_integer (to_word256 a `and` to_word256 b) == a .&. b
+--
+-- xor_matches :: Q.NonNegative Integer -> Q.NonNegative Integer -> Bool
+-- xor_matches (Q.NonNegative a) (Q.NonNegative b) =
+-- to_integer (to_word256 a `xor` to_word256 b) == a .^. b
+
+-- sub_matches :: Monotonic -> Bool
+-- sub_matches (Monotonic (a, b)) =
+-- to_integer (to_word256 a `sub` to_word256 b) == a - b
+--
+-- div_matches :: DivMonotonic -> Bool
+-- div_matches (DivMonotonic (a, b)) =
+-- let !left = to_word256 a `div` to_word256 b
+-- !rite = to_word256 (a `Prelude.div` b)
+-- in left == rite
+--
+-- mod_matches :: DivMonotonic -> Bool
+-- mod_matches (DivMonotonic (a, b)) =
+-- let !left = to_word256 a `mod` to_word256 b
+-- !rite = to_word256 (a `rem` b)
+-- in left == rite
+--
+-- -- assertions ------------------------------------------------------------------
+--
+-- quotrem_r_case0 :: H.Assertion
+-- quotrem_r_case0 = do
+-- let !(P q r) = quotrem_r 2 4 4
+-- H.assertEqual mempty (P 9223372036854775809 0) (P q r)
+--
+-- quotrem_r_case1 :: H.Assertion
+-- quotrem_r_case1 = do
+-- let !(P q r) = quotrem_r 0 4 2
+-- H.assertEqual mempty (P 2 0) (P q r)
+--
+-- recip_2by1_case0 :: H.Assertion
+-- recip_2by1_case0 = do
+-- let !q = recip_2by1 (B.complement 4)
+-- H.assertEqual mempty 5 q
+--
+-- recip_2by1_case1 :: H.Assertion
+-- recip_2by1_case1 = do
+-- let !q = recip_2by1 (B.complement 0xff)
+-- H.assertEqual mempty 256 q
+--
+-- quotrem_2by1_case0 :: H.Assertion
+-- quotrem_2by1_case0 = do
+-- let !d = B.complement 0xFF :: Word64
+-- !o = quotrem_2by1 8 4 d (recip_2by1 d)
+-- H.assertEqual mempty (P 8 2052) o
+--
+-- -- main -----------------------------------------------------------------------
+--
+-- comparison :: TestTree
+-- comparison = testGroup "comparison" [
+-- Q.testProperty "lt matches" $
+-- Q.withMaxSuccess 1000 lt_matches
+-- , Q.testProperty "gt matches" $
+-- Q.withMaxSuccess 1000 gt_matches
+-- ]
+--
+-- bits :: TestTree
+-- bits = testGroup "bits" [
+-- Q.testProperty "or matches" $
+-- Q.withMaxSuccess 1000 or_matches
+-- , Q.testProperty "and matches" $
+-- Q.withMaxSuccess 1000 and_matches
+-- , Q.testProperty "xor matches" $
+-- Q.withMaxSuccess 1000 xor_matches
+-- ]
+--
+-- inverses :: TestTree
+-- inverses = testGroup "inverses" [
+-- Q.testProperty "to_word256 . to_integer ~ id" $
+-- Q.withMaxSuccess 1000 to_word256_inverts_to_integer
+-- , Q.testProperty "to_integer . to_word256 ~ id (nonneg input)" $
+-- Q.withMaxSuccess 1000 to_integer_inverts_to_word256
+-- ]
+--
+-- arithmetic :: TestTree
+-- arithmetic = testGroup "arithmetic" [
+-- Q.testProperty "addition matches (nonneg)" $
+-- Q.withMaxSuccess 1000 add_matches
+-- , Q.testProperty "subtraction matches (nonneg, monotonic)" $
+-- Q.withMaxSuccess 1000 sub_matches
+-- , Q.testProperty "512-bit multiplication matches (nonneg, low bits)" $
+-- Q.withMaxSuccess 1000 mul_512_matches
+-- , Q.testProperty "division matches" $
+-- Q.withMaxSuccess 1000 div_matches
+-- , Q.testProperty "mod matches" $
+-- Q.withMaxSuccess 1000 mod_matches
+-- ]
+--
+-- utils :: TestTree
+-- utils = testGroup "utils" [
+-- Q.testProperty "mul_c matches integer multiplication" $
+-- Q.withMaxSuccess 1000 mul_c_matches
+-- , Q.testProperty "umul_hop: (hi * 2 ^ 64 + lo) = z + (x * y)" $
+-- Q.withMaxSuccess 1000 umul_hop_predicate_holds
+-- , Q.testProperty "umul_step: (hi * 2 ^ 64 + lo) = z + (x * y) + c" $
+-- Q.withMaxSuccess 1000 umul_step_predicate_holds
+-- ]
+--
+-- main :: IO ()
+-- main = defaultMain $
+-- testGroup "ppad-fixed" [
+-- testGroup "property tests" [
+-- comparison
+-- , utils
+-- , inverses
+-- , bits
+-- , arithmetic
+-- ]
+-- , testGroup "unit tests" [
+-- H.testCase "quotrem_r matches case0" quotrem_r_case0
+-- , H.testCase "quotrem_r matches case1" quotrem_r_case1
+-- , H.testCase "recip_2by1 matches case0" recip_2by1_case0
+-- , H.testCase "recip_2by1 matches case1" recip_2by1_case1
+-- , H.testCase "quotrem_2by1 matches case0" quotrem_2by1_case0
+-- ]
+-- ]
+--
