-import GHC.Builtin.Utils

-import GHC.Types.Unique

-import GHC.Utils.Outputable

-    KnownKeyName u -> case lookupKnownKeyName u of

-      Nothing -> pprPanic "fromHieName:unknown known-key unique"

-                          (ppr u)

-      Just n -> pure n

-

-putHieName bh (KnownKeyName uniq) = do

-  putByte bh 2

-  put_ bh $ unpkUnique uniq

-    2 -> do

-      (c,i) <- get bh

-      return $ KnownKeyName $ mkUnique c i

-import GHC.Builtin.Utils

-import GHC.Types.Unique

-  | KnownKeyName !Unique

-  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b

-    -- Not actually non deterministic as it is a KnownKey

-  compare LocalName{} _ = LT

-  compare KnownKeyName{} _ = GT

-  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u

-hieNameOcc (KnownKeyName u) =

-  case lookupKnownKeyName u of

-    Just n -> nameOccName n

-    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"

-                        (ppr u)

-toHieName name

-  | isKnownKeyName name = KnownKeyName (nameUnique name)

-  | isExternalName name = ExternalName (nameModule name)

-                                       (nameOccName name)

-                                       (removeBufSpan $ nameSrcSpan name)

-  | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)

--- >   extern StgPtr Main_r2wb_closure;

--- >   extern StgPtr Main_r2wc_closure;

--- The linker must find the definitions matching the @extern StgPtr <name>@

-        $$ text "extern StgPtr "

-It turns out that we end up looking up built-in syntax in the cache when we

-generate Haddock documentation. E.g. if we don't find tuple data constructors

-there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs)

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

-

-*/

-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'])

-freshNameCache =

-  initNameCache

-    'a' -- ??

-    []