Wider.hs (8154B)
1 {-# OPTIONS_GHC -fno-warn-orphans #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE NumericUnderscores #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 7 module Wider ( 8 tests 9 ) where 10 11 import qualified Data.Choice as C 12 import qualified Data.Word.Wider as W 13 import qualified GHC.Num.Integer as I 14 import Test.Tasty 15 import qualified Test.Tasty.HUnit as H 16 import qualified Test.Tasty.QuickCheck as Q 17 18 overflowing_add_no_carry :: H.Assertion 19 overflowing_add_no_carry = do 20 let !(r, c) = W.add_o 1 0 21 H.assertBool mempty (W.eq_vartime r 1) 22 H.assertBool mempty (c == 0) 23 24 overflowing_add_with_carry :: H.Assertion 25 overflowing_add_with_carry = do 26 let !(r, c) = W.add_o (2 ^ (256 :: Word) - 1) 1 27 H.assertBool mempty (W.eq_vartime r 0) 28 H.assertBool mempty (c == 1) 29 30 wrapping_add_no_carry :: H.Assertion 31 wrapping_add_no_carry = do 32 let !r = W.add 0 1 33 H.assertBool mempty (W.eq_vartime r 1) 34 35 wrapping_add_with_carry :: H.Assertion 36 wrapping_add_with_carry = do 37 let !r = W.add (2 ^ (256 :: Word) - 1) 1 38 H.assertBool mempty (W.eq_vartime r 0) 39 40 borrowing_sub_no_borrow :: H.Assertion 41 borrowing_sub_no_borrow = do 42 let !(d, b) = W.sub_b 1 1 43 H.assertBool mempty (W.eq_vartime d 0) 44 H.assertBool mempty (b == 0) 45 46 borrowing_sub_with_borrow :: H.Assertion 47 borrowing_sub_with_borrow = do 48 let !(d, b) = W.sub_b 0 1 49 H.assertBool mempty (W.eq_vartime d (2 ^ (256 :: Word) - 1)) 50 H.assertBool mempty (b == (2 ^ (64 :: Word) - 1)) 51 52 wrapping_sub_no_borrow :: H.Assertion 53 wrapping_sub_no_borrow = do 54 let !r = W.sub 1 1 55 H.assertBool mempty (W.eq_vartime r 0) 56 57 wrapping_sub_with_borrow :: H.Assertion 58 wrapping_sub_with_borrow = do 59 let !r = W.sub 0 1 60 H.assertBool mempty (W.eq_vartime r (2 ^ (256 :: Word) - 1)) 61 62 eq :: H.Assertion 63 eq = do 64 let !(W.Wider a) = 0 65 !(W.Wider b) = 2 ^ (256 :: Word) - 1 66 H.assertBool mempty (C.decide (W.eq# a a)) 67 H.assertBool mempty (not (C.decide (W.eq# a b))) 68 H.assertBool mempty (not (C.decide (W.eq# b a))) 69 H.assertBool mempty (C.decide (W.eq# b b)) 70 -- eq# must yield a full-word mask, not a bare bit; negating or 71 -- selecting on it is otherwise wrong 72 H.assertBool mempty (not (C.decide (C.not (W.eq# a a)))) 73 H.assertBool mempty (C.decide (C.not (W.eq# a b))) 74 H.assertBool mempty 75 (W.eq_vartime (W.select (W.Wider a) (W.Wider b) (W.eq# a a)) (W.Wider b)) 76 77 gt :: H.Assertion 78 gt = do 79 let !(W.Wider a) = 0 80 !(W.Wider b) = 1 81 !(W.Wider c) = 2 ^ (256 :: Word) - 1 82 H.assertBool mempty (C.decide (W.gt# b a)) 83 H.assertBool mempty (C.decide (W.gt# c a)) 84 H.assertBool mempty (C.decide (W.gt# c b)) 85 86 H.assertBool mempty (not (C.decide (W.gt# a a))) 87 H.assertBool mempty (not (C.decide (W.gt# b b))) 88 H.assertBool mempty (not (C.decide (W.gt# c c))) 89 90 H.assertBool mempty (not (C.decide (W.gt# a b))) 91 H.assertBool mempty (not (C.decide (W.gt# a c))) 92 H.assertBool mempty (not (C.decide (W.gt# b c))) 93 94 lt :: H.Assertion 95 lt = do 96 let !(W.Wider a) = 0 97 !(W.Wider b) = 1 98 !(W.Wider c) = 2 ^ (256 :: Word) - 1 99 H.assertBool mempty (C.decide (W.lt# a b)) 100 H.assertBool mempty (C.decide (W.lt# a c)) 101 H.assertBool mempty (C.decide (W.lt# b c)) 102 103 H.assertBool mempty (not (C.decide (W.lt# a a))) 104 H.assertBool mempty (not (C.decide (W.lt# b b))) 105 H.assertBool mempty (not (C.decide (W.lt# c c))) 106 107 H.assertBool mempty (not (C.decide (W.lt# b a))) 108 H.assertBool mempty (not (C.decide (W.lt# c a))) 109 H.assertBool mempty (not (C.decide (W.lt# c b))) 110 111 gt_vartime :: H.Assertion 112 gt_vartime = do 113 let !a = 0 114 !b = 1 115 !c = 2 ^ (256 :: Word) - 1 116 H.assertBool mempty (W.gt_vartime b a) 117 H.assertBool mempty (W.gt_vartime c a) 118 H.assertBool mempty (W.gt_vartime c b) 119 120 H.assertBool mempty (not (W.gt_vartime a a)) 121 H.assertBool mempty (not (W.gt_vartime b b)) 122 H.assertBool mempty (not (W.gt_vartime c c)) 123 124 H.assertBool mempty (not (W.gt_vartime a b)) 125 H.assertBool mempty (not (W.gt_vartime a c)) 126 H.assertBool mempty (not (W.gt_vartime b c)) 127 128 lt_vartime :: H.Assertion 129 lt_vartime = do 130 let !a = 0 131 !b = 1 132 !c = 2 ^ (256 :: Word) - 1 133 H.assertBool mempty (W.lt_vartime a b) 134 H.assertBool mempty (W.lt_vartime a c) 135 H.assertBool mempty (W.lt_vartime b c) 136 137 H.assertBool mempty (not (W.lt_vartime a a)) 138 H.assertBool mempty (not (W.lt_vartime b b)) 139 H.assertBool mempty (not (W.lt_vartime c c)) 140 141 H.assertBool mempty (not (W.lt_vartime b a)) 142 H.assertBool mempty (not (W.lt_vartime c a)) 143 H.assertBool mempty (not (W.lt_vartime c b)) 144 145 cmp :: H.Assertion 146 cmp = do 147 let !a = 0 148 !b = 1 149 !c = 2 ^ (256 :: Word) - 1 150 H.assertEqual mempty (W.cmp_vartime a b) LT 151 H.assertEqual mempty (W.cmp_vartime a c) LT 152 H.assertEqual mempty (W.cmp_vartime b c) LT 153 154 H.assertEqual mempty (W.cmp_vartime a a) EQ 155 H.assertEqual mempty (W.cmp_vartime b b) EQ 156 H.assertEqual mempty (W.cmp_vartime c c) EQ 157 158 H.assertEqual mempty (W.cmp_vartime b a) GT 159 H.assertEqual mempty (W.cmp_vartime c a) GT 160 H.assertEqual mempty (W.cmp_vartime c b) GT 161 162 sqr :: H.Assertion 163 sqr = do 164 let !n = 2 ^ (256 :: Word) - 1 165 !(l, h ) = W.sqr n 166 H.assertBool mempty (W.eq_vartime l 1) 167 H.assertBool mempty (W.eq_vartime h (n - 1)) 168 169 mul :: H.Assertion 170 mul = do 171 let !n = 2 ^ (256 :: Word) - 1 172 H.assertBool mempty (W.eq_vartime (W.mul 0 n) 0) 173 H.assertBool mempty (W.eq_vartime (W.mul n 0) 0) 174 H.assertBool mempty (W.eq_vartime (W.mul n n) 1) 175 H.assertBool mempty (W.eq_vartime (W.mul 1 n) n) 176 177 sub_mod :: H.Assertion 178 sub_mod = do 179 let !a = 0x1a2472fde50286541d97ca6a3592dd75beb9c9646e40c511b82496cfc3926956 180 !b = 0xd5777c45019673125ad240f83094d4252d829516fac8601ed01979ec1ec1a251 181 !n = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551 182 !o = W.sub_mod a b n 183 !e = 0x44acf6b7e36c1342c2c5897204fe09504e1e2efb1a900377dbc4e7a6a133ec56 184 H.assertBool mempty (W.eq_vartime o e) 185 186 shl1_c :: H.Assertion 187 shl1_c = case W.shl1_c (2 ^ (255 :: Word)) of 188 (# r1, c1 #) -> case W.shl1_c 1 of 189 (# r2, c2 #) -> do 190 H.assertBool "value, carry out" (W.eq_vartime r1 0) 191 H.assertBool "carry decides true" (C.decide c1) 192 -- the carry must be a full-word mask, not a bare bit; negating 193 -- or selecting on it is otherwise wrong 194 H.assertBool "negated carry decides false" 195 (not (C.decide (C.not c1))) 196 H.assertBool "select on carry" 197 (W.eq_vartime (W.select 0 1 c1) 1) 198 H.assertBool "value, no carry" (W.eq_vartime r2 2) 199 H.assertBool "no carry decides false" (not (C.decide c2)) 200 H.assertBool "select on no carry" 201 (W.eq_vartime (W.select 0 1 c2) 0) 202 203 instance Q.Arbitrary W.Wider where 204 arbitrary = fmap W.to_vartime Q.arbitrary 205 206 odd_correct :: W.Wider -> Bool 207 odd_correct w = C.decide (W.odd w) == I.integerTestBit (W.from_vartime w) 0 208 209 lt_vartime_correct :: W.Wider -> W.Wider -> Bool 210 lt_vartime_correct a b = 211 W.lt_vartime a b == (W.from_vartime a < W.from_vartime b) 212 213 gt_vartime_correct :: W.Wider -> W.Wider -> Bool 214 gt_vartime_correct a b = 215 W.gt_vartime a b == (W.from_vartime a > W.from_vartime b) 216 217 tests :: TestTree 218 tests = testGroup "wider tests" [ 219 H.testCase "overflowing add, no carry" overflowing_add_no_carry 220 , H.testCase "overflowing add, carry" overflowing_add_with_carry 221 , H.testCase "wrapping add, no carry" wrapping_add_no_carry 222 , H.testCase "wrapping add, carry" wrapping_add_with_carry 223 , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow 224 , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow 225 , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow 226 , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow 227 , H.testCase "eq" eq 228 , H.testCase "gt" gt 229 , H.testCase "lt" lt 230 , H.testCase "gt_vartime" gt_vartime 231 , H.testCase "lt_vartime" lt_vartime 232 , H.testCase "cmp" cmp 233 , H.testCase "sqr" sqr 234 , H.testCase "mul" mul 235 , H.testCase "sub_mod" sub_mod 236 , H.testCase "shl1_c" shl1_c 237 , Q.testProperty "odd w ~ odd (from w)" $ Q.withMaxSuccess 500 odd_correct 238 , Q.testProperty "lt_vartime a b ~ from a < from b" $ 239 Q.withMaxSuccess 500 lt_vartime_correct 240 , Q.testProperty "gt_vartime a b ~ from a > from b" $ 241 Q.withMaxSuccess 500 gt_vartime_correct 242 ] 243