Zubin pushed to branch ghc-9.10 at Glasgow Haskell Compiler / GHC Commits: dea3e5d6 by Teo Camarasu at 2025-08-17T22:31:50+05:30 rts: ensure MessageBlackHole.link is always a valid closure We turn a MessageBlackHole into an StgInd in wakeBlockingQueue(). Therefore it's important that the link field, which becomes the indirection field, always points to a valid closure. It's unclear whether it's currently possible for the previous behaviour to lead to a crash, but it's good to be consistent about this invariant nonetheless. Co-authored-by: Andreas Klebinger (cherry picked from commit a8b2fbae6bcf20bc2f3fe58803096d2a9c5fc43d) - - - - - 97299e94 by Teo Camarasu at 2025-08-17T22:31:57+05:30 rts: spin if we see a WHITEHOLE in messageBlackHole When a BLACKHOLE gets cancelled in raiseAsync, we indirect to a THUNK. GC can then shortcut this, replacing our BLACKHOLE with a fresh THUNK. This THUNK is not guaranteed to have a valid indirectee field. If at the same time, a message intended for the previous BLACKHOLE is processed and concurrently we BLACKHOLE the THUNK, thus temporarily turning it into a WHITEHOLE, we can get a segfault, since we look at the undefined indirectee field of the THUNK The fix is simple: spin if we see a WHITEHOLE, and it will soon be replaced with a valid BLACKHOLE. Resolves #26205 (cherry picked from commit 4021181ee0860aca2054883a531f3312361cc701) - - - - - 2e47cd55 by Reed Mullanix at 2025-08-17T22:33:53+05:30 ghc-internal: Fix naturalAndNot for NB/NS case When the first argument to `naturalAndNot` is larger than a `Word` and the second is `Word`-sized, `naturalAndNot` will truncate the result: ```

...

...

naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3) 0

In contrast, `naturalAndNot` does not truncate when both arguments are larger than a `Word`, so this appears to be a bug.
Luckily, the fix is pretty easy: we just need to call `bigNatAndNotWord#` instead of truncating.

Fixes #26230

(cherry picked from commit a766286fe759251eceb304c54ba52841c2a51f86)

- - - - -
1ea64785 by sheaf at 2025-08-17T22:36:18+05:30
RecordCon lookup: don't allow a TyCon

This commit adds extra logic when looking up a record constructor.
If GHC.Rename.Env.lookupOccRnConstr returns a TyCon (as it may, due to
the logic explained in Note [Pattern to type (P2T) conversion]),
we emit an error saying that the data constructor is not in scope.

This avoids the compiler falling over shortly thereafter, in the call to
'lookupConstructorInfo' inside 'GHC.Rename.Env.lookupRecFieldOcc',
because the record constructor would not have been a ConLike.

Fixes #25056

(cherry picked from commit da306610b9e58cfb7cf2530ebeec7ee8ad17183a)

- - - - -


23 changed files:

- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Env.hs
- libraries/base/changelog.md
- libraries/ghc-bignum/changelog.md
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- rts/Messages.c
- rts/StgMiscClosures.cmm
- rts/Updates.h
- + testsuite/tests/numeric/should_run/T26230.hs
- + testsuite/tests/numeric/should_run/T26230.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/rename/should_fail/T25056.hs
- + testsuite/tests/rename/should_fail/T25056.stderr
- + testsuite/tests/rename/should_fail/T25056a.hs
- + testsuite/tests/rename/should_fail/T25056b.hs
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/typecheck/should_fail/T23739b.hs
- testsuite/tests/typecheck/should_fail/T23739b.stderr
- + testsuite/tests/typecheck/should_fail/T23739c.hs
- + testsuite/tests/typecheck/should_fail/T23739c.stderr
- testsuite/tests/typecheck/should_fail/all.T


Changes:

=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -436,6 +436,7 @@ lookupConstructorInfo con_name
        ; case info of
             IAmConLike con_info -> return con_info
             UnboundGRE          -> return ConHasPositionalArgs
+            IAmTyCon {}         -> failIllegalTyCon WL_Constructor con_name
             _ -> pprPanic "lookupConstructorInfo: not a ConLike" $
                       vcat [ text "name:" <+> ppr con_name ]
        }
@@ -1029,24 +1030,12 @@ lookupOccRn' which_suggest rdr_name
 lookupOccRn :: RdrName -> RnM Name
 lookupOccRn = lookupOccRn' WL_Anything
 
--- lookupOccRnConstr looks up an occurrence of a RdrName and displays
--- constructors and pattern synonyms as suggestions if it is not in scope
+-- | Look up an occurrence of a 'RdrName'.
 --
