Limb.hs (4992B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE MagicHash #-} 3 {-# LANGUAGE UnboxedTuples #-} 4 5 module Limb ( 6 tests 7 ) where 8 9 import qualified Data.Choice as C 10 import qualified Data.Word.Limb as L 11 import GHC.Exts 12 import Test.Tasty 13 import qualified Test.Tasty.HUnit as H 14 15 overflowing_add_no_carry :: H.Assertion 16 overflowing_add_no_carry = do 17 let !(# r, c #) = L.add_o# (L.Limb 0##) (L.Limb 1##) 18 H.assertBool mempty (L.eq_vartime# r (L.Limb 1##)) 19 H.assertBool mempty (L.eq_vartime# c (L.Limb 0##)) 20 21 overflowing_add_with_carry :: H.Assertion 22 overflowing_add_with_carry = do 23 let !(# r, c #) = L.add_o# (L.Limb (not# 0##)) (L.Limb 1##) 24 H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) 25 H.assertBool mempty (L.eq_vartime# c (L.Limb 1##)) 26 27 wrapping_add_no_carry :: H.Assertion 28 wrapping_add_no_carry = do 29 let !r = L.add_w# (L.Limb 0##) (L.Limb 1##) 30 H.assertBool mempty (L.eq_vartime# r (L.Limb 1##)) 31 32 wrapping_add_with_carry :: H.Assertion 33 wrapping_add_with_carry = do 34 let !r = L.add_w# (L.Limb (not# 0##)) (L.Limb 1##) 35 H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) 36 37 borrowing_sub_no_borrow :: H.Assertion 38 borrowing_sub_no_borrow = do 39 let !(# r, c #) = L.sub_b# (L.Limb 1##) (L.Limb 1##) (L.Limb 0##) 40 H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) 41 H.assertBool mempty (L.eq_vartime# c (L.Limb 0##)) 42 43 borrowing_sub_with_borrow :: H.Assertion 44 borrowing_sub_with_borrow = do 45 let !(# r, c #) = L.sub_b# (L.Limb 0##) (L.Limb 1##) (L.Limb 0##) 46 H.assertBool mempty (L.eq_vartime# r (L.Limb (not# 0##))) 47 H.assertBool mempty (L.eq_vartime# c (L.Limb (not# 0##))) 48 49 wrapping_sub_no_borrow :: H.Assertion 50 wrapping_sub_no_borrow = do 51 let !r = L.sub_w# (L.Limb 1##) (L.Limb 1##) 52 H.assertBool mempty (L.eq_vartime# r (L.Limb 0##)) 53 54 wrapping_sub_with_borrow :: H.Assertion 55 wrapping_sub_with_borrow = do 56 let !r = L.sub_w# (L.Limb 0##) (L.Limb 1##) 57 H.assertBool mempty (L.eq_vartime# r (L.Limb (not# 0##))) 58 59 shl1 :: H.Assertion 60 shl1 = do 61 let !r = L.shl# (L.Limb 1##) 1# 62 H.assertBool mempty (L.eq_vartime# r (L.Limb 2##)) 63 64 shl2 :: H.Assertion 65 shl2 = do 66 let !r = L.shl# (L.Limb 1##) 2# 67 H.assertBool mempty (L.eq_vartime# r (L.Limb 4##)) 68 69 shr1 :: H.Assertion 70 shr1 = do 71 let !r = L.shr# (L.Limb 2##) 1# 72 H.assertBool mempty (L.eq_vartime# r (L.Limb 1##)) 73 74 shr2 :: H.Assertion 75 shr2 = do 76 let !r = L.shr# (L.Limb 16##) 2# 77 H.assertBool mempty (L.eq_vartime# r (L.Limb 4##)) 78 79 eq :: H.Assertion 80 eq = do 81 let !a = L.Limb 0## 82 !b = L.Limb (not# 0##) 83 H.assertBool mempty (C.decide (L.eq# a a)) 84 H.assertBool mempty (not (C.decide (L.eq# a b))) 85 H.assertBool mempty (not (C.decide (L.eq# b a))) 86 H.assertBool mempty (C.decide (L.eq# b b)) 87 88 gt :: H.Assertion 89 gt = do 90 let !a = L.Limb 0## 91 !b = L.Limb 1## 92 !c = L.Limb (not# 0##) 93 H.assertBool mempty (C.decide (L.gt# b a)) 94 H.assertBool mempty (C.decide (L.gt# c a)) 95 H.assertBool mempty (C.decide (L.gt# c b)) 96 97 H.assertBool mempty (not (C.decide (L.gt# a a))) 98 H.assertBool mempty (not (C.decide (L.gt# b b))) 99 H.assertBool mempty (not (C.decide (L.gt# c c))) 100 101 H.assertBool mempty (not (C.decide (L.gt# a b))) 102 H.assertBool mempty (not (C.decide (L.gt# a c))) 103 H.assertBool mempty (not (C.decide (L.gt# b c))) 104 105 lt :: H.Assertion 106 lt = do 107 let !a = L.Limb 0## 108 !b = L.Limb 1## 109 !c = L.Limb (not# 0##) 110 H.assertBool mempty (C.decide (L.lt# a b)) 111 H.assertBool mempty (C.decide (L.lt# a c)) 112 H.assertBool mempty (C.decide (L.lt# b c)) 113 114 H.assertBool mempty (not (C.decide (L.lt# a a))) 115 H.assertBool mempty (not (C.decide (L.lt# b b))) 116 H.assertBool mempty (not (C.decide (L.lt# c c))) 117 118 H.assertBool mempty (not (C.decide (L.lt# b a))) 119 H.assertBool mempty (not (C.decide (L.lt# c a))) 120 H.assertBool mempty (not (C.decide (L.lt# c b))) 121 122 cswap :: H.Assertion 123 cswap = do 124 let !a = L.Limb (not# 0##) 125 !b = L.Limb 0## 126 !(# a0, b0 #) = L.cswap# a b (C.false# ()) 127 H.assertBool mempty (L.eq_vartime# a0 (L.Limb (not# 0##))) 128 H.assertBool mempty (L.eq_vartime# b0 (L.Limb 0##)) 129 let !(# a1, b1 #) = L.cswap# a0 b0 (C.true# ()) 130 H.assertBool mempty (L.eq_vartime# a1 (L.Limb 0##)) 131 H.assertBool mempty (L.eq_vartime# b1 (L.Limb (not# 0##))) 132 133 tests :: TestTree 134 tests = testGroup "limb tests" [ 135 H.testCase "overflowing add, no carry" overflowing_add_no_carry 136 , H.testCase "overflowing add, carry" overflowing_add_with_carry 137 , H.testCase "wrapping add, no carry" wrapping_add_no_carry 138 , H.testCase "wrapping add, carry" wrapping_add_with_carry 139 , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow 140 , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow 141 , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow 142 , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow 143 , H.testCase "left shift (1)" shl1 144 , H.testCase "left shift (2)" shl2 145 , H.testCase "right shift (1)" shr1 146 , H.testCase "right shift (2)" shr2 147 , H.testCase "eq" eq 148 , H.testCase "gt" gt 149 , H.testCase "lt" lt 150 , H.testCase "cswap" cswap 151 ] 152