Limb.hs (5262B)
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 -- eq# must yield a full-word mask, not a bare bit; negating or 88 -- selecting on it is otherwise wrong 89 H.assertBool mempty (not (C.decide (L.ne# a a))) 90 H.assertBool mempty (C.decide (L.ne# a b)) 91 H.assertBool mempty (L.eq_vartime# (L.select# a b (L.eq# a a)) b) 92 93 gt :: H.Assertion 94 gt = do 95 let !a = L.Limb 0## 96 !b = L.Limb 1## 97 !c = L.Limb (not# 0##) 98 H.assertBool mempty (C.decide (L.gt# b a)) 99 H.assertBool mempty (C.decide (L.gt# c a)) 100 H.assertBool mempty (C.decide (L.gt# c b)) 101 102 H.assertBool mempty (not (C.decide (L.gt# a a))) 103 H.assertBool mempty (not (C.decide (L.gt# b b))) 104 H.assertBool mempty (not (C.decide (L.gt# c c))) 105 106 H.assertBool mempty (not (C.decide (L.gt# a b))) 107 H.assertBool mempty (not (C.decide (L.gt# a c))) 108 H.assertBool mempty (not (C.decide (L.gt# b c))) 109 110 lt :: H.Assertion 111 lt = do 112 let !a = L.Limb 0## 113 !b = L.Limb 1## 114 !c = L.Limb (not# 0##) 115 H.assertBool mempty (C.decide (L.lt# a b)) 116 H.assertBool mempty (C.decide (L.lt# a c)) 117 H.assertBool mempty (C.decide (L.lt# b c)) 118 119 H.assertBool mempty (not (C.decide (L.lt# a a))) 120 H.assertBool mempty (not (C.decide (L.lt# b b))) 121 H.assertBool mempty (not (C.decide (L.lt# c c))) 122 123 H.assertBool mempty (not (C.decide (L.lt# b a))) 124 H.assertBool mempty (not (C.decide (L.lt# c a))) 125 H.assertBool mempty (not (C.decide (L.lt# c b))) 126 127 cswap :: H.Assertion 128 cswap = do 129 let !a = L.Limb (not# 0##) 130 !b = L.Limb 0## 131 !(# a0, b0 #) = L.cswap# a b (C.false# ()) 132 H.assertBool mempty (L.eq_vartime# a0 (L.Limb (not# 0##))) 133 H.assertBool mempty (L.eq_vartime# b0 (L.Limb 0##)) 134 let !(# a1, b1 #) = L.cswap# a0 b0 (C.true# ()) 135 H.assertBool mempty (L.eq_vartime# a1 (L.Limb 0##)) 136 H.assertBool mempty (L.eq_vartime# b1 (L.Limb (not# 0##))) 137 138 tests :: TestTree 139 tests = testGroup "limb tests" [ 140 H.testCase "overflowing add, no carry" overflowing_add_no_carry 141 , H.testCase "overflowing add, carry" overflowing_add_with_carry 142 , H.testCase "wrapping add, no carry" wrapping_add_no_carry 143 , H.testCase "wrapping add, carry" wrapping_add_with_carry 144 , H.testCase "borrowing sub, no borrow" borrowing_sub_no_borrow 145 , H.testCase "borrowing sub, borrow" borrowing_sub_with_borrow 146 , H.testCase "wrapping sub, no borrow" wrapping_sub_no_borrow 147 , H.testCase "wrapping sub, borrow" wrapping_sub_with_borrow 148 , H.testCase "left shift (1)" shl1 149 , H.testCase "left shift (2)" shl2 150 , H.testCase "right shift (1)" shr1 151 , H.testCase "right shift (2)" shr2 152 , H.testCase "eq" eq 153 , H.testCase "gt" gt 154 , H.testCase "lt" lt 155 , H.testCase "cswap" cswap 156 ] 157