fixed

commit 8cfb7d72240bdc20dc534085d23af7bc0528d387
parent 74ebe44f818353129c5ec973a55c8bc487e2fd7b
Author: Jared Tobin <jared@jtobin.io>
Date:   Sat,  1 Aug 2026 09:44:34 -0230

lib: full-word masks from constant-time equality

The eq_word#, eq_wide#, and eq_wider# primitives wrapped a bare 0/1
bit directly in the Choice constructor, violating the invariant that
a Choice is a full-word mask. 'decide' happened to work (it only
checks nonzero), but logical negation and constant-time selection
were silently wrong on equality-derived Choice values: 'not' on
Choice 1 yields a still-truthy word, and the select functions AND
the mask against (a xor b), so a mask of 1 selected only the low
bit of the second operand.

Route the comparison bit through from_bit#, which negates it into a
proper mask. With this, every remaining raw Choice construction in
Data.Choice yields a full-word mask.

Add regression tests at each width (Limb, Wide, Wider) covering
negation and selection on equality-derived Choice values; under the
old encoding all of them fail.

Diffstat:
M
lib/Data/Choice.hs
 | 
6
+++---
M
test/Limb.hs
 | 
5
+++++
M
test/Wide.hs
 | 
15
+++++++++++++++
M
test/Wider.hs
 | 
6
++++++

4 files changed, 29 insertions(+), 3 deletions(-)
diff --git a/lib/Data/Choice.hs b/lib/Data/Choice.hs
@@ -347,7 +347,7 @@ eq_word# a b =
   let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1#
       !x = Exts.xor# a b
       !y = Exts.uncheckedShiftRL# (Exts.or# x (neg_w# x)) s
-  in  Choice (Exts.xor# y 1##)
+  in  from_bit# (Exts.xor# y 1##)
 {-# INLINE eq_word# #-}
 
 -- | Compare unboxed two-limb words for equality in constant time.
@@ -362,7 +362,7 @@ eq_wide# (# a0, a1 #) (# b0, b1 #) =
   let !s = case B.finiteBitSize (0 :: Word) of I# m -> m Exts.-# 1#
       !x = Exts.or# (Exts.xor# a0 b0) (Exts.xor# a1 b1)
       !y = Exts.uncheckedShiftRL# (Exts.or# x (neg_w# x)) s
-  in  Choice (Exts.xor# y 1##)
+  in  from_bit# (Exts.xor# y 1##)
 {-# INLINE eq_wide# #-}
 
 -- | Compare unboxed four-limb words for equality in constant time.
@@ -378,6 +378,6 @@ eq_wider# (# a0, a1, a2, a3 #) (# b0, b1, b2, b3 #) =
       !x = Exts.or# (Exts.or# (Exts.xor# a0 b0) (Exts.xor# a1 b1))
                     (Exts.or# (Exts.xor# a2 b2) (Exts.xor# a3 b3))
       !y = Exts.uncheckedShiftRL# (Exts.or# x (neg_w# x)) s
-  in  Choice (Exts.xor# y 1##)
+  in  from_bit# (Exts.xor# y 1##)
 {-# INLINE eq_wider# #-}
 
diff --git a/test/Limb.hs b/test/Limb.hs
@@ -84,6 +84,11 @@ eq = do
   H.assertBool mempty (not (C.decide (L.eq# a b)))
   H.assertBool mempty (not (C.decide (L.eq# b a)))
   H.assertBool mempty (C.decide (L.eq# b b))
+  -- eq# must yield a full-word mask, not a bare bit; negating or
+  -- selecting on it is otherwise wrong
+  H.assertBool mempty (not (C.decide (L.ne# a a)))
+  H.assertBool mempty (C.decide (L.ne# a b))
+  H.assertBool mempty (L.eq_vartime# (L.select# a b (L.eq# a a)) b)
 
 gt :: H.Assertion
 gt = do
diff --git a/test/Wide.hs b/test/Wide.hs
@@ -6,6 +6,7 @@ module Wide (
     tests
   ) where
 
+import qualified Data.Choice as C
 import qualified Data.Word.Wide as W
 import Test.Tasty
 import qualified Test.Tasty.HUnit as H
@@ -32,11 +33,25 @@ wrapping_add_with_carry = do
   let !r = W.add (2 ^ (128 :: Word) - 1) 1
   H.assertBool mempty (W.eq_vartime r 0)
 
+eq :: H.Assertion
+eq = do
+  let !a = 0 :: W.Wide
+      !b = 2 ^ (128 :: Word) - 1
+  H.assertBool mempty (C.decide (W.eq a a))
+  H.assertBool mempty (not (C.decide (W.eq a b)))
+  H.assertBool mempty (C.decide (W.eq b b))
+  -- eq must yield a full-word mask, not a bare bit; negating or
+  -- selecting on it is otherwise wrong
+  H.assertBool mempty (not (C.decide (C.not (W.eq a a))))
+  H.assertBool mempty (C.decide (C.not (W.eq a b)))
+  H.assertBool mempty (W.eq_vartime (W.select a b (W.eq a a)) b)
+
 tests :: TestTree
 tests = testGroup "wide tests" [
     H.testCase "overflowing add, no carry" overflowing_add_no_carry
   , H.testCase "overflowing add, carry" overflowing_add_with_carry
   , H.testCase "wrapping add, no carry" wrapping_add_no_carry
   , H.testCase "wrapping add, carry" wrapping_add_with_carry
+  , H.testCase "eq" eq
   ]
 
diff --git a/test/Wider.hs b/test/Wider.hs
@@ -67,6 +67,12 @@ eq = do
   H.assertBool mempty (not (C.decide (W.eq# a b)))
   H.assertBool mempty (not (C.decide (W.eq# b a)))
   H.assertBool mempty (C.decide (W.eq# b b))
+  -- eq# must yield a full-word mask, not a bare bit; negating or
+  -- selecting on it is otherwise wrong
+  H.assertBool mempty (not (C.decide (C.not (W.eq# a a))))
+  H.assertBool mempty (C.decide (C.not (W.eq# a b)))
+  H.assertBool mempty
+    (W.eq_vartime (W.select (W.Wider a) (W.Wider b) (W.eq# a a)) (W.Wider b))
 
 gt :: H.Assertion
 gt = do