Choice.hs (8611B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE MagicHash #-} 3 {-# LANGUAGE UnliftedNewtypes #-} 4 {-# LANGUAGE UnboxedTuples #-} 5 {-# LANGUAGE ViewPatterns #-} 6 7 module Data.Choice ( 8 -- * Choice 9 Choice 10 , true# 11 , false# 12 , decide 13 , to_word# 14 15 -- * MaybeWord# 16 , MaybeWord#(..) 17 , some_word# 18 , none_word# 19 20 -- * MaybeWide# 21 , MaybeWide#(..) 22 , some_wide# 23 , just_wide# 24 , none_wide# 25 , expect_wide# 26 , expect_wide_or# 27 28 -- * Construction 29 , from_word_mask# 30 , from_word_lsb# 31 , from_word_nonzero# 32 , from_word_eq# 33 , from_word_le# 34 , from_word_lt# 35 , from_word_gt# 36 37 , from_wide_lsb# 38 , from_wide_le# 39 40 -- * Manipulation 41 , or_c# 42 , and_c# 43 , xor_c# 44 , not_c# 45 , ne_c# 46 , eq_c# 47 48 -- * Constant-time Selection 49 , ct_select_word# 50 , ct_select_wide# 51 52 -- * Constant-time Equality 53 , ct_eq_word# 54 , ct_eq_wide# 55 , ct_eq_wider# 56 ) where 57 58 import qualified Data.Bits as B 59 import GHC.Exts 60 61 -- utilities ------------------------------------------------------------------ 62 63 -- make a mask from a bit (0 -> 0, 1 -> maxBound) 64 wrapping_neg# :: Word# -> Word# 65 wrapping_neg# w = plusWord# (not# w) 1## 66 {-# INLINE wrapping_neg# #-} 67 68 hi# :: Word# -> (# Word#, Word# #) 69 hi# w = (# 0##, w #) 70 {-# INLINE hi# #-} 71 72 lo# :: Word# -> (# Word#, Word# #) 73 lo# w = (# w, 0## #) 74 {-# INLINE lo# #-} 75 76 not_w# :: (# Word#, Word# #) -> (# Word#, Word# #) 77 not_w# (# a0, a1 #) = (# not# a0, not# a1 #) 78 {-# INLINE not_w# #-} 79 80 or_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) 81 or_w# (# a0, a1 #) (# b0, b1 #) = (# or# a0 b0, or# a1 b1 #) 82 {-# INLINE or_w# #-} 83 84 and_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) 85 and_w# (# a0, a1 #) (# b0, b1 #) = (# and# a0 b0, and# a1 b1 #) 86 {-# INLINE and_w# #-} 87 88 xor_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) 89 xor_w# (# a0, a1 #) (# b0, b1 #) = (# xor# a0 b0, xor# a1 b1 #) 90 {-# INLINE xor_w# #-} 91 92 -- subtract-with-borrow 93 sub_b# :: Word# -> Word# -> Word# -> (# Word#, Word# #) 94 sub_b# m n b = 95 let !(# d0, b0 #) = subWordC# m n 96 !(# d, b1 #) = subWordC# d0 b 97 !c = int2Word# (orI# b0 b1) 98 in (# d, c #) 99 {-# INLINE sub_b# #-} 100 101 -- wide subtract-with-borrow 102 sub_wb# 103 :: (# Word#, Word# #) 104 -> (# Word#, Word# #) 105 -> (# Word#, Word#, Word# #) 106 sub_wb# (# a0, a1 #) (# b0, b1 #) = 107 let !(# s0, c0 #) = sub_b# a0 b0 0## 108 !(# s1, c1 #) = sub_b# a1 b1 c0 109 in (# s0, s1, c1 #) 110 {-# INLINE sub_wb# #-} 111 112 -- wide subtraction (wrapping) 113 sub_w# :: (# Word#, Word# #) -> (# Word#, Word# #) -> (# Word#, Word# #) 114 sub_w# a b = 115 let !(# c0, c1, _ #) = sub_wb# a b 116 in (# c0, c1 #) 117 {-# INLINE sub_w# #-} 118 119 -- choice --------------------------------------------------------------------- 120 121 -- constant-time choice, encoded as a mask 122 newtype Choice = Choice Word# 123 124 false# :: () -> Choice 125 false# _ = Choice 0## 126 {-# INLINE false# #-} 127 128 true# :: () -> Choice 129 true# _ = case maxBound :: Word of 130 W# w -> Choice w 131 {-# INLINE true# #-} 132 133 decide :: Choice -> Bool 134 decide (Choice c) = isTrue# (neWord# c 0##) 135 {-# INLINE decide #-} 136 137 to_word# :: Choice -> Word# 138 to_word# (Choice c) = and# c 1## 139 {-# INLINE to_word# #-} 140 141 -- constant time 'Maybe Word#' 142 newtype MaybeWord# = MaybeWord# (# Word#, Choice #) 143 144 some_word# :: Word# -> MaybeWord# 145 some_word# w = MaybeWord# (# w, true# () #) 146 {-# INLINE some_word# #-} 147 148 none_word# :: Word# -> MaybeWord# 149 none_word# w = MaybeWord# (# w, false# () #) 150 {-# INLINE none_word# #-} 151 152 -- constant time 'Maybe (# Word#, Word# #)' 153 newtype MaybeWide# = MaybeWide# (# (# Word#, Word# #), Choice #) 154 155 just_wide# :: (# Word#, Word# #) -> Choice -> MaybeWide# 156 just_wide# w c = MaybeWide# (# w, c #) 157 {-# INLINE just_wide# #-} 158 159 some_wide# :: (# Word#, Word# #) -> MaybeWide# 160 some_wide# w = MaybeWide# (# w, true# () #) 161 {-# INLINE some_wide# #-} 162 163 none_wide# :: (# Word#, Word# #) -> MaybeWide# 164 none_wide# w = MaybeWide# (# w, false# () #) 165 {-# INLINE none_wide# #-} 166 167 expect_wide# :: MaybeWide# -> String -> (# Word#, Word# #) 168 expect_wide# (MaybeWide# (# w, Choice c #)) msg 169 | isTrue# (eqWord# c t#) = w 170 | otherwise = error $ "ppad-fixed (expect_wide#): " <> msg 171 where 172 !(Choice t#) = true# () 173 {-# INLINE expect_wide# #-} 174 175 expect_wide_or# :: MaybeWide# -> (# Word#, Word# #) -> (# Word#, Word# #) 176 expect_wide_or# (MaybeWide# (# w, Choice c #)) alt 177 | isTrue# (eqWord# c t#) = w 178 | otherwise = alt 179 where 180 !(Choice t#) = true# () 181 {-# INLINE expect_wide_or# #-} 182 183 -- construction --------------------------------------------------------------- 184 185 from_word_mask# :: Word# -> Choice 186 from_word_mask# w = Choice w 187 {-# INLINE from_word_mask# #-} 188 189 from_word_lsb# :: Word# -> Choice 190 from_word_lsb# w = Choice (wrapping_neg# w) 191 {-# INLINE from_word_lsb# #-} 192 193 from_wide_lsb# :: (# Word#, Word# #) -> Choice 194 from_wide_lsb# (# l, _ #) = from_word_lsb# l 195 {-# INLINE from_wide_lsb# #-} 196 197 from_word_nonzero# :: Word# -> Choice 198 from_word_nonzero# w = 199 let !n = wrapping_neg# w 200 !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 201 !v = uncheckedShiftRL# (or# w n) s 202 in from_word_lsb# v 203 {-# INLINE from_word_nonzero# #-} 204 205 from_word_eq# :: Word# -> Word# -> Choice 206 from_word_eq# x y = case from_word_nonzero# (xor# x y) of 207 Choice w -> Choice (not# w) 208 {-# INLINE from_word_eq# #-} 209 210 from_word_le# :: Word# -> Word# -> Choice 211 from_word_le# x y = 212 let !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 213 !bit = 214 uncheckedShiftRL# 215 (and# 216 (or# (not# x) y) 217 (or# (xor# x y) (not# (minusWord# y x)))) 218 s 219 in from_word_lsb# bit 220 {-# INLINE from_word_le# #-} 221 222 from_wide_le# :: (# Word#, Word# #) -> (# Word#, Word# #) -> Choice 223 from_wide_le# x y = 224 let !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 225 !mask = 226 (and_w# 227 (or_w# (not_w# x) y) 228 (or_w# (xor_w# x y) (not_w# (sub_w# y x)))) 229 !bit = case mask of 230 (# l, _ #) -> uncheckedShiftRL# l s 231 in from_word_lsb# bit 232 {-# INLINE from_wide_le# #-} 233 234 from_word_lt# :: Word# -> Word# -> Choice 235 from_word_lt# x y = 236 let !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 237 !bit = 238 uncheckedShiftRL# 239 (or# 240 (and# (not# x) y) 241 (and# (or# (not# x) y) (minusWord# x y))) 242 s 243 in from_word_lsb# bit 244 {-# INLINE from_word_lt# #-} 245 246 from_word_gt# :: Word# -> Word# -> Choice 247 from_word_gt# x y = from_word_lt# y x 248 {-# INLINE from_word_gt# #-} 249 250 -- manipulation --------------------------------------------------------------- 251 252 not_c# :: Choice -> Choice 253 not_c# (Choice w) = Choice (not# w) 254 {-# INLINE not_c# #-} 255 256 or_c# :: Choice -> Choice -> Choice 257 or_c# (Choice w0) (Choice w1) = Choice (or# w0 w1) 258 {-# INLINE or_c# #-} 259 260 and_c# :: Choice -> Choice -> Choice 261 and_c# (Choice w0) (Choice w1) = Choice (and# w0 w1) 262 {-# INLINE and_c# #-} 263 264 xor_c# :: Choice -> Choice -> Choice 265 xor_c# (Choice w0) (Choice w1) = Choice (xor# w0 w1) 266 {-# INLINE xor_c# #-} 267 268 ne_c# :: Choice -> Choice -> Choice 269 ne_c# c0 c1 = xor_c# c0 c1 270 {-# INLINE ne_c# #-} 271 272 eq_c# :: Choice -> Choice -> Choice 273 eq_c# c0 c1 = not_c# (ne_c# c0 c1) 274 {-# INLINE eq_c# #-} 275 276 -- constant-time selection ---------------------------------------------------- 277 278 ct_select_word# :: Word# -> Word# -> Choice -> Word# 279 ct_select_word# a b (Choice c) = xor# a (and# c (xor# a b)) 280 {-# INLINE ct_select_word# #-} 281 282 ct_select_wide# 283 :: (# Word#, Word# #) 284 -> (# Word#, Word# #) 285 -> Choice 286 -> (# Word#, Word# #) 287 ct_select_wide# a b (Choice w) = 288 let !mask = or_w# (hi# w) (lo# w) 289 in xor_w# a (and_w# mask (xor_w# a b)) 290 {-# INLINE ct_select_wide# #-} 291 292 -- constant-time equality ----------------------------------------------------- 293 294 ct_eq_word# :: Word# -> Word# -> Choice 295 ct_eq_word# a b = 296 let !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 297 !x = xor# a b 298 !y = uncheckedShiftRL# (or# x (wrapping_neg# x)) s 299 in Choice (xor# y 1##) 300 {-# INLINE ct_eq_word# #-} 301 302 ct_eq_wide# 303 :: (# Word#, Word# #) 304 -> (# Word#, Word# #) 305 -> Choice 306 ct_eq_wide# (# a0, a1 #) (# b0, b1 #) = 307 let !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 308 !x = or# (xor# a0 b0) (xor# a1 b1) 309 !y = uncheckedShiftRL# (or# x (wrapping_neg# x)) s 310 in Choice (xor# y 1##) 311 {-# INLINE ct_eq_wide# #-} 312 313 ct_eq_wider# 314 :: (# Word#, Word#, Word#, Word# #) 315 -> (# Word#, Word#, Word#, Word# #) 316 -> Choice 317 ct_eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) = 318 let !s = case B.finiteBitSize (0 :: Word) of I# m -> m -# 1# 319 !x = or# (or# (xor# a0 b0) (xor# a1 b1)) 320 (or# (xor# a2 b2) (xor# a3 b3)) 321 !y = uncheckedShiftRL# (or# x (wrapping_neg# x)) s 322 in Choice (xor# y 1##) 323 {-# INLINE ct_eq_wider# #-} 324