--- There is a fallback to the type level, when the first lookup fails.
--- This is required to implement a pat-to-type transformation
--- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
--- Consider this example:
+-- Displays constructors and pattern synonyms as suggestions if
+-- it is not in scope.
 --
---   data VisProxy a where VP :: forall a -> VisProxy a
---
---   f :: VisProxy Int -> ()
---   f (VP Int) = ()
---
--- Here `Int` is actually a type, but it stays on position where
--- we expect a data constructor.
---
--- In all other cases we just use this additional lookup for better
--- error messaging (See Note [Promotion]).
+-- See Note [lookupOccRnConstr]
 lookupOccRnConstr :: RdrName -> RnM Name
 lookupOccRnConstr rdr_name
   = do { mb_gre <- lookupOccRn_maybe rdr_name
@@ -1058,6 +1047,28 @@ lookupOccRnConstr rdr_name
               Just gre -> return $ greName gre
               Nothing ->  reportUnboundName' WL_Constructor rdr_name} }
 
+{- Note [lookupOccRnConstr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupOccRnConstr looks up a data constructor or pattern synonym. Simple.
+
+However, there is a fallback to the type level when the lookup fails.
+This is required to implement a pat-to-type transformation
+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+
+Consider this example:
+
+  data VisProxy a where VP :: forall a -> VisProxy a
+
+  f :: VisProxy Int -> ()
+  f (VP Int) = ()
+
+Here `Int` is actually a type, but it occurs in a position in which we expect
+a data constructor.
+
+In all other cases we just use this additional lookup for better
+error messaging (See Note [Promotion]).
+-}
+
 -- lookupOccRnRecField looks up an occurrence of a RdrName and displays
 -- record fields as suggestions if it is not in scope
 lookupOccRnRecField :: RdrName -> RnM Name


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -532,9 +532,9 @@ rnExpr (ExplicitSum _ alt arity expr)
   = do { (expr', fvs) <- rnLExpr expr
        ; return (ExplicitSum noExtField alt arity expr', fvs) }
 
-rnExpr (RecordCon { rcon_con = con_id
+rnExpr (RecordCon { rcon_con = con_rdr
                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_rdr
        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
        ; (flds', fvss) <- mapAndUnzipM rn_field flds
        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1161,7 +1161,7 @@ tc_infer_id id_name
 
              AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
              AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
-             (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon
+             (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything (tyConName tc)
              ATyVar name _ -> failIllegalTyVal name
 
              _ -> failWithTc $ TcRnExpectedValueId thing }


=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -280,7 +280,7 @@ tcLookupConLike name = do
     thing <- tcLookupGlobal name
     case thing of
         AConLike cl -> return cl
-        ATyCon tc   -> failIllegalTyCon WL_Constructor tc
+        ATyCon  {}  -> failIllegalTyCon WL_Constructor name
         _           -> wrongThingErr WrongThingConLike (AGlobal thing) name
 
 tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
@@ -353,19 +353,20 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
     lookupThing = tcLookupGlobal
 
 -- Illegal term-level use of type things
-failIllegalTyCon :: WhatLooking -> TyCon -> TcM a
+failIllegalTyCon :: WhatLooking -> Name -> TcM a
 failIllegalTyVal :: Name -> TcM a
 (failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)
   where
-    fail_tycon what_looking tc = do
+    fail_tycon what_looking tc_nm = do
       gre <- getGlobalRdrEnv
-      let nm = tyConName tc
-          pprov = case lookupGRE_Name gre nm of
+      let mb_gre = lookupGRE_Name gre tc_nm
+          pprov = case mb_gre of
                       Just gre -> nest 2 (pprNameProvenance gre)
                       Nothing  -> empty
-          err | isClassTyCon tc = ClassTE
-              | otherwise       = TyConTE
-      fail_with_msg what_looking dataName nm pprov err
+          err = case greInfo <$> mb_gre of
+            Just (IAmTyCon ClassFlavour) -> ClassTE
+            _ -> TyConTE
+      fail_with_msg what_looking dataName tc_nm pprov err
 
     fail_tyvar nm =
       let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))


=====================================
libraries/base/changelog.md
=====================================
@@ -2,6 +2,7 @@
 
 ## 4.20.2 *July 2025*
   * Fix incorrect results of `integerPowMod` when the base is 0 and the exponent is negative, and `integerRecipMod` when the modulus is zero ([#26017](https://gitlab.haskell.org/ghc/ghc/-/issues/26017)).
+  * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350))
 
 ## 4.20.1 *Jan 2025*
   * Shipped with GHC 9.10.2


=====================================
libraries/ghc-bignum/changelog.md
=====================================
@@ -4,6 +4,7 @@
 
 - Expose backendName
 - Add `naturalSetBit[#]` (#21173), `naturalClearBit[#]` (#21175), `naturalComplementBit[#]` (#21181)
+- Fix bug where `naturalAndNot` was incorrectly truncating results (#26230)
 
 ## 1.2
 


=====================================
libraries/ghc-bignum/src/GHC/Num/Natural.hs
=====================================
@@ -488,7 +488,7 @@ naturalAndNot :: Natural -> Natural -> Natural
 {-# NOINLINE naturalAndNot #-}
 naturalAndNot (NS n) (NS m) = NS (n `and#` not# m)
 naturalAndNot (NS n) (NB m) = NS (n `and#` not# (bigNatToWord# m))
-naturalAndNot (NB n) (NS m) = NS (bigNatToWord# n `and#` not# m)
+naturalAndNot (NB n) (NS m) = NB (bigNatAndNotWord# n m)
 naturalAndNot (NB n) (NB m) = naturalFromBigNat# (bigNatAndNot n m)
 
 naturalOr :: Natural -> Natural -> Natural


=====================================
rts/Messages.c
=====================================
@@ -180,13 +180,22 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg)
         bh_info != &stg_CAF_BLACKHOLE_info &&
         bh_info != &__stg_EAGER_BLACKHOLE_info &&
         bh_info != &stg_WHITEHOLE_info) {
-        // if it is a WHITEHOLE, then a thread is in the process of
-        // trying to BLACKHOLE it.  But we know that it was once a
-        // BLACKHOLE, so there is at least a valid pointer in the
-        // payload, so we can carry on.
         return 0;
     }
 
+    // If we see a WHITEHOLE then we should wait for it to turn into a BLACKHOLE.
+    // Otherwise we might look at the indirectee and segfault.
+    // See "Exception handling" in Note [Thunks, blackholes, and indirections]
+    // We might be looking at a *fresh* THUNK being WHITEHOLE-d so we can't
+    // guarantee that the indirectee is a valid pointer.
+#if defined(THREADED_RTS)
+    if (bh_info == &stg_WHITEHOLE_info) {
+      while(ACQUIRE_LOAD(&bh->header.info) == &stg_WHITEHOLE_info) {
+        busy_wait_nop();
+      }
+    }
+#endif
+
     // The blackhole must indirect to a TSO, a BLOCKING_QUEUE, an IND,
     // or a value.
     StgClosure *p;


=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -31,6 +31,7 @@ import CLOSURE ENT_VIA_NODE_ctr;
 import CLOSURE RtsFlags;
 import CLOSURE stg_BLOCKING_QUEUE_CLEAN_info;
 import CLOSURE stg_BLOCKING_QUEUE_DIRTY_info;
+import CLOSURE stg_END_TSO_QUEUE_closure;
 import CLOSURE stg_IND_info;
 import CLOSURE stg_MSG_BLACKHOLE_info;
 import CLOSURE stg_TSO_info;
@@ -597,6 +598,9 @@ retry:
 
         MessageBlackHole_tso(msg) = CurrentTSO;
         MessageBlackHole_bh(msg) = node;
+        // Ensure that the link field is a valid closure,
+        // since we might turn this into an indirection in wakeBlockingQueue()
+        MessageBlackHole_link(msg) = stg_END_TSO_QUEUE_closure;
         SET_HDR(msg, stg_MSG_BLACKHOLE_info, CCS_SYSTEM);
         // messageBlackHole has appropriate memory barriers when this object is exposed.
         // See Note [Heap memory barriers].


=====================================
rts/Updates.h
=====================================
@@ -333,6 +333,10 @@
  * `AP_STACK` closure recording the aborted execution state.
  * See `RaiseAsync.c:raiseAsync` for details.
  *
+ * This can combine with indirection shortcutting during GC to replace a BLACKHOLE
+ * with a fresh THUNK. We should be very careful here since the THUNK will have an
+ * undefined value in the indirectee field. Looking at the indirectee field can then
+ * lead to a segfault such as #26205.
  *
  * CAFs
  * ----


=====================================
testsuite/tests/numeric/should_run/T26230.hs
=====================================
@@ -0,0 +1,8 @@
+import Data.Bits
+import GHC.Num.Natural
+
+main = do
+  print $ naturalAndNot ((2 ^ 4) .|. (2 ^ 3)) (2 ^ 3)
+  print $ naturalAndNot ((2 ^ 129) .|. (2 ^ 65)) (2 ^ 65)
+  print $ naturalAndNot ((2 ^ 4) .|. (2 ^ 3)) ((2 ^ 65) .|. (2 ^ 3))
+  print $ naturalAndNot ((2 ^ 65) .|. (2 ^ 3)) (2 ^ 3)


=====================================
testsuite/tests/numeric/should_run/T26230.stdout
=====================================
@@ -0,0 +1,4 @@
+16
+680564733841876926926749214863536422912
+16
+36893488147419103232


=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -83,3 +83,4 @@ test('T22282', normal, compile_and_run, [''])
 test('T22671', js_fragile(24259), compile_and_run, [''])
 test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
 test('T24066', normal, compile_and_run, [''])
+test('T26230', normal, compile_and_run, [''])


=====================================
testsuite/tests/rename/should_fail/T25056.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE RecordWildCards #-}
+module T25056 where
+
+import T25056b
+
+foo :: T -> ()
+foo (T { unT = x }) = x


=====================================
testsuite/tests/rename/should_fail/T25056.stderr
=====================================
@@ -0,0 +1,5 @@
+T25056.hs:7:10: error: [GHC-01928]
+    • Illegal term-level use of the type constructor ‘T’
+    • imported from ‘T25056b’ at T25056.hs:4:1-14
+      (and originally defined in ‘T25056a’ at T25056a.hs:8:1-14)
+


=====================================
testsuite/tests/rename/should_fail/T25056a.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T25056a
+  ( T
+  , T_(unT)
+  , pattern T
+  ) where
+
+type T = T_ ()
+
+data T_ a = PrivateT { unT_ :: a }
+
+pattern T :: a -> T_ a
+pattern T { unT } <- PrivateT { unT_ = unT }


=====================================
testsuite/tests/rename/should_fail/T25056b.hs
=====================================
@@ -0,0 +1,3 @@
+module T25056b (T, T_(..)) where
+
+import T25056a (T, T_(..))


=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -222,6 +222,7 @@ test('T23740g', normal, compile_fail, [''])
 test('T23740h', normal, compile_fail, [''])
 test('T23740i', req_th, compile_fail, [''])
 test('T23740j', normal, compile_fail, [''])
+test('T25056', [extra_files(['T25056a.hs', 'T25056b.hs'])], multimod_compile_fail, ['T25056', '-v0'])
 test('T23570', [extra_files(['T23570_aux.hs'])], multimod_compile_fail, ['T23570', '-v0'])
 test('T23570b', [extra_files(['T23570_aux.hs'])], multimod_compile, ['T23570b', '-v0'])
 test('T17594b', req_th, compile_fail, [''])


=====================================
testsuite/tests/typecheck/should_fail/T23739b.hs
=====================================
@@ -8,7 +8,4 @@ g1 :: Int -> Unit
 g1 Int = ()
 
 g2 :: Int
-g2 = Int{}
-
-g3 :: Int
-g3 = Int
+g2 = Int


=====================================
testsuite/tests/typecheck/should_fail/T23739b.stderr
=====================================
@@ -6,16 +6,9 @@ T23739b.hs:8:4: error: [GHC-01928]
       In an equation for ‘g1’: g1 Int = ()
 
 T23739b.hs:11:6: error: [GHC-01928]
-    • Illegal term-level use of the type constructor ‘Int’
-    • imported from ‘Prelude’ at T23739b.hs:2:8-14
-      (and originally defined in ‘GHC.Types’)
-    • In the expression: Int {}
-      In an equation for ‘g2’: g2 = Int {}
-
-T23739b.hs:14:6: error: [GHC-01928]
     • Illegal term-level use of the type constructor ‘Int’
     • imported from ‘Prelude’ at T23739b.hs:2:8-14
       (and originally defined in ‘GHC.Types’)
     • In the expression: Int
-      In an equation for ‘g3’: g3 = Int
+      In an equation for ‘g2’: g2 = Int
 


=====================================
testsuite/tests/typecheck/should_fail/T23739c.hs
=====================================
@@ -0,0 +1,8 @@
+
+module T23739c where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+g :: Int
+g = Int{}


=====================================
testsuite/tests/typecheck/should_fail/T23739c.stderr
=====================================
@@ -0,0 +1,7 @@
+T23739c.hs:8:5: error: [GHC-01928]
+    • Illegal term-level use of the type constructor ‘Int’
+    • imported from ‘Prelude’ at T23739c.hs:2:8-14
+      (and originally defined in ‘GHC.Types’)
+    • In the expression: Int {}
+      In an equation for ‘g’: g = Int {}
+


=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -730,3 +730,4 @@ test('T23739b', normal, compile_fail, [''])
 test('T25325', normal, compile_fail, [''])
 test('T25004', normal, compile_fail, [''])
 test('T25004k', normal, compile_fail, [''])
+test('T23739c', normal, compile_fail, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7d323b0fb0805f3ebc10c91a9d858d1af82c458...1ea64785f14487f7b999c4a9014bc6da20c0115d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d7d323b0fb0805f3ebc10c91a9d858d1af82c458...1ea64785f14487f7b999c4a9014bc6da20c0115d
You're receiving this email because of your account on gitlab.haskell.org.