Permalink
Browse files

Issue #168: resolves a merge conflict

  • Loading branch information...
mdimjasevic committed Feb 11, 2019
2 parents 53bb583 + ec705b5 commit a126559f6cae213f7e4730dc38f93445a54013a0
Showing with 1,391 additions and 694 deletions.
  1. +12 −4 io-sim-classes/src/Control/Monad/Class/MonadFork.hs
  2. +21 −4 io-sim-classes/src/Control/Monad/Class/MonadSTM.hs
  3. +0 −1 io-sim/io-sim.cabal
  4. +245 −141 io-sim/src/Control/Monad/IOSim.hs
  5. +4 −4 io-sim/test/Test/IOSim.hs
  6. +1 −1 ouroboros-consensus/demo-playground/CLI.hs
  7. +40 −43 ouroboros-consensus/demo-playground/Run.hs
  8. +2 −1 ouroboros-consensus/ouroboros-consensus.cabal
  9. +57 −45 ouroboros-consensus/src/Ouroboros/Consensus/Demo.hs
  10. +612 −255 ouroboros-consensus/src/Ouroboros/Consensus/Node.hs
  11. +62 −31 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Abstract.hs
  12. +21 −2 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/BFT.hs
  13. +5 −3 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ExtNodeConfig.hs
  14. +10 −16 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Genesis.hs
  15. +3 −1 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/LeaderSchedule.hs
  16. +19 −11 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/ModChainSel.hs
  17. +15 −9 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Praos.hs
  18. +4 −2 ouroboros-consensus/src/Ouroboros/Consensus/Protocol/Test.hs
  19. +20 −0 ouroboros-consensus/src/Ouroboros/Consensus/Util.hs
  20. +3 −2 ouroboros-consensus/src/Ouroboros/Consensus/Util/Chain.hs
  21. +44 −24 ouroboros-consensus/src/Ouroboros/Consensus/Util/Random.hs
  22. +7 −7 ouroboros-consensus/src/Ouroboros/Consensus/Util/STM.hs
  23. +15 −9 ouroboros-consensus/test-consensus/Test/Dynamic/BFT.hs
  24. +9 −8 ouroboros-consensus/test-consensus/Test/Dynamic/General.hs
  25. +6 −5 ouroboros-consensus/test-consensus/Test/Dynamic/LeaderSchedule.hs
  26. +19 −12 ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs
  27. +16 −12 ouroboros-consensus/test-consensus/Test/Dynamic/Praos.hs
  28. +2 −2 ouroboros-consensus/test-consensus/Test/Dynamic/Util.hs
  29. +22 −0 ouroboros-consensus/test-util/Test/Orphans/Arbitrary.hs
  30. +86 −27 ouroboros-network/test/Test/Ouroboros/Network/Node.hs
  31. +5 −6 ouroboros-network/test/Test/Ouroboros/Network/Protocol/BlockFetch.hs
  32. +2 −3 ouroboros-network/test/Test/Ouroboros/Network/Protocol/ChainSync.hs
  33. +2 −3 ouroboros-network/test/Test/Ouroboros/Network/Protocol/ReqResp.hs
@@ -8,16 +8,25 @@ import Control.Exception
import Control.Monad (void)
import Control.Monad.Except
import Control.Monad.Reader
import System.IO (hPutStrLn, stderr)
import System.IO (hFlush, hPutStrLn, stderr)
import System.IO.Unsafe (unsafePerformIO)

forkPrintExceptionLock :: IO.MVar ()
{-# NOINLINE forkPrintExceptionLock #-}
forkPrintExceptionLock = unsafePerformIO $ IO.newMVar ()

class Monad m => MonadFork m where
fork :: m () -> m ()

instance MonadFork IO where
fork a =
let handleException :: Either SomeException () -> IO ()
handleException (Left e) =
hPutStrLn stderr $ "Uncaught exception in thread:" ++ displayException e
handleException (Left e) = do
tid <- IO.myThreadId
IO.withMVar forkPrintExceptionLock $ \() -> do
hPutStrLn stderr $ "Uncaught exception in thread " ++ show tid
++ ": " ++ displayException e
hFlush stderr
handleException (Right x) = return x
in void (IO.forkFinally a handleException)

@@ -27,4 +36,3 @@ instance MonadFork m => MonadFork (ReaderT e m) where
-- NOTE(adn): Is this a sensible instance?
instance (Show e, MonadFork m) => MonadFork (ExceptT e m) where
fork (ExceptT m) = ExceptT $ Right <$> fork (either (error . show) id <$> m)

@@ -1,8 +1,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE CPP #-}
module Control.Monad.Class.MonadSTM
( MonadSTM (..)
, MonadFork (..)
@@ -30,9 +30,11 @@ import Prelude hiding (read)
import qualified Control.Concurrent.STM.TBQueue as STM
import qualified Control.Concurrent.STM.TMVar as STM
import qualified Control.Concurrent.STM.TVar as STM
import Control.Exception
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Monad.STM as STM
import GHC.Stack
import Numeric.Natural (Natural)

import Control.Monad.Class.MonadFork
@@ -44,7 +46,7 @@ class (MonadFork m, Monad (Tr m)) => MonadSTM m where
-- The STM primitives
type TVar m :: * -> *

atomically :: Tr m a -> m a
atomically :: HasCallStack => Tr m a -> m a
newTVar :: a -> Tr m (TVar m a)
readTVar :: TVar m a -> Tr m a
writeTVar :: TVar m a -> a -> Tr m ()
@@ -145,6 +147,22 @@ instance (Show e, MonadSTM m) => MonadSTM (ExceptT e m) where
readTBQueue = lift . readTBQueue
writeTBQueue q a = lift $ writeTBQueue q a

-- | Wrapper around 'BlockedIndefinitelyOnSTM' that stores a call stack
data BlockedIndefinitely = BlockedIndefinitely {
blockedIndefinitelyCallStack :: CallStack
, blockedIndefinitelyException :: BlockedIndefinitelyOnSTM
}
deriving (Show)

instance Exception BlockedIndefinitely where
displayException (BlockedIndefinitely cs e) = unlines [
displayException e
, prettyCallStack cs
]

wrapBlockedIndefinitely :: HasCallStack => IO a -> IO a
wrapBlockedIndefinitely = handle (throwIO . BlockedIndefinitely callStack)

--
-- Instance for IO uses the existing STM library implementations
--
@@ -153,7 +171,7 @@ instance MonadSTM IO where
type Tr IO = STM.STM
type TVar IO = STM.TVar

atomically = STM.atomically
atomically = wrapBlockedIndefinitely . STM.atomically
newTVar = STM.newTVar
readTVar = STM.readTVar
writeTVar = STM.writeTVar
@@ -316,4 +334,3 @@ writeTBQueueDefault (TBQueue rsize _read wsize write _size) a = do
else retry
listend <- readTVar write
writeTVar write (a:listend)

@@ -34,7 +34,6 @@ library
build-depends: base >=4.9 && <4.13,
io-sim-classes >=0.1 && <0.2,
containers,
free,
psqueues >=0.2 && <0.3

ghc-options: -Wall
Oops, something went wrong.

0 comments on commit a126559

Please sign in to comment.