GitLab

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

5b5d9d47

by Ben Gamari at 2025-08-25T14:29:35-04:00

Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"

This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd

10f06163

by Cheng Shao at 2025-08-25T14:30:16-04:00

wasm: ensure setKeepCAFs() is called in ghci

This patch is a critical bugfix for #26106, see comment and linked
issue for details.

6dfa209e

by Cheng Shao at 2025-08-25T19:02:15-04:00

compiler: use zero cost coerce in hoopl setElems/mapToList

This patch is a follow-up of !14680 and changes setElems/mapToList in
GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel
over the keys.

04fbc92c

by Ryan Scott at 2025-08-25T19:02:15-04:00

Reject infix promoted data constructors without DataKinds

In the rename, make sure to apply the same `DataKinds` checks for both
`HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix
promoted data constructors) alike.

Fixes #26318.

13 changed files:

compiler/GHC/Cmm/Dataflow/Label.hs
compiler/GHC/Rename/HsType.hs
docs/users_guide/9.16.1-notes.rst
rts/PrimOps.cmm
rts/RaiseAsync.c
rts/STM.c
− testsuite/tests/lib/stm/T26028.hs
− testsuite/tests/lib/stm/T26028.stdout
− testsuite/tests/lib/stm/all.T
+ testsuite/tests/typecheck/should_fail/T26318.hs
+ testsuite/tests/typecheck/should_fail/T26318.stderr
testsuite/tests/typecheck/should_fail/all.T
utils/jsffi/dyld.mjs

Changes:

compiler/GHC/Cmm/Dataflow/Label.hs

@@ -83,6 +83,7 @@ import GHC.Data.Word64Map.Strict (Word64Map)
  import qualified GHC.Data.Word64Map.Strict as M
  import GHC.Data.TrieMap
 +import Data.Coerce
  import Data.Word (Word64)
@@ -164,7 +165,7 @@ setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s
  {-# INLINE setElems #-}
  setElems :: LabelSet -> [Label]
 -setElems (LS s) = map mkHooplLabel (S.elems s)
 +setElems (LS s) = coerce $ S.elems s
  {-# INLINE setFromList #-}
  setFromList :: [Label] -> LabelSet
@@ -272,7 +273,7 @@ mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)
  {-# INLINE mapToList #-}
  mapToList :: LabelMap b -> [(Label, b)]
 -mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]
 +mapToList (LM m) = coerce $ M.toList m
  {-# INLINE mapFromList #-}
  mapFromList :: [(Label, v)] -> LabelMap v

compiler/GHC/Rename/HsType.hs

@@ -547,15 +547,7 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name))
         ; this_mod <- getModule
         ; when (nameIsLocalOrFrom this_mod name) $
           checkThLocalTyName name
 -       ; when (isDataConName name && not (isKindName name)) $
 -           -- Any use of a promoted data constructor name (that is not
 -           -- specifically exempted by isKindName) is illegal without the use
 -           -- of DataKinds. See Note [Checking for DataKinds] in
 -           -- GHC.Tc.Validity.
 -           checkDataKinds env tv
 -       ; when (isDataConName name && not (isPromoted ip)) $
 -         -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.
 -            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
 +       ; checkPromotedDataConName env tv Prefix ip name
         ; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) }
  rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
@@ -567,8 +559,7 @@ rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
          ; (ty1', fvs2) <- rnLHsTyKi env ty1
          ; (ty2', fvs3) <- rnLHsTyKi env ty2
          ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2'
 -        ; when (isDataConName op_name && not (isPromoted prom)) $
 -            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
 +        ; checkPromotedDataConName env ty Infix prom op_name
          ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
  rnHsTyKi env (HsParTy _ ty)
@@ -1670,6 +1661,30 @@ checkDataKinds env thing
      type_or_kind | isRnKindLevel env = KindLevel
                   | otherwise         = TypeLevel
 +-- | If a 'Name' is that of a promoted data constructor, perform various
 +-- validity checks on it.
 +checkPromotedDataConName ::
 +  RnTyKiEnv ->
 +  -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar'
 +  -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names).
 +  HsType GhcPs ->
 +  -- | Whether the type is written 'Prefix' or 'Infix'.
 +  LexicalFixity ->
 +  -- | Whether the name was written with an explicit promotion tick or not.
 +  PromotionFlag ->
 +  -- | The name to check.
 +  Name ->
 +  TcM ()
 +checkPromotedDataConName env ty fixity ip name
 +  = do when (isDataConName name && not (isKindName name)) $
 +         -- Any use of a promoted data constructor name (that is not
 +         -- specifically exempted by isKindName) is illegal without the use
 +         -- of DataKinds. See Note [Checking for DataKinds] in
 +         -- GHC.Tc.Validity.
 +         checkDataKinds env ty
 +       when (isDataConName name && not (isPromoted ip)) $
 +         addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name)
++
  warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
                   => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
  warnUnusedForAll doc (L loc tvb) used_names =

docs/users_guide/9.16.1-notes.rst

@@ -11,6 +11,11 @@ for specific guidance on migrating programs to this release.
  Language
  ~~~~~~~~
 +- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses
 +  of promoted data constructors without enabling :extension:`DataKinds`. As a
 +  result, you may need to enable :extension:`DataKinds` in code that did not
 +  previously require it.
++
  Compiler
  ~~~~~~~~

rts/PrimOps.cmm

@@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
      gcptr trec, outer, arg;
      trec = StgTSO_trec(CurrentTSO);
 -    if (running_alt_code != 1) {
 -      // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup
 -      // the nested transaction.
 -      // See Note [catchRetry# implementation]
 -      outer  = StgTRecHeader_enclosing_trec(trec);
 -      (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
 -      if (r != 0) {
 -          // Succeeded in first branch
 -          StgTSO_trec(CurrentTSO) = outer;
 -          return (ret);
 -      } else {
 -          // Did not commit: abort and restart.
 -          StgTSO_trec(CurrentTSO) = outer;
 -          jump stg_abort();
 -      }
 -    }
 -    else {
 -      // nothing to do in the rhs code of catchRetry# lhs rhs, it's already
 -      // using the parent transaction (not a nested one).
 -      // See Note [catchRetry# implementation]
 -      return (ret);
 +    outer  = StgTRecHeader_enclosing_trec(trec);
 +    (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
 +    if (r != 0) {
 +        // Succeeded (either first branch or second branch)
 +        StgTSO_trec(CurrentTSO) = outer;
 +        return (ret);
 +    } else {
 +        // Did not commit: abort and restart.
 +        StgTSO_trec(CurrentTSO) = outer;
 +        jump stg_abort();
+     }
+ }
@@ -1464,26 +1453,21 @@ retry_pop_stack:
      outer  = StgTRecHeader_enclosing_trec(trec);
      if (frame_type == CATCH_RETRY_FRAME) {
 -        // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME
+-
 +        // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
 +        ASSERT(outer != NO_TREC);
 +        // Abort the transaction attempting the current branch
 +        ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
 +        ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
          if (!StgCatchRetryFrame_running_alt_code(frame) != 0) {
 -            // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested
 -            // transaction. See Note [catchRetry# implementation]
+-
 -            // check that we have a parent transaction
 -            ASSERT(outer != NO_TREC);
+-
 -            // Abort the nested transaction
 -            ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr");
 -            ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr");
+-
 -            // As we are retrying in the lhs code, we must now try the rhs code
 -            StgTSO_trec(CurrentTSO) = outer;
 +            // Retry in the first branch: try the alternative
 +            ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr");
 +            StgTSO_trec(CurrentTSO) = trec;
              StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
              R1 = StgCatchRetryFrame_alt_code(frame);
              jump stg_ap_v_fast [R1];
          } else {
 -            // Retry in the rhs code: propagate the retry
 +            // Retry in the alternative code: propagate the retry
 +            StgTSO_trec(CurrentTSO) = outer;
              Sp = Sp + SIZEOF_StgCatchRetryFrame;
              goto retry_pop_stack;
+         }

rts/RaiseAsync.c

@@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
+             }
          case CATCH_STM_FRAME:
 -            // CATCH_STM frame within an atomically block: abort the
 +        case CATCH_RETRY_FRAME:
 +            // CATCH frames within an atomically block: abort the
              // inner transaction and continue.  Eventually we will
              // hit the outer transaction that will get frozen (see
              // above).
@@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
+         {
              StgTRecHeader *trec = tso -> trec;
              StgTRecHeader *outer = trec -> enclosing_trec;
 -            debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");
 +            debugTraceCap(DEBUG_stm, cap,
 +                          "found atomically block delivering async exception");
              stmAbortTransaction(cap, trec);
              stmFreeAbortedTRec(cap, trec);
              tso -> trec = outer;
              break;
          };
 -        case CATCH_RETRY_FRAME:
 -            // CATCH_RETY frame within an atomically block: if we're executing
 -            // the lhs code, abort the inner transaction and continue; if we're
 -            // executing thr rhs, continue (no nested transaction to abort. See
 -            // Note [catchRetry# implementation]). Eventually we will hit the
 -            // outer transaction that will get frozen (see above).
 -            //
 -            // As for the CATCH_STM_FRAME case above, we do not care
 -            // whether the transaction is valid or not because its
 -            // possible validity cannot have caused the exception
 -            // and will not be visible after the abort.
 -        {
 -            if (!((StgCatchRetryFrame *)frame) -> running_alt_code) {
 -                debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)");
 -                StgTRecHeader *trec = tso -> trec;
 -                StgTRecHeader *outer = trec -> enclosing_trec;
 -                stmAbortTransaction(cap, trec);
 -                stmFreeAbortedTRec(cap, trec);
 -                tso -> trec = outer;
 -            }
 -            else
 -            {
 -                debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)");
 -            }
 -            break;
 -        };
+-
          default:
              // see Note [Update async masking state on unwind] in Schedule.c
              if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {

rts/STM.c

@@ -1505,30 +1505,3 @@ void stmWriteTVar(Capability *cap,
+ }
  /*......................................................................*/
+-
+-
+-
 -/*
+-
 -Note [catchRetry# implementation]
 -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -catchRetry# creates a nested transaction for its lhs:
 -- if the lhs transaction succeeds:
 -    - the lhs transaction is committed
 -    - its read-variables are merged with those of the parent transaction
 -    - the rhs code is ignored
 -- if the lhs transaction retries:
 -    - the lhs transaction is aborted
 -    - its read-variables are merged with those of the parent transaction
 -    - the rhs code is executed directly in the parent transaction (see #26028).
+-
 -So note that:
 -- lhs code uses a nested transaction
 -- rhs code doesn't use a nested transaction
+-
 -We have to take which case we're in into account (using the running_alt_code
 -field of the catchRetry frame) in catchRetry's entry code, in retry#
 -implementation, and also when an async exception is received (to cleanup the
 -right number of transactions).
+-
 -*/

testsuite/tests/lib/stm/T26028.hs deleted

 -module Main where
+-
 -import GHC.Conc
+-
 -forever :: IO String
 -forever = delay 10 >> forever
+-
 -terminates :: IO String
 -terminates = delay 1 >> pure "terminates"
+-
 -delay s = threadDelay (1000000 * s)
+-
 -async :: IO a -> IO (STM a)
 -async a = do
 -  var <- atomically (newTVar Nothing)
 -  forkIO (a >>= atomically . writeTVar var . Just)
 -  pure (readTVar var >>= maybe retry pure)
+-
 -main :: IO ()
 -main = do
 -  x <- mapM async $ terminates : replicate 50000 forever
 -  r <- atomically (foldr1 orElse x)
 -  print r

testsuite/tests/lib/stm/T26028.stdout deleted

-"terminates"

testsuite/tests/lib/stm/all.T deleted

-test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2'])

testsuite/tests/typecheck/should_fail/T26318.hs

 +{-# LANGUAGE GHC2021 #-}
 +{-# LANGUAGE NoDataKinds #-}
 +module T26318 where
++
 +class C1 l
 +instance C1 (x : xs)
++
 +class C2 l
 +instance C2 (x ': xs)
++
 +class C3 l
 +instance C3 ((:) x xs)
++
 +class C4 l
 +instance C4 ('(:) x xs)

testsuite/tests/typecheck/should_fail/T26318.stderr

 +T26318.hs:6:16: error: [GHC-68567]
 +    Illegal type: ‘x : xs’
 +    Suggested fix:
 +      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
++
 +T26318.hs:9:16: error: [GHC-68567]
 +    Illegal type: ‘x ': xs’
 +    Suggested fix:
 +      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
++
 +T26318.hs:12:14: error: [GHC-68567]
 +    Illegal type: ‘(:)’
 +    Suggested fix:
 +      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
++
 +T26318.hs:15:14: error: [GHC-68567]
 +    Illegal type: ‘'(:)’
 +    Suggested fix:
 +      Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’)
++

testsuite/tests/typecheck/should_fail/all.T

@@ -741,3 +741,4 @@ test('T25325', normal, compile_fail, [''])
  test('T25004', normal, compile_fail, [''])
  test('T25004k', normal, compile_fail, [''])
  test('T26004', normal, compile_fail, [''])
 +test('T26318', normal, compile_fail, [''])

utils/jsffi/dyld.mjs

@@ -1105,6 +1105,20 @@ class DyLD {
        if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) {
          this.rts_init();
          delete this.rts_init;
++
 +        // At this point the RTS symbols in linear memory are fixed
 +        // and constructors are run, especially the one in JSFFI.c
 +        // that does GHC RTS initialization for any code that links
 +        // JSFFI.o. Luckily no Haskell computation or gc has taken
 +        // place yet, so we must set keepCAFs=1 right now! Otherwise,
 +        // any BCO created by later TH splice or ghci expression may
 +        // refer to any CAF that's not reachable from GC roots (here
 +        // our only entry point is defaultServer) and the CAF could
 +        // have been GC'ed! (#26106)
 +        //
 +        // We call it here instead of in RTS C code, since we only
 +        // want keepCAFs=1 for ghci, not user code.
 +        this.exportFuncs.setKeepCAFs();
+       }
        init();
+     }