+{-# LANGUAGE MultiWayIf #-}

+import GHC.Core

+import GHC.Core.Coercion

+import GHC.Core.Reduction

+import GHC.Core.TyCon

+  = (cpr_ty', Cast e' co)

+    cpr_ty'

+      | cpr_ty == topCprType                    = topCprType -- cheap case first

+      | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors]

+      | otherwise                               = cpr_ty

+isRecNewTyConApp :: AnalEnv -> Type -> Bool

+-- See Note [CPR for recursive newtype constructors]

+isRecNewTyConApp env ty

+  --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined

+  | Just (tc, tc_args) <- splitTyConApp_maybe ty =

+      if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args

+         -> isRecNewTyConApp env rhs

+         | Just dc <- newTyConDataCon_maybe tc

+         -> ae_rec_dc env dc == DefinitelyRecursive

+         | otherwise

+         -> False

+  | otherwise = False

+

+    -- If fixed-point iteration does not yield a result we use this instead

+    -- See Note [Safe abortion in the fixed-point iteration]

+    abort :: (AnalEnv, [(Id,CoreExpr)])

+    abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ]

+

+      | n == 10        = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort

+      | rhs_ty == topCprType = topCprType -- cheap case first

+      | stays_thunk          = trimCprTy rhs_ty

+      | otherwise            = rhs_ty

+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType

+ A. Don't give recursive data constructors or casts representing recursive newtype constructors

+    the CPR property (the list in this case). This is the solution we adopt.

+    Rationale: the benefit of CPR on recursive data structures is slight,

+    because it only affects the outer layer of a potentially massive data

+    structure.

+We adopt solution (A). It is ad-hoc, but appears to work reasonably well.

+Specifically:

+

+* For data constructors, in `cprTransformDataConWork` we check for a recursive

+  data constructor by calling `ae_rec_dc env`, which is just a memoised version

+  of `isRecDataCon`.  See Note [Detecting recursive data constructors]

+* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype

+  by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`.

+  See Note [CPR for recursive newtype constructors]

+ D. If `ty = f a`, then look into `f` and `a`

+ E. If `ty = ty' |> co`, then look into `ty'`

+  2. It doesn't look into kinds, literals or coercion types because we are

+     ultimately looking for value-level recursion.

+Note [CPR for recursive newtype constructors]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+A newtype constructor is considered recursive iff the data constructor of the

+equivalent datatype definition is recursive.

+See Note [CPR for recursive data constructors].

+Detection is a bit complicated by the fact that newtype constructor applications

+reflect as Casts in Core:

+

+  newtype List a = C (Maybe (a, List a))

+  xs = C (Just (0, C Nothing))

+  ==> {desugar to Core}

+  xs = Just (0, Nothing |> sym N:List) |> sym N:List

+

+So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than

+in `cprTransformDataConWork` as for data constructors.

+

+    putMsg, putMsgS, errorMsg, msg, diagnostic,

+import GHC.Driver.Errors ( reportDiagnostic, reportError )

+import GHC.Driver.Config.Diagnostic ( initDiagOpts )

+diagnostic :: DiagnosticReason -> SDoc -> CoreM ()

+diagnostic reason doc = do

+    logger <- getLogger

+    loc <- getSrcSpanM

+    name_ppr_ctx <- getNamePprCtx

+    diag_opts <- initDiagOpts <$> getDynFlags

+    liftIO $ reportDiagnostic logger name_ppr_ctx diag_opts loc reason doc

+

+errorMsg doc = do

+    logger <- getLogger

+    loc <- getSrcSpanM

+    name_ppr_ctx <- getNamePprCtx

+    diag_opts <- initDiagOpts <$> getDynFlags

+    liftIO $ reportError logger name_ppr_ctx diag_opts loc doc

+import GHC.Types.Error (DiagnosticReason(..))

+       ; when (not (null warnings)) $ diagnostic WarningWithoutFlag (warn_msg warnings)

+    allCallersInlined :: Bool

+

+    doWarn :: DiagnosticReason -> CoreM ()

+      diagnostic reason

+import GHC.Core.TyCo.Rep

+    go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $

+      case coreFullView ty of

+        TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args

+          -- See Note [Detecting recursive data constructors], points (B) and (C)

+        ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty'

+        CastTy ty' _ -> go_arg_ty fuel visited_tcs ty'

+        AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a

+          -- See Note [Detecting recursive data constructors], point (D)

+

+        FunTy{} -> NonRecursiveOrUnsure

+          -- See Note [Detecting recursive data constructors], point (1)

+

+        -- (TyVarTy{} | LitTy{} | CastTy{})

+        _ -> NonRecursiveOrUnsure

+        ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined

+--

+-- @since 4.23.0.0

+    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);

+        // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME

+

+            // 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 rhs code: propagate the retry

+            // CATCH_STM frame within an atomically block: abort the

+            debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame");

+        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;

+        };

+

+

+

+

+/*

+

+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).

+

+*/

+{-# LANGUAGE UndecidableInstances, LambdaCase #-}

+

+-- | This file starts with a small reproducer for #25944 that is easy to debug

+-- and then continues with a much larger MWE that is faithful to the original

+-- issue.

+module T25944 (foo, bar, popMinOneT, popMinOne) where

+

+import Data.Functor.Identity ( Identity(..) )

+import Data.Coerce

+

+data ListCons a b = Nil | a :- !b

+newtype Fix f = Fix (f (Fix f)) -- Rec

+

+foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a)

+foo a b = go a

+  where

+    -- The outer loop arranges it so that the base case `go as` of `go2` is

+    -- bottom on the first iteration of the loop.

+    go (Fix Nil) = Fix Nil

+    go (Fix (a :- as)) = Fix (a :- go2 b)

+      where

+        go2 (Fix Nil) = go as

+        go2 (Fix (b :- bs)) = Fix (b :- go2 bs)

+

+bar :: Int -> (Fix (ListCons Int), Int)

+bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property

+

+-- Now the actual reproducer from #25944:

+

+newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) }

+

+cons :: Applicative m => a -> ListT m a -> ListT m a

+cons x xs = ListT (pure (x :- xs))

+

+nil :: Applicative m => ListT m a

+nil = ListT (pure Nil)

+

+instance Functor m => Functor (ListT m) where

+  fmap f (ListT m) = ListT (go <$> m)

+     where

+       go Nil = Nil

+       go (a :- m) = f a :- (f <$> m)

+

+foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b)

+          -> (a -> b -> c)

+          -> c

+          -> ListT m a -> b

+foldListT r c n = r h . runListT

+  where

+    h Nil = n

+    h (x :- ListT xs) = c x (r h xs)

+{-# INLINE foldListT #-}

+

+mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b

+mapListT =

+  foldListT

+  ((coerce ::

+ ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) ->

+ ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b))

+  (=<<))

+{-# INLINE mapListT #-}

+

+instance Monad m => Applicative (ListT m) where

+  pure x = cons x nil

+  {-# INLINE pure #-}

+  liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs

+  {-# INLINE liftA2 #-}

+

+instance Monad m => Monad (ListT m) where

+  xs >>= f = mapListT (flip (mapListT cons) . f) nil xs

+  {-# INLINE (>>=) #-}

+

+infixr 5 :<

+data Node w a b = Leaf a | !w :< b

+  deriving (Functor)

+

+bimapNode f g (Leaf x) = Leaf (f x)

+bimapNode f g (x :< xs) = x :< g xs

+

+newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) }

+

+-- | The 'Heap' type, specialised to the 'Identity' monad.

+type Heap w = HeapT w Identity

+

+instance Functor m => Functor (HeapT w m) where

+  fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT

+

+instance Monad m => Applicative (HeapT w m) where

+  pure = HeapT . pure . Leaf

+  (<*>) = liftA2 id

+

+instance Monad m => Monad (HeapT w m) where

+  HeapT m >>= f = HeapT (m >>= g)

+    where

+      g (Leaf x) = runHeapT (f x)

+      g (w :< xs) = pure (w :< (xs >>= f))

+

+popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a))

+popMinOneT = go mempty [] . runHeapT

+  where

+    go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a))

+    go' a Nothing = pure Nothing

+    go' a (Just (w, HeapT xs)) = go (a <> w) [] xs

+

+    go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a))

+    go w a (ListT xs) = xs >>= \case

+      Nil -> go' w (undefined)

+      Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a)))

+      (u :< x) :- xs -> go w ((u,x) : a) xs

+{-# INLINE popMinOneT #-}

+

+popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a)

+popMinOne = runIdentity . popMinOneT

+{-# INLINE popMinOne #-}

+

+==================== Cpr signatures ====================

+T25944.$fApplicativeHeapT:

+T25944.$fApplicativeListT:

+T25944.$fFunctorHeapT:

+T25944.$fFunctorListT:

+T25944.$fFunctorNode:

+T25944.$fMonadHeapT:

+T25944.$fMonadListT:

+T25944.bar: 1

+T25944.foo:

+T25944.popMinOne: 2(1(1,))

+T25944.popMinOneT:

+T25944.runHeapT:

+T25944.runListT:

+

+

+test('T25944', normal, compile, [''])

+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

+"terminates"

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