fixed

commit 6ad24b1ba0161bbf1b99b8e6bbc30b734cb02fdf
parent 02f8865b778515b4ecab6ff27b0ffc3e6c91ce9d
Author: Jared Tobin <jared@jtobin.io>
Date:   Sat,  1 Aug 2026 14:08:04 -0230

lib: fix shl1_c# carry mask

The carry bit was shifted back to the most significant position
before being passed to from_bit#, which expects 0 or 1. The
resulting Choice carried a 0x8000000000000000 mask rather than a
full-word one: 'decide' still gave the right answer, but negation
and constant-time selection on the carry were wrong.

Diffstat:
M
lib/Data/Word/Wider.hs
 | 
2
+-
M
test/Wider.hs
 | 
18
++++++++++++++++++

2 files changed, 19 insertions(+), 1 deletion(-)
diff --git a/lib/Data/Word/Wider.hs b/lib/Data/Word/Wider.hs
@@ -384,7 +384,7 @@ shl1_c# (# w0, w1, w2, w3 #) =
       !r2           = L.or# s2 c1
       !(# s3, c3 #) = (# L.shl# w3 1#, L.shr# w3 s #)
       !r3           = L.or# s3 c2
-      !(Limb w)     = L.shl# c3 s
+      !(Limb w)     = c3
   in  (# (# r0, r1, r2, r3 #), C.from_bit# w #)
 {-# INLINE shl1_c# #-}
 
diff --git a/test/Wider.hs b/test/Wider.hs
@@ -183,6 +183,23 @@ sub_mod = do
       !e = 0x44acf6b7e36c1342c2c5897204fe09504e1e2efb1a900377dbc4e7a6a133ec56
   H.assertBool mempty (W.eq_vartime o e)
 
+shl1_c :: H.Assertion
+shl1_c = case W.shl1_c (2 ^ (255 :: Word)) of
+  (# r1, c1 #) -> case W.shl1_c 1 of
+    (# r2, c2 #) -> do
+      H.assertBool "value, carry out" (W.eq_vartime r1 0)
+      H.assertBool "carry decides true" (C.decide c1)
+      -- the carry must be a full-word mask, not a bare bit; negating
+      -- or selecting on it is otherwise wrong
+      H.assertBool "negated carry decides false"
+        (not (C.decide (C.not c1)))
+      H.assertBool "select on carry"
+        (W.eq_vartime (W.select 0 1 c1) 1)
+      H.assertBool "value, no carry" (W.eq_vartime r2 2)
+      H.assertBool "no carry decides false" (not (C.decide c2))
+      H.assertBool "select on no carry"
+        (W.eq_vartime (W.select 0 1 c2) 0)
+
 instance Q.Arbitrary W.Wider where
   arbitrary = fmap W.to_vartime Q.arbitrary
 
@@ -216,6 +233,7 @@ tests = testGroup "wider tests" [
   , H.testCase "sqr" sqr
   , H.testCase "mul" mul
   , H.testCase "sub_mod" sub_mod
+  , H.testCase "shl1_c" shl1_c
   , Q.testProperty "odd w ~ odd (from w)" $ Q.withMaxSuccess 500 odd_correct
   , Q.testProperty "lt_vartime a b ~ from a < from b" $
       Q.withMaxSuccess 500 lt_vartime_correct