├── .ghci
├── Control
    └── Monad
    │   ├── ST
    │       └── Class.hs
    │   ├── RTS-Test.hs
    │   ├── Concurrent.hs
    │   └── RTS.hs
├── experiments
    ├── LSCMemoTrie.hs
    ├── LSCTest.hs
    └── Data
    │   └── MemoTrie.hs
├── Utilities.hs
├── Data
    └── STQueue.hs
└── Test
    └── LazySmallCheck.hs


/.ghci:
--------------------------------------------------------------------------------
1 | :set -Wall -fno-warn-name-shadowing
2 | :l Control/Monad/RTS.hs
3 | 


--------------------------------------------------------------------------------
/Control/Monad/ST/Class.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TypeFamilies #-}
 2 | module Control.Monad.ST.Class (MonadST(..)) where
 3 | 
 4 | import Control.Monad.ST
 5 | 
 6 | 
 7 | -- | Type class of monads that can perform lifted computation in the 'ST' monad.
 8 | class Monad m => MonadST m where
 9 |     type StateThread m
10 |     liftST :: ST (StateThread m) a -> m a
11 | 
12 | instance MonadST (ST s) where
13 |     type StateThread (ST s) = s
14 |     liftST m = m
15 | 
16 | instance MonadST IO where
17 |     type StateThread IO = RealWorld
18 |     liftST = stToIO
19 | 


--------------------------------------------------------------------------------
/experiments/LSCMemoTrie.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TypeOperators, CPP #-}
 2 | import Data.Int
 3 | import Data.Word
 4 | 
 5 | import Data.MemoTrie        -- Needed to modify this so we export (:->:) constructors
 6 | import Test.LazySmallCheck  -- Needed to modify this so we can generate infinite data structures
 7 | 
 8 | 
 9 | class HasTrie a => HasSerialTrie a where
10 |     seriesTrie :: Series b -> Series (a :->: b)
11 | 
12 | instance HasSerialTrie () where
13 |     seriesTrie series = cons UnitTrie >< series
14 | 
15 | instance HasSerialTrie Bool where
16 |     seriesTrie series = cons BoolTrie >< series >< series
17 | 
18 | instance (HasSerialTrie a, HasSerialTrie b) => HasSerialTrie (Either a b) where
19 |     seriesTrie series = cons EitherTrie >< seriesTrie series >< seriesTrie series
20 | 
21 | instance (HasSerialTrie a, HasSerialTrie b) => HasSerialTrie (a, b) where
22 |     seriesTrie series = cons PairTrie >< seriesTrie (seriesTrie series)
23 | 
24 | instance (HasSerialTrie a, HasSerialTrie b, HasSerialTrie c) => HasSerialTrie (a, b, c) where
25 |     seriesTrie series = cons TripleTrie >< seriesTrie series
26 | 
27 | instance HasSerialTrie a => HasSerialTrie [a] where
28 |     seriesTrie series = cons ListTrie >< seriesTrie series
29 | 
30 | #define SimpleInstance(IntType,TrieType) \
31 | instance HasSerialTrie IntType where \
32 |     seriesTrie series = cons TrieType >< seriesTrie series
33 | 
34 | SimpleInstance(Char,CharTrie)
35 | SimpleInstance(Word,WordTrie)
36 | SimpleInstance(Word8,Word8Trie)
37 | SimpleInstance(Word16,Word16Trie)
38 | SimpleInstance(Word32,Word32Trie)
39 | SimpleInstance(Word64,Word64Trie)
40 | SimpleInstance(Int,IntTrie)
41 | SimpleInstance(Int8,Int8Trie)
42 | SimpleInstance(Int16,Int16Trie)
43 | SimpleInstance(Int32,Int32Trie)
44 | SimpleInstance(Int64,Int64Trie)
45 | SimpleInstance(Integer,IntegerTrie)
46 | 
47 | 
48 | instance (HasSerialTrie a, Serial b) => Serial (a -> b) where
49 |     series = cons untrie >< seriesTrie series . (+1)
50 | 
51 | 
52 | instance Show (a -> b) where
53 |     show _ = "<function>" -- FIXME: could print a finite representation of function in the form of the MemoTrie
54 | 
55 | 
56 | prop_fun :: (Bool -> Bool) -> Bool
57 | prop_fun f = f True == True && f False == False
58 | 
59 | 
60 | main :: IO ()
61 | main = test prop_fun
62 | 


--------------------------------------------------------------------------------
/experiments/LSCTest.hs:
--------------------------------------------------------------------------------
 1 | import Control.Arrow (first)
 2 | import Control.Exception
 3 | import Control.Monad
 4 | import System.IO.Unsafe
 5 | 
 6 | import Test.LazySmallCheck
 7 | 
 8 | 
 9 | prop_list :: [Int] -> Bool
10 | prop_list xs = xs `lengthAtLeast` 4 ==> ((before ++ 9 : after) !! 4) == 9
11 |   where (before, after) = splitAt 4 xs
12 | 
13 | -- | Length testing, but in a less strict way, so that LazySmallCheck can prune the search space.
14 | --
15 | -- @lengthAtLeast xs n == length xs >= n@
16 | lengthAtLeast :: [a] -> Int -> Bool
17 | lengthAtLeast xs     0 = True
18 | lengthAtLeast []     _ = False
19 | lengthAtLeast (x:xs) n = lengthAtLeast xs (n - 1)
20 | 
21 | 
22 | -- I used to use unsafeIsEvaluated to decide where to put in "...", but that pruned too heavily because
23 | -- I couldn't show the schedule before it was actually poked on and those thunks turned into real values.
24 | {-# NOINLINE showExplored #-}
25 | showExplored :: (a -> String) -> a -> String
26 | showExplored show x = unsafePerformIO $ fmap (maybe "..." show) $ tryIf isLSCError (evaluate x)
27 |   where
28 |     -- Looked at the LSC code to see what sort of errors it was generating...
29 |     isLSCError (ErrorCall ('\0':msg)) = True
30 |     isLSCError _                      = False
31 | 
32 |     tryIf :: Exception e => (e -> Bool) -> IO a -> IO (Maybe a)
33 |     tryIf p act = fmap (either (\() -> Nothing) Just) $ tryJust (\e -> guard (p e) >> return ()) act
34 | 
35 | 
36 | data Stream a = a :< Stream a
37 | 
38 | instance Show a => Show (Stream a) where
39 |     show = showExplored $ \(x :< xs) -> show x ++ " :< " ++ show xs
40 | 
41 | instance Serial a => Serial (Stream a) where
42 |     series = cons2 (:<)
43 | 
44 | splitStream :: Int -> Stream a -> ([a], Stream a)
45 | splitStream 0 xs        = ([], xs)
46 | splitStream n (x :< xs) = first (x:) $ splitStream (n - 1) xs
47 | 
48 | streamPrepend :: [a] -> Stream a -> Stream a
49 | streamPrepend []     ys = ys
50 | streamPrepend (x:xs) ys = x :< streamPrepend xs ys
51 | 
52 | streamAt :: Stream a -> Int -> a
53 | streamAt (x :< xs) n = if n == 0 then x else streamAt xs (n - 1)
54 | 
55 | prop_stream1 :: Stream Int -> Bool
56 | prop_stream1 xs = (((before ++ [9]) `streamPrepend` after) `streamAt` 4) == 9
57 |   where (before, after) = splitStream 4 xs
58 | 
59 | prop_stream2 :: Stream Bool -> Bool
60 | prop_stream2 (x :< _) = x == True
61 | 
62 | 
63 | data Streem a = Streem a (Stream (Streem a))
64 | 
65 | instance Serial a => Serial (Streem a) where
66 |     series = cons2 Streem
67 | 
68 | 
69 | -- prop_fun :: (Bool -> Bool) -> Bool
70 | -- prop_fun f = f True == True && f False == False
71 | 
72 | 
73 | main :: IO ()
74 | main = do
75 |     --test prop_stream1
76 |     test prop_stream2
77 |     --test prop_fun


--------------------------------------------------------------------------------
/Control/Monad/RTS-Test.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
 2 | {-# LANGUAGE RankNTypes #-}
 3 | import Control.Monad.ST
 4 | import Debug.Trace
 5 | 
 6 | 
 7 | data Result a = Good a | Bad
 8 |               deriving (Show)
 9 | 
10 | 
11 | newtype ThreadId = TID Int
12 |                  deriving (Show)
13 | 
14 | 
15 | newtype Unblocked' s r a = Unblocked { unUnblocked :: ([Unblocked s r] -> Int -> ST s (Result r))
16 |                                                    -> Int -- Next TID
17 |                                                    -> ST s a }
18 | 
19 | instance Monad (Unblocked' s r) where
20 |     return x = Unblocked $ \_k_may_block _tid -> return x
21 |     mx >>= fxmy = Unblocked $ \k_may_block tid -> unUnblocked mx k_may_block tid >>= \x -> unUnblocked (fxmy x) k_may_block tid
22 | 
23 | reschedule :: [Unblocked s r] -> Unblocked s r
24 | reschedule unblockeds = Unblocked $ \k_may_block next_tid -> k_may_block unblockeds next_tid
25 | 
26 | type Unblocked s r = Unblocked' s r (Result r)
27 | newtype RTS s r a = RTS { unRTS :: (a -> Unblocked s r)
28 |                                 -> ThreadId -- My TID
29 |                                 -> Unblocked s r }
30 | 
31 | instance Monad (RTS s r) where
32 |     return x = RTS $ \k_done _tid -> k_done x
33 |     mx >>= fxmy = RTS $ \k_done tid -> unRTS mx (\x -> unRTS (fxmy x) k_done tid) tid
34 | 
35 | yield :: RTS s r ()
36 | yield = RTS $ \k_done _tid -> trace ("Thread " ++ show _tid ++ " yielding") $ reschedule [k_done ()]
37 | 
38 | forkIO :: RTS s r () -> RTS s r Int
39 | forkIO rts = RTS $ \k_done _tid -> Unblocked $ \k_may_block next_tid -> k_may_block [k_done next_tid,
40 |                                                                                      unRTS rts (\() -> reschedule []) (TID next_tid)]
41 |                                                                                     (next_tid + 1)
42 | 
43 | runRTS :: (forall s. RTS s r r) -> Result r
44 | runRTS rts = runST $ unUnblocked (unRTS rts (\x -> return (Good x)) (TID 0)) schedule 1
45 |   where
46 |     -- Dummy impl:
47 |     schedule :: [Unblocked s r] -> Int -> ST s (Result r)
48 |     schedule []                     _next_tid = error "Blocked forever"
49 |     schedule (unblocked:unblockeds) next_tid  = {- trace ("Scheduling " ++ show (length unblockeds + 1) ++ " threads") $ -} unUnblocked unblocked (\unblockeds' -> schedule (unblockeds ++ unblockeds')) next_tid
50 | 
51 | 
52 | main :: IO ()
53 | main = print $ runRTS $ do
54 |     1 <- forkIO $ do
55 |       return True
56 |       2 <- forkIO $ do
57 |         return "Hello"
58 |         yield
59 |         yield
60 |         return ()
61 |       return False
62 |       yield
63 |       yield
64 |       yield
65 |     
66 |     yield
67 |     yield
68 |     yield
69 |     yield
70 |     
71 |     return "10"
72 |     yield
73 |     return "2"
74 | 


--------------------------------------------------------------------------------
/Utilities.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  2 | module Utilities where
  3 | 
  4 | import Control.Applicative (Applicative(..))
  5 | import Control.Arrow ((***), first, second)
  6 | import qualified Control.Exception as E
  7 | import Control.Monad
  8 | import Control.Monad.ST
  9 | 
 10 | import Debug.Trace
 11 | 
 12 | import System.IO.Unsafe
 13 | import System.Random
 14 | 
 15 | 
 16 | instance Applicative (ST s) where
 17 |     pure = return
 18 |     (<*>) = ap
 19 | 
 20 | 
 21 | thd3 :: (a, b, c) -> c
 22 | thd3 (_, _, c) = c
 23 | 
 24 | fth4 :: (a, b, c, d) -> d
 25 | fth4 (_, _, _, d) = d
 26 | 
 27 | vth5 :: (a, b, c, d, e) -> e
 28 | vth5 (_, _, _, _, e) = e
 29 | 
 30 | pamf :: Functor f => f a -> (a -> b) -> f b
 31 | pamf = flip fmap
 32 | 
 33 | 
 34 | {-# NOINLINE exceptionTrace #-}
 35 | exceptionTrace :: a -> a
 36 | exceptionTrace x = unsafePerformIO (E.evaluate x `E.catch` (\e -> trace ("Exception in pure code: " ++ show (e :: E.SomeException)) $ E.throw e))
 37 | 
 38 | 
 39 | genericDeleteAt :: Num i => [a] -> i -> (a, [a])
 40 | genericDeleteAt []     _ = error $ "genericDeleteAt: index too large for given list, or list null"
 41 | genericDeleteAt (x:xs) n = if n == 0 then (x, xs) else second (x:) (genericDeleteAt xs (n - 1))
 42 | 
 43 | 
 44 | newtype Nat = Nat { unNat :: Int }
 45 |             deriving (Eq, Ord)
 46 | 
 47 | instance Show Nat where
 48 |     show = show . unNat
 49 | 
 50 | instance Num Nat where
 51 |     x + y = Nat (unNat x + unNat y)
 52 |     x * y = Nat (unNat x * unNat y)
 53 |     x - y | z < 0     = error $ "Subtracting the naturals " ++ show x ++ " and " ++ show y ++ " produced a negative answer"
 54 |           | otherwise = Nat z
 55 |       where z = unNat x - unNat y
 56 |     negate (Nat 0) = Nat 0
 57 |     negate x = error $ "Cannot negate the strictly-positive natural number " ++ show x
 58 |     abs x = x
 59 |     signum (Nat 0) = Nat 0
 60 |     signum (Nat _) = Nat 1
 61 |     fromInteger x | x < 0     = error $ "The integer " ++ show x ++ " was not a natural number"
 62 |                   | otherwise = Nat (fromInteger x)
 63 | 
 64 | instance Real Nat where
 65 |     toRational = toRational . unNat
 66 | 
 67 | instance Enum Nat where
 68 |     succ x = Nat (succ (unNat x))
 69 |     pred (Nat 0) = error "Cannot take the predecessor of the natural number 0"
 70 |     pred x       = Nat (pred (unNat x))
 71 |     toEnum x | x < 0     = error $ "Invalid argument to toEnum: " ++ show x
 72 |              | otherwise = Nat x
 73 |     fromEnum = unNat
 74 | 
 75 | instance Integral Nat where
 76 |     x `quot` y = Nat (unNat x `quot` unNat y)
 77 |     x `rem` y = Nat (unNat x `rem` unNat y)
 78 |     x `div` y = Nat (unNat x `div` unNat y)
 79 |     x `mod` y = Nat (unNat x `mod` unNat y)
 80 |     x `quotRem` y = (Nat *** Nat) (unNat x `quotRem` unNat y)
 81 |     x `divMod` y = (Nat *** Nat) (unNat x `divMod` unNat y)
 82 |     toInteger = toInteger . unNat
 83 | 
 84 | instance Random Nat where
 85 |     randomR (lo, hi) g = first Nat $ randomR (unNat lo, unNat hi) g
 86 |     random g = first (Nat . abs) $ random g
 87 | 
 88 | 
 89 | data Queue a = Queue [a] [a]
 90 | 
 91 | emptyQueue :: Queue a
 92 | emptyQueue = Queue [] []
 93 | 
 94 | nullQueue :: Queue a -> Bool
 95 | nullQueue (Queue [] []) = True
 96 | nullQueue (Queue _  _)  = False
 97 | 
 98 | queue :: a -> Queue a -> Queue a
 99 | queue x (Queue xs ys) = Queue (x : xs) ys
100 | 
101 | dequeue :: Queue a -> Maybe (a, Queue a)
102 | dequeue (Queue xs     (y:ys)) = Just (y, Queue xs ys)
103 | dequeue (Queue []     [])     = Nothing
104 | dequeue (Queue (x:xs) [])     = Just (rev xs x [])
105 |   where
106 |     rev []     x acc = (x, Queue [] acc)
107 |     rev (y:ys) x acc = rev ys y (x:acc)
108 | 
109 | 
110 | holes :: [a] -> [(a, [a])]
111 | holes []     = []
112 | holes (x:xs) = (x, xs) : [(x', x:xs') | (x', xs') <- holes xs]
113 | 
114 | 
115 | mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
116 | mapMaybeM f = go
117 |   where go []     = return []
118 |         go (x:xs) = do
119 |           mb_y <- f x
120 |           maybe id (\y -> liftM (y:)) mb_y (go xs)
121 | 


--------------------------------------------------------------------------------
/Control/Monad/Concurrent.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts, TypeFamilies, RankNTypes #-}
  2 | module Control.Monad.Concurrent where
  3 | 
  4 | import Control.Exception (Exception(..), SomeException, MaskingState)
  5 | import qualified Control.Exception as IO
  6 | import qualified Control.Concurrent as IO
  7 | 
  8 | import Data.Typeable (Typeable, Typeable1)
  9 | 
 10 | import Prelude hiding (catch)
 11 | 
 12 | 
 13 | class Monad m => MonadException m where
 14 |     mask :: ((forall a. m a -> m a) -> m b) -> m b
 15 |     mask_ :: m a -> m a
 16 |     mask_ io = mask $ \_ -> io
 17 | 
 18 |     uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b
 19 |     uninterruptibleMask_ :: m a -> m a
 20 |     uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io
 21 | 
 22 |     getMaskingState :: m MaskingState
 23 | 
 24 |     -- TODO: add other functions from Control.Exception
 25 |     
 26 |     throwIO :: Exception e => e -> m a
 27 |     throwTo :: Exception e => ThreadId m -> e -> m ()
 28 |     catch :: Exception e => m a -> (e -> m a) -> m a
 29 |     
 30 |     bracket :: m a -> (a -> m b) -> (a -> m c) -> m c
 31 |     bracket before after thing = mask $ \restore -> do
 32 |         a <- before
 33 |         r <- restore (thing a) `onException` after a
 34 |         _ <- after a
 35 |         return r
 36 | 
 37 |     bracket_ :: m a -> m b -> m c -> m c
 38 |     bracket_ before after thing = bracket before (const after) (const thing)
 39 | 
 40 |     onException :: m a -> m b -> m a
 41 |     onException io what = io `catch` handle
 42 |       where handle e = do
 43 |               _ <- what
 44 |               throwIO (e :: SomeException)
 45 | 
 46 | instance MonadException IO where
 47 |     mask = IO.mask
 48 |     mask_ = IO.mask_
 49 |     uninterruptibleMask = IO.uninterruptibleMask
 50 |     uninterruptibleMask_ = IO.uninterruptibleMask_
 51 |     getMaskingState = IO.getMaskingState
 52 |     
 53 |     throwIO = IO.throwIO
 54 |     throwTo = IO.throwTo
 55 |     catch = IO.catch
 56 |     
 57 |     bracket = IO.bracket
 58 |     bracket_ = IO.bracket_
 59 |     
 60 |     onException = IO.onException
 61 | 
 62 | 
 63 | class (Eq (ThreadId m),
 64 |        Ord (ThreadId m),
 65 |        Show (ThreadId m),
 66 |        Typeable (ThreadId m),
 67 |        Monad m) => MonadConcurrent m where
 68 |     type ThreadId m :: *
 69 |     
 70 |     forkIO :: m () -> m (ThreadId m)
 71 |     myThreadId :: m (ThreadId m)
 72 | 
 73 |     yield :: m ()
 74 | 
 75 | instance MonadConcurrent IO where
 76 |     type ThreadId IO = IO.ThreadId
 77 |     
 78 |     forkIO = IO.forkIO
 79 |     myThreadId = IO.myThreadId
 80 |     
 81 |     yield = IO.yield
 82 | 
 83 | 
 84 | -- TODO: we need to have (forall a. Eq (MVar m) a) in the context here but we can't
 85 | class (Typeable1 (MVar m),
 86 |        MonadException m, MonadConcurrent m) => MonadMVar m where
 87 |     type MVar m :: * -> *
 88 |     
 89 |     newEmptyMVar :: m (MVar m a)
 90 |     newMVar :: a -> m (MVar m a)
 91 |     
 92 |     takeMVar :: MVar m a -> m a
 93 |     putMVar :: MVar m a -> a -> m ()
 94 |     readMVar :: MVar m a -> m a
 95 |     readMVar m = mask_ $ do
 96 |         a <- takeMVar m
 97 |         putMVar m a
 98 |         return a
 99 |     
100 |     swapMVar :: MVar m a -> a -> m a
101 |     swapMVar m new = mask_ $ do
102 |         old <- takeMVar m
103 |         putMVar m new
104 |         return old
105 |     
106 |     tryTakeMVar :: MVar m a -> m (Maybe a)
107 |     tryPutMVar :: MVar m a -> a -> m Bool
108 |     isEmptyMVar :: MVar m a -> m Bool
109 |     
110 |     withMVar :: MVar m a -> (a -> m b) -> m b
111 |     withMVar m io = mask $ \restore -> do
112 |         a <- takeMVar m
113 |         b <- restore (io a) `onException` putMVar m a
114 |         putMVar m a
115 |         return b
116 |     
117 |     modifyMVar_ :: MVar m a -> (a -> m a) -> m ()
118 |     modifyMVar_ m io = mask $ \restore -> do
119 |         a  <- takeMVar m
120 |         a' <- restore (io a) `onException` putMVar m a
121 |         putMVar m a'
122 |     
123 |     modifyMVar :: MVar m a -> (a -> m (a, b)) -> m b
124 |     modifyMVar m io = mask $ \restore -> do
125 |         a      <- takeMVar m
126 |         (a',b) <- restore (io a) `onException` putMVar m a
127 |         putMVar m a'
128 |         return b
129 | 
130 | instance MonadMVar IO where
131 |     type MVar IO = IO.MVar
132 |     
133 |     newEmptyMVar = IO.newEmptyMVar
134 |     newMVar = IO.newMVar
135 |     
136 |     takeMVar = IO.takeMVar
137 |     putMVar = IO.putMVar
138 |     readMVar = IO.readMVar
139 |     
140 |     swapMVar = IO.swapMVar
141 |     
142 |     tryTakeMVar = IO.tryTakeMVar
143 |     tryPutMVar = IO.tryPutMVar
144 |     isEmptyMVar = IO.isEmptyMVar
145 |     
146 |     withMVar = IO.withMVar
147 |     modifyMVar_ = IO.modifyMVar_
148 |     modifyMVar = IO.modifyMVar
149 | 


--------------------------------------------------------------------------------
/Data/STQueue.hs:
--------------------------------------------------------------------------------
  1 | module Data.STQueue (
  2 |     STQueue, Location,
  3 |     new, Data.STQueue.null, enqueue, dequeue, delete,
  4 |     toList, toListWithLocation, mapMaybeM
  5 |   ) where
  6 | 
  7 | import Control.Monad
  8 | import Control.Monad.ST
  9 | import Control.Monad.ST.Class
 10 | import Data.STRef
 11 | 
 12 | import Utilities (pamf)
 13 | 
 14 | 
 15 | -- Initiall based on a Haskell translation of <http://www.java-tips.org/java-se-tips/java.lang/linked-list-based-queue-implementation.html>
 16 | 
 17 | 
 18 | data Node s a = Node { location :: Integer, value :: a, backwards_ref :: STRef s (Maybe (Node s a)) }
 19 | 
 20 | data Front s a = Empty
 21 |                | NonEmpty (Node s a) (Node s a)
 22 | data STQueue s a = MQ { next_location_ref :: STRef s Integer, front_ref :: STRef s (Front s a) }
 23 |                       deriving (Eq)
 24 | 
 25 | new :: ST s (STQueue s a)
 26 | new = do
 27 |     next_location_ref <- newSTRef 0
 28 |     front_ref <- newSTRef Empty
 29 |     return $ MQ next_location_ref front_ref
 30 | 
 31 | null :: STQueue s a -> ST s Bool
 32 | null q = readSTRef (front_ref q) `pamf` \front -> case front of
 33 |       Empty        -> True
 34 |       NonEmpty _ _ -> False
 35 | 
 36 | enqueue :: a -> STQueue s a -> ST s (Location s a)
 37 | enqueue x q = do
 38 |     next_location_i <- readSTRef (next_location_ref q)
 39 |     writeSTRef (next_location_ref q) (next_location_i + 1)
 40 |     
 41 |     enqueueInLocation next_location_i x q
 42 |     return $ L next_location_i q
 43 | 
 44 | enqueueInLocation :: Integer -> a -> STQueue s a -> ST s ()
 45 | enqueueInLocation next_location_i x q = do
 46 |     backwards_ref' <- newSTRef Nothing
 47 |     let node = Node next_location_i x backwards_ref'
 48 |     
 49 |     front <- readSTRef (front_ref q)
 50 |     case front of
 51 |       Empty -> do
 52 |           writeSTRef (front_ref q) $ NonEmpty node node
 53 |       NonEmpty front back -> do
 54 |           writeSTRef (front_ref q) $ NonEmpty front node
 55 |           writeSTRef (backwards_ref back) (Just node)
 56 | 
 57 | dequeue :: STQueue s a -> ST s (Maybe a)
 58 | dequeue = fmap (fmap snd) . dequeueWithLocation
 59 | 
 60 | dequeueWithLocation :: STQueue s a -> ST s (Maybe (Integer, a))
 61 | dequeueWithLocation q = do
 62 |     mb_front <- readSTRef (front_ref q)
 63 |     case mb_front of
 64 |       Empty -> return Nothing
 65 |       NonEmpty front back -> do
 66 |           mb_backwards <- readSTRef (backwards_ref front)
 67 |           replaceFront q mb_backwards back
 68 |           return (Just (location front, value front))
 69 | 
 70 | replaceFront :: STQueue s a -> Maybe (Node s a) -> Node s a -> ST s ()
 71 | replaceFront q mb_front back = writeSTRef (front_ref q) (maybe Empty (\front -> NonEmpty front back) mb_front)
 72 | 
 73 | 
 74 | toList :: STQueue s a -> ST s [a]
 75 | toList = fmap (map snd) . toListWithLocation
 76 | 
 77 | toListWithLocation :: STQueue s a -> ST s [(Integer, a)]
 78 | toListWithLocation q = do
 79 |    mb_front <- readSTRef (front_ref q)
 80 |    case mb_front of
 81 |      Empty -> return []
 82 |      NonEmpty front _back -> go [] front
 83 |        where
 84 |          go acc node = do
 85 |             mb_backwards <- readSTRef (backwards_ref node)
 86 |             let acc' = (location node, value node) : acc
 87 |             maybe (return (reverse acc')) (\backwards -> go acc' backwards) mb_backwards
 88 | 
 89 | 
 90 | mapMaybeM :: MonadST m => (a -> m (Maybe a)) -> STQueue (StateThread m) a -> m ()
 91 | mapMaybeM f q = go []
 92 |   where
 93 |     go ys = do
 94 |       mb_x <- liftST $ dequeueWithLocation q
 95 |       case mb_x of
 96 |         Nothing -> forM_ (reverse ys) $ \(loc, y) -> liftST $ enqueueInLocation loc y q
 97 |         Just (loc, x) -> do
 98 |           mb_y <- f x
 99 |           go (maybe ys (\y -> (loc, y) : ys) mb_y)
100 | 
101 | 
102 | data Location s a = L Integer (STQueue s a) -- TODO: could probably implement constant-time delete if I could tolerate more pointers
103 |                   deriving (Eq)
104 | 
105 | delete :: Location s a -> ST s (Maybe a)
106 | delete (L location_i q) = do
107 |     front <- readSTRef (front_ref q)
108 |     case front of
109 |       Empty               -> return Nothing
110 |       NonEmpty front back -> go front (\mb_front -> replaceFront q mb_front back)
111 |   where
112 |     go this write_this_ref
113 |       | location_i /= location this = do
114 |         mb_backwards <- readSTRef (backwards_ref this)
115 |         maybe (return Nothing) (\backwards -> go backwards (writeSTRef (backwards_ref this))) mb_backwards
116 |       | otherwise                   = do
117 |         mb_backwards <- readSTRef (backwards_ref this)
118 |         write_this_ref mb_backwards
119 |         return (Just (value this))
120 | 
121 | 
122 | -- main :: IO ()
123 | -- main = print (runST test :: (Int, Int, Int, Int))
124 | --   where
125 | --     test = do
126 | --       q <- new
127 | --       enqueue 1 q
128 | --       enqueue 2 q
129 | --       Just x1 <- dequeue q
130 | --       enqueue 3 q
131 | --       loc4 <- enqueue 4 q
132 | --       Just x2 <- dequeue q
133 | --       enqueue 5 q
134 | --       Just 4 <- delete loc4
135 | --       Just x3 <- dequeue q
136 | --       Just x4 <- dequeue q
137 | --       Nothing <- dequeue q
138 | --       return (x1, x2, x3, x4) -- (1, 2, 3, 5)
139 | 


--------------------------------------------------------------------------------
/Test/LazySmallCheck.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-}
  2 | -- | For documentation, see the paper "SmallCheck and Lazy SmallCheck:
  3 | -- automatic exhaustive testing for small values" available at
  4 | -- <http://www.cs.york.ac.uk/fp/smallcheck/>.  Several examples are
  5 | -- also included in the package.
  6 | {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
  7 | module Test.LazySmallCheck
  8 |   ( Serial(series) -- :: class
  9 |   , Series         -- :: type Series a = Int -> Cons a
 10 |   , Cons           -- :: *
 11 |   , cons           -- :: a -> Series a
 12 |   , (><)           -- :: Series (a -> b) -> Series a -> Series b
 13 |   , empty          -- :: Series a
 14 |   , (\/)           -- :: Series a -> Series a -> Series a
 15 |   , drawnFrom      -- :: [a] -> Cons a
 16 |   , cons0          -- :: a -> Series a
 17 |   , cons1          -- :: Serial a => (a -> b) -> Series b
 18 |   , cons2          -- :: (Serial a, Serial b) => (a -> b -> c) -> Series c
 19 |   , cons3          -- :: ...
 20 |   , cons4          -- :: ...
 21 |   , cons5          -- :: ...
 22 |   , Testable       -- :: class
 23 |   , Report(..)     -- :: * -> *
 24 |   , depthCheck     -- :: Testable a => Int -> a -> IO ()
 25 |   , depthCheck'    -- :: Testable a => Int -> a -> IO (Report a)
 26 |   , smallCheck     -- :: Testable a => Int -> a -> IO ()
 27 |   , smallCheck'    -- :: Testable a => Int -> a -> IO (Report a)
 28 |   , test           -- :: Testable a => a -> IO ()
 29 |   , test'          -- :: Testable a => a -> IO (Report a)
 30 |   , (==>)          -- :: Bool -> Bool -> Bool
 31 |   , Property       -- :: *
 32 |   , lift           -- :: Bool -> Property
 33 |   , neg            -- :: Property -> Property
 34 |   , (*&*)          -- :: Property -> Property -> Property
 35 |   , (*|*)          -- :: Property -> Property -> Property
 36 |   , (*=>*)         -- :: Property -> Property -> Property
 37 |   , (*=*)          -- :: Property -> Property -> Property
 38 |   )
 39 |   where
 40 | 
 41 | import Control.Exception
 42 | import System.Exit
 43 | import Data.List (intercalate)
 44 | 
 45 | infixr 0 ==>, *=>*
 46 | infixr 3 \/, *|*
 47 | infixl 4 ><, *&*
 48 | 
 49 | type Pos = [Int]
 50 | 
 51 | data Term = Var Pos Type | Ctr Int [Term]
 52 | 
 53 | data Type = SumOfProd [[Type]]
 54 | 
 55 | -- For debugging only:
 56 | instance Show Type where
 57 |     showsPrec d (SumOfProd ps) = case ps of
 58 |         []  -> showString "0"
 59 |         [p] -> showString $ showProd p
 60 |         _   -> showParen (d > 0) $ showString $ intercalate " + " (map showProd ps)
 61 |       where
 62 |         showProd :: [Type] -> String
 63 |         showProd [] = "1"
 64 |         showProd p  = intercalate " * " (map (\x -> showsPrec 1 x "") p)
 65 | 
 66 | type Series a = Int -> Cons a
 67 | 
 68 | data Cons a = C Type ([[Term] -> a])
 69 | 
 70 | class Serial a where
 71 |   series :: Series a
 72 | 
 73 | -- Series constructors
 74 | 
 75 | cons :: a -> Series a
 76 | cons a _d = C (SumOfProd [[]]) [const a]
 77 | 
 78 | empty :: Series a
 79 | empty _d = C (SumOfProd []) []
 80 | 
 81 | -- Bug:
 82 | --   let it = cons (:<) >< (series :: Series Nat) >< it in it)
 83 | -- Always has type:
 84 | --   SumOfProd [] == 0
 85 | -- When it should be:
 86 | --   SumOfProd ?? == 1 (The "1" is justified because undefined is always an admissable value)
 87 | --   SumOfProd ?? == 1 x 1
 88 | --
 89 | -- For lists:
 90 | --  n  | Type(n)
 91 | -- ----+--------
 92 | --  0  | 1
 93 | --  1  | 1 + 1 * 1
 94 | --  2  | 1 + (1 + 1 * 1) * (1 + 1)
 95 | --  3  | 1 + (1 + (1 + 1 * 1) * (1 + 1)) * (1 + 1 + 1)
 96 | (><) :: Series (a -> b) -> Series a -> Series b
 97 | (f >< a) d = C (SumOfProd [ta:p | shallow, p <- ps]) cs
 98 |   where
 99 |     C (SumOfProd ps) cfs = f d
100 |     C ta cas = a (d-1)
101 |     cs = [\(x:xs) -> cf xs (conv cas x) | shallow, cf <- cfs]
102 |     shallow = d > 0 -- && nonEmpty ta
103 | 
104 | -- nonEmpty :: Type -> Bool
105 | -- nonEmpty (SumOfProd ps) = not (null ps)
106 | 
107 | (\/) :: Series a -> Series a -> Series a
108 | (a \/ b) d = C (SumOfProd (ssa ++ ssb)) (ca ++ cb)
109 |   where
110 |     C (SumOfProd ssa) ca = a d
111 |     C (SumOfProd ssb) cb = b d
112 | 
113 | conv :: [[Term] -> a] -> Term -> a
114 | conv _cs (Var p _) = error ('\0':map toEnum p)
115 | conv cs  (Ctr i xs) = (cs !! i) xs
116 | 
117 | drawnFrom :: [a] -> Cons a
118 | drawnFrom xs = C (SumOfProd (map (const []) xs)) (map const xs)
119 | 
120 | -- Helpers, a la SmallCheck
121 | 
122 | cons0 :: a -> Series a
123 | cons0 f = cons f
124 | 
125 | cons1 :: Serial a => (a -> b) -> Series b
126 | cons1 f = cons f >< series
127 | 
128 | cons2 :: (Serial a, Serial b) => (a -> b -> c) -> Series c
129 | cons2 f = cons f >< series >< series
130 | 
131 | cons3 :: (Serial a, Serial b, Serial c) => (a -> b -> c -> d) -> Series d
132 | cons3 f = cons f >< series >< series >< series
133 | 
134 | cons4 :: (Serial a, Serial b, Serial c, Serial d) =>
135 |   (a -> b -> c -> d -> e) -> Series e
136 | cons4 f = cons f >< series >< series >< series >< series
137 | 
138 | cons5 :: (Serial a, Serial b, Serial c, Serial d, Serial e) =>
139 |   (a -> b -> c -> d -> e -> f) -> Series f
140 | cons5 f = cons f >< series >< series >< series >< series >< series
141 | 
142 | -- Standard instances
143 | 
144 | instance Serial () where
145 |   series = cons0 ()
146 | 
147 | instance Serial Bool where
148 |   series = cons0 False \/ cons0 True
149 | 
150 | instance Serial a => Serial (Maybe a) where
151 |   series = cons0 Nothing \/ cons1 Just
152 | 
153 | instance (Serial a, Serial b) => Serial (Either a b) where
154 |   series = cons1 Left \/ cons1 Right
155 | 
156 | instance Serial a => Serial [a] where
157 |   series = cons0 [] \/ cons2 (:)
158 | 
159 | instance (Serial a, Serial b) => Serial (a, b) where
160 |   series = cons2 (,) . (+1)
161 | 
162 | instance (Serial a, Serial b, Serial c) => Serial (a, b, c) where
163 |   series = cons3 (,,) . (+1)
164 | 
165 | instance (Serial a, Serial b, Serial c, Serial d) =>
166 |     Serial (a, b, c, d) where
167 |   series = cons4 (,,,) . (+1)
168 | 
169 | instance (Serial a, Serial b, Serial c, Serial d, Serial e) =>
170 |     Serial (a, b, c, d, e) where
171 |   series = cons5 (,,,,) . (+1)
172 | 
173 | instance Serial Int where
174 |   series d = drawnFrom [-d..d]
175 | 
176 | instance Serial Integer where
177 |   series d = drawnFrom (map toInteger [-d..d])
178 | 
179 | instance Serial Char where
180 |   series d = drawnFrom (take (d+1) ['a'..])
181 | 
182 | instance Serial Float where
183 |   series d = drawnFrom (floats d)
184 | 
185 | instance Serial Double where
186 |   series d = drawnFrom (floats d)
187 | 
188 | floats :: RealFloat a => Int -> [a]
189 | floats d = [ encodeFloat sig exp
190 |            | sig <- map toInteger [-d..d]
191 |            , exp <- [-d..d]
192 |            , odd sig || sig == 0 && exp == 0
193 |            ]
194 | 
195 | -- Term refinement
196 | 
197 | refine :: Term -> Pos -> [Term]
198 | refine (Var p (SumOfProd ss)) [] = new p ss
199 | refine (Ctr c xs) p = map (Ctr c) (refineList xs p)
200 | 
201 | refineList :: [Term] -> Pos -> [[Term]]
202 | refineList xs (i:is) = [ls ++ y:rs | y <- refine x is]
203 |   where (ls, x:rs) = splitAt i xs
204 | 
205 | new :: Pos -> [[Type]] -> [Term]
206 | new p ps = [ Ctr c (zipWith (\i t -> Var (p++[i]) t) [0..] ts)
207 |            | (c, ts) <- zip [0..] ps ]
208 | 
209 | -- Find total instantiations of a partial value
210 | 
211 | -- total :: Term -> [Term] 
212 | -- total val = tot val
213 | --   where
214 | --     tot (Ctr c xs) = [Ctr c ys | ys <- mapM tot xs] 
215 | --     tot (Var p (SumOfProd ss)) = [y | x <- new p ss, y <- tot x]
216 | 
217 | -- Answers
218 | 
219 | answer :: a -> (a -> IO b) -> (Pos -> IO b) -> IO b
220 | answer a known unknown =
221 |   do res <- try (evaluate a)
222 |      case res of
223 |        Right b -> known b
224 |        Left (ErrorCall ('\0':p)) -> unknown (map fromEnum p)
225 |        Left e -> throw e
226 | 
227 | -- Refute
228 | 
229 | refute :: Result a -> IO (Report a)
230 | refute r = ref (args r)
231 |   where
232 |     ref xs = eval (apply r xs) known unknown
233 |       where
234 |         known True = return (Success 1)
235 |         known False = return (Failure (zipWith ($) (showArgs r) xs) (failInfo r xs))
236 |         unknown p = sumMapM ref 1 (refineList xs p)
237 | 
238 | sumMapM :: (a -> IO (Report b)) -> Int -> [a] -> IO (Report b)
239 | sumMapM _f n [] = return (Success n)
240 | sumMapM f n (a:as) = seq n $ do
241 |     report <- f a
242 |     continueReport report (\m -> sumMapM f (n+m) as)
243 | 
244 | -- Properties with parallel conjunction (Lindblad TFP'07)
245 | 
246 | data Property =
247 |     Bool Bool
248 |   | Neg Property
249 |   | And Property Property
250 |   | ParAnd Property Property
251 |   | Eq Property Property
252 | 
253 | eval :: Property -> (Bool -> IO a) -> (Pos -> IO a) -> IO a
254 | eval p k u = answer p (\p -> eval' p k u) u
255 | 
256 | eval' :: Property -> (Bool -> IO a) -> (Pos -> IO a) -> IO a
257 | eval' (Bool b) k u = answer b k u
258 | eval' (Neg p) k u = eval p (k . not) u
259 | eval' (And p q) k u = eval p (\b-> if b then eval q k u else k b) u
260 | eval' (Eq p q) k u = eval p (\b-> if b then eval q k u else eval (Neg q) k u) u
261 | eval' (ParAnd p q) k u = eval p (\b-> if b then eval q k u else k b) unknown
262 |   where
263 |     unknown pos = eval q (\b-> if b then u pos else k b) (\_-> u pos)
264 | 
265 | lift :: Bool -> Property
266 | lift b = Bool b
267 | 
268 | neg :: Property -> Property
269 | neg p = Neg p
270 | 
271 | (*&*), (*|*), (*=>*), (*=*) :: Property -> Property -> Property
272 | p *&* q = ParAnd p q
273 | p *|* q = neg (neg p *&* neg q)
274 | p *=>* q = neg (p *&* neg q)
275 | p *=* q = Eq p q
276 | 
277 | -- Boolean implication
278 | 
279 | (==>) :: Bool -> Bool -> Bool
280 | False ==> _ = True
281 | True ==> x = x
282 | 
283 | -- Testable
284 | 
285 | data Result a =
286 |   Result { args     :: [Term]
287 |          , showArgs :: [Term -> String]
288 |          , failInfo :: [Term] -> FailInfo a
289 |          , apply    :: [Term] -> Property
290 |          }
291 | 
292 | data P a = P (Int -> Int -> Result a)
293 | 
294 | run :: Testable a => ([Term] -> a) -> Int -> Int -> Result a
295 | run a = f where P f = property a
296 | 
297 | class Testable a where
298 |   type FailInfo a
299 |   property :: ([Term] -> a) -> P a
300 | 
301 | instance Testable Bool where
302 |   type FailInfo Bool = ()
303 |   property apply = P $ \_n _d -> Result [] [] (\[] -> ()) (Bool . apply . reverse)
304 | 
305 | instance Testable Property where
306 |   type FailInfo Property = ()
307 |   property apply = P $ \_n _d -> Result [] [] (\[] -> ()) (apply . reverse)
308 | 
309 | instance (Show a, Serial a, Testable b) => Testable (a -> b) where
310 |   type FailInfo (a -> b) = (a, FailInfo b)
311 |   property f = P $ \n d ->
312 |     let C t c = series d
313 |         c' = conv c
314 |         r = run (\(x:xs) -> f xs (c' x)) (n+1) d
315 |     in  Result { args = Var [n] t : args r, showArgs = (show . c') : showArgs r, failInfo = \(x:xs) -> (c' x, failInfo r xs), apply = apply r }
316 | 
317 | data Report a = Success { testsRun :: Int }
318 |               | Failure { argStrings :: [String], failure :: FailInfo a }
319 | 
320 | continueReport :: Monad m => Report a -> (Int -> m (Report a)) -> m (Report a)
321 | continueReport (Success m)   k = k m
322 | continueReport (Failure s f) _ = return (Failure s f)
323 | 
324 | putReport :: Report a -> IO ()
325 | putReport (Success n)      = putStrLn $ "OK, required " ++ show n ++ " tests"
326 | putReport (Failure args _) = do
327 |     putStrLn "Counter example found:"
328 |     mapM_ putStrLn args
329 |     exitWith ExitSuccess
330 | 
331 | -- Top-level interface
332 | 
333 | depthCheck :: Testable a => Int -> a -> IO ()
334 | depthCheck d p = depthCheck' d p >>= putReport
335 | 
336 | depthCheck' :: Testable a => Int -> a -> IO (Report a)
337 | depthCheck' d p = refute (run (const p) 0 d)
338 | 
339 | smallCheck :: Testable a => Int -> a -> IO ()
340 | smallCheck d p = smallCheck' d p >>= putReport
341 | 
342 | smallCheck' :: Testable a => Int -> a -> IO (Report a)
343 | smallCheck' d p = go 0 [0..d]
344 |   where
345 |     go n [] = return (Success n)
346 |     go n (d:ds) = do
347 |         report <- d `depthCheck'` p
348 |         continueReport report $ \m -> go (n + m) ds
349 | 
350 | test :: forall a. Testable a => a -> IO ()
351 | test p = test' p >>= (putReport :: Report a -> IO ()) . uncurry Failure
352 | 
353 | test' :: Testable a => a -> IO ([String], FailInfo a)
354 | test' p = go 0
355 |   where
356 |     go d = do
357 |         report <- depthCheck' d p
358 |         case report of
359 |           Success _              -> go (d + 1)
360 |           Failure args fail_info -> return (args, fail_info)
361 | 


--------------------------------------------------------------------------------
/experiments/Data/MemoTrie.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE GADTs, TypeFamilies, TypeOperators, ScopedTypeVariables, CPP #-}
  2 | {-# OPTIONS_GHC -Wall -fenable-rewrite-rules #-}
  3 | -- ScopedTypeVariables works around a 6.10 bug.  The forall keyword is
  4 | -- supposed to be recognized in a RULES pragma.
  5 | 
  6 | ----------------------------------------------------------------------
  7 | -- |
  8 | -- Module      :  Data.MemoTrie
  9 | -- Copyright   :  (c) Conal Elliott 2008
 10 | -- License     :  BSD3
 11 | -- 
 12 | -- Maintainer  :  conal@conal.net
 13 | -- Stability   :  experimental
 14 | -- 
 15 | -- Trie-based memoizer
 16 | -- Adapted from sjanssen's paste: \"a lazy trie\" <http://hpaste.org/3839>.
 17 | ----------------------------------------------------------------------
 18 | 
 19 | module Data.MemoTrie
 20 |   ( HasTrie(..), domain, idTrie, (@.@)
 21 |   , (:->:)(..)
 22 |   -- , trie2, trie3, untrie2, untrie3
 23 |   , memo, memo2, memo3, mup
 24 |   , inTrie, inTrie2, inTrie3
 25 |   -- , untrieBits
 26 |   ) where
 27 | 
 28 | import Data.Bits
 29 | import Data.Word
 30 | import Data.Int
 31 | import Control.Applicative
 32 | import Control.Arrow (first,(&&&))
 33 | import Data.Monoid
 34 | import Data.Function (on)
 35 | 
 36 | -- import Prelude hiding (id,(.))
 37 | -- import Control.Category
 38 | -- import Control.Arrow
 39 | 
 40 | infixr 0 :->:
 41 | 
 42 | -- | Mapping from all elements of @a@ to the results of some function
 43 | class HasTrie a where
 44 |     -- | Representation of trie with domain type @a@
 45 |     data (:->:) a :: * -> *
 46 |     -- | Create the trie for the entire domain of a function
 47 |     trie   :: (a  ->  b) -> (a :->: b)
 48 |     -- | Convert a trie to a function, i.e., access a field of the trie
 49 |     untrie :: (a :->: b) -> (a  ->  b)
 50 |     -- | List the trie elements.  Order of keys (@:: a@) is always the same.
 51 |     enumerate :: (a :->: b) -> [(a,b)]
 52 | 
 53 | -- | Domain elements of a trie
 54 | domain :: HasTrie a => [a]
 55 | domain = map fst (enumerate (trie (const oops)))
 56 |  where
 57 |    oops = error "Data.MemoTrie.domain: range element evaluated."
 58 | 
 59 | -- Hm: domain :: [Bool] doesn't produce any output.
 60 | 
 61 | instance (HasTrie a, Eq b) => Eq (a :->: b) where
 62 |   (==) = (==) `on` (map snd . enumerate)
 63 | 
 64 | instance (HasTrie a, Show a, Show b) => Show (a :->: b) where
 65 |   show t = "Trie: " ++ show (enumerate t)
 66 | 
 67 | {-
 68 | trie2 :: (HasTrie a, HasTrie b) =>
 69 |          (a -> b -> c) -> (a :->: b :->: c)
 70 | -- trie2 h = trie $ \ a -> trie $ \ b -> h a b
 71 | -- trie2 h = trie $ \ a -> trie (h a)
 72 | trie2 h = trie (trie . h)
 73 | -- trie2 h = trie (fmap trie h)
 74 | -- trie2 = (fmap.fmap) trie trie
 75 | 
 76 | 
 77 | trie3 :: (HasTrie a, HasTrie b, HasTrie c) =>
 78 |          (a -> b -> c -> d) -> (a :->: b :->: c :->: d)
 79 | trie3 h = trie (trie2 . h)
 80 | 
 81 | untrie2 :: (HasTrie a, HasTrie b) =>
 82 |           (a :->: b :->: c)-> (a -> b -> c)
 83 | untrie2 tt = untrie . untrie tt
 84 | 
 85 | 
 86 | untrie3 :: (HasTrie a, HasTrie b, HasTrie c) =>
 87 |           (a :->: b :->: c :->: d)-> (a -> b -> c -> d)
 88 | untrie3 tt = untrie2 . untrie tt
 89 | -}
 90 | 
 91 | 
 92 | {-# RULES
 93 | "trie/untrie"   forall t. trie (untrie t) = t
 94 |  #-}
 95 | 
 96 | -- Don't include the dual rule:
 97 | --   "untrie/trie"   forall f. untrie (trie f) = f
 98 | -- which would defeat memoization.
 99 | --
100 | -- TODO: experiment with rule application.  Maybe re-enable "untrie/trie"
101 | -- but fiddle with phases, so it won't defeat 'memo'.
102 | 
103 | -- | Trie-based function memoizer
104 | memo :: HasTrie t => (t -> a) -> (t -> a)
105 | memo = untrie . trie
106 | 
107 | -- | Memoize a binary function, on its first argument and then on its
108 | -- second.  Take care to exploit any partial evaluation.
109 | memo2 :: (HasTrie s,HasTrie t) => (s -> t -> a) -> (s -> t -> a)
110 | 
111 | -- | Memoize a ternary function on successive arguments.  Take care to
112 | -- exploit any partial evaluation.
113 | memo3 :: (HasTrie r,HasTrie s,HasTrie t) => (r -> s -> t -> a) -> (r -> s -> t -> a)
114 | 
115 | -- | Lift a memoizer to work with one more argument.
116 | mup :: HasTrie t => (b -> c) -> (t -> b) -> (t -> c)
117 | mup mem f = memo (mem . f)
118 | 
119 | memo2 = mup memo
120 | memo3 = mup memo2
121 | 
122 | -- | Apply a unary function inside of a trie
123 | inTrie :: (HasTrie a, HasTrie c) =>
124 |           ((a  ->  b) -> (c  ->  d))
125 |        -> ((a :->: b) -> (c :->: d))
126 | inTrie = untrie ~> trie
127 | 
128 | -- | Apply a binary function inside of a trie
129 | inTrie2 :: (HasTrie a, HasTrie c, HasTrie e) =>
130 |            ((a  ->  b) -> (c  ->  d) -> (e  ->  f))
131 |         -> ((a :->: b) -> (c :->: d) -> (e :->: f))
132 | inTrie2 = untrie ~> inTrie
133 | 
134 | -- | Apply a ternary function inside of a trie
135 | inTrie3 :: (HasTrie a, HasTrie c, HasTrie e, HasTrie g) =>
136 |            ((a  ->  b) -> (c  ->  d) -> (e  ->  f) -> (g  ->  h))
137 |         -> ((a :->: b) -> (c :->: d) -> (e :->: f) -> (g :->: h))
138 | inTrie3 = untrie ~> inTrie2
139 | 
140 | 
141 | ---- Instances
142 | 
143 | instance HasTrie () where
144 |     data () :->: a = UnitTrie a
145 |     trie f = UnitTrie (f ())
146 |     untrie (UnitTrie a) = \ () -> a
147 |     enumerate (UnitTrie a) = [((),a)]
148 | 
149 | -- Proofs of inverse properties:
150 | 
151 | {-
152 |     untrie (trie f)
153 |       == { trie def }
154 |     untrie (UnitTrie (f ()))
155 |       == { untrie def }
156 |     \ () -> (f ())
157 |       == { const-unit }
158 |     f   
159 | 
160 |     trie (untrie (UnitTrie a))
161 |       == { untrie def }
162 |     trie (\ () -> a)
163 |       == { trie def }
164 |     UnitTrie ((\ () -> a) ())
165 |       == { beta-reduction }
166 |     UnitTrie a
167 | 
168 | Oops -- the last step of the first direction is bogus when f is non-strict.
169 | Can be fixed by using @const a@ in place of @\ () -> a@, but I can't do
170 | the same for other types, like integers or sums.
171 | 
172 | All of these proofs have this same bug, unless we restrict ourselves to
173 | memoizing hyper-strict functions.
174 | 
175 | -}
176 | 
177 | 
178 | instance HasTrie Bool where
179 |     data Bool :->: x = BoolTrie x x
180 |     trie f = BoolTrie (f False) (f True)
181 |     untrie (BoolTrie f t) = if' f t
182 |     enumerate (BoolTrie f t) = [(False,f),(True,t)]
183 | 
184 | -- | Conditional with boolean last.
185 | -- Spec: @if' (f False) (f True) == f@
186 | if' :: x -> x -> Bool -> x
187 | if' t _ False = t
188 | if' _ e True  = e
189 | 
190 | {-
191 |     untrie (trie f)
192 |       == { trie def }
193 |     untrie (BoolTrie (f False) (f True))
194 |       == { untrie def }
195 |     if' (f False) (f True)
196 |       == { if' spec }
197 |     f
198 | 
199 |     trie (untrie (BoolTrie f t))
200 |       == { untrie def }
201 |     trie (if' f t)
202 |       == { trie def }
203 |     BoolTrie (if' f t False) (if' f t True)
204 |       == { if' spec }
205 |     BoolTrie f t
206 | -}
207 | 
208 | 
209 | instance (HasTrie a, HasTrie b) => HasTrie (Either a b) where
210 |     data (Either a b) :->: x = EitherTrie (a :->: x) (b :->: x)
211 |     trie f = EitherTrie (trie (f . Left)) (trie (f . Right))
212 |     untrie (EitherTrie s t) = either (untrie s) (untrie t)
213 |     enumerate (EitherTrie s t) = enum' Left s `weave` enum' Right t
214 | 
215 | enum' :: (HasTrie a) => (a -> a') -> (a :->: b) -> [(a', b)]
216 | enum' f = (fmap.first) f . enumerate
217 | 
218 | weave :: [a] -> [a] -> [a]
219 | [] `weave` as = as
220 | as `weave` [] = as
221 | (a:as) `weave` bs = a : (bs `weave` as)
222 | 
223 | {-
224 |     untrie (trie f)
225 |        == { trie def }
226 |     untrie (EitherTrie (trie (f . Left)) (trie (f . Right)))
227 |        == { untrie def }
228 |     either (untrie (trie (f . Left))) (untrie (trie (f . Right)))
229 |        == { untrie . trie }
230 |     either (f . Left) (f . Right)
231 |        == { either }
232 |     f
233 | 
234 |     trie (untrie (EitherTrie s t))
235 |        == { untrie def }
236 |     trie (either (untrie s) (untrie t))
237 |        == { trie def }
238 |     EitherTrie (trie (either (untrie s) (untrie t) . Left))
239 |                (trie (either (untrie s) (untrie t) . Right))
240 |        == { either }
241 |     EitherTrie (trie (untrie s)) (trie (untrie t))
242 |        == { trie . untrie }
243 |     EitherTrie s t
244 | -}
245 | 
246 | 
247 | instance (HasTrie a, HasTrie b) => HasTrie (a,b) where
248 |     data (a,b) :->: x = PairTrie (a :->: (b :->: x))
249 |     trie f = PairTrie (trie (trie . curry f))
250 |     untrie (PairTrie t) = uncurry (untrie .  untrie t)
251 |     enumerate (PairTrie tt) =
252 |       [ ((a,b),x) | (a,t) <- enumerate tt , (b,x) <- enumerate t ]
253 | 
254 | {-
255 |     untrie (trie f)
256 |       == { trie def }
257 |     untrie (PairTrie (trie (trie . curry f)))
258 |       == { untrie def }
259 |     uncurry (untrie . untrie (trie (trie . curry f)))
260 |       == { untrie . trie }
261 |     uncurry (untrie . trie . curry f)
262 |       == { untrie . untrie }
263 |     uncurry (curry f)
264 |       == { uncurry . curry }
265 |     f
266 | 
267 |     trie (untrie (PairTrie t))
268 |       == { untrie def }
269 |     trie (uncurry (untrie .  untrie t))
270 |       == { trie def }
271 |     PairTrie (trie (trie . curry (uncurry (untrie .  untrie t))))
272 |       == { curry . uncurry }
273 |     PairTrie (trie (trie . untrie .  untrie t))
274 |       == { trie . untrie }
275 |     PairTrie (trie (untrie t))
276 |       == { trie . untrie }
277 |     PairTrie t
278 | -}
279 | 
280 | instance (HasTrie a, HasTrie b, HasTrie c) => HasTrie (a,b,c) where
281 |     data (a,b,c) :->: x = TripleTrie (((a,b),c) :->: x)
282 |     trie f = TripleTrie (trie (f . trip))
283 |     untrie (TripleTrie t) = untrie t . detrip
284 |     enumerate (TripleTrie t) = enum' trip t
285 | 
286 | trip :: ((a,b),c) -> (a,b,c)
287 | trip ((a,b),c) = (a,b,c)
288 | 
289 | detrip :: (a,b,c) -> ((a,b),c)
290 | detrip (a,b,c) = ((a,b),c)
291 | 
292 | 
293 | instance HasTrie x => HasTrie [x] where
294 |     data [x] :->: a = ListTrie (Either () (x,[x]) :->: a)
295 |     trie f = ListTrie (trie (f . list))
296 |     untrie (ListTrie t) = untrie t . delist
297 |     enumerate (ListTrie t) = enum' list t
298 | 
299 | list :: Either () (x,[x]) -> [x]
300 | list = either (const []) (uncurry (:))
301 | 
302 | delist :: [x] -> Either () (x,[x])
303 | delist []     = Left ()
304 | delist (x:xs) = Right (x,xs)
305 | 
306 | #define WordInstance(Type,TrieType)\
307 | instance HasTrie Type where \
308 |     data Type :->: a = TrieType ([Bool] :->: a);\
309 |     trie f = TrieType (trie (f . unbits));\
310 |     untrie (TrieType t) = untrie t . bits;\
311 |     enumerate (TrieType t) = enum' unbits t
312 | 
313 | WordInstance(Word,WordTrie)
314 | WordInstance(Word8,Word8Trie)
315 | WordInstance(Word16,Word16Trie)
316 | WordInstance(Word32,Word32Trie)
317 | WordInstance(Word64,Word64Trie)
318 | 
319 | -- instance HasTrie Word where
320 | --     data Word :->: a = WordTrie ([Bool] :->: a)
321 | --     trie f = WordTrie (trie (f . unbits))
322 | --     untrie (WordTrie t) = untrie t . bits
323 | --     enumerate (WordTrie t) = enum' unbits t
324 | 
325 | 
326 | -- | Extract bits in little-endian order
327 | bits :: Bits t => t -> [Bool]
328 | bits 0 = []
329 | bits x = testBit x 0 : bits (shiftR x 1)
330 | 
331 | -- | Convert boolean to 0 (False) or 1 (True)
332 | unbit :: Num t => Bool -> t
333 | unbit False = 0
334 | unbit True  = 1
335 | 
336 | -- | Bit list to value
337 | unbits :: Bits t => [Bool] -> t
338 | unbits [] = 0
339 | unbits (x:xs) = unbit x .|. shiftL (unbits xs) 1
340 | 
341 | instance HasTrie Char where
342 |     data Char :->: a = CharTrie (Int :->: a)
343 |     untrie (CharTrie t) n = untrie t (fromEnum n)
344 |     trie f = CharTrie (trie (f . toEnum))
345 |     enumerate (CharTrie t) = enum' toEnum t
346 | 
347 | -- Although Int is a Bits instance, we can't use bits directly for
348 | -- memoizing, because the "bits" function gives an infinite result, since
349 | -- shiftR (-1) 1 == -1.  Instead, convert between Int and Word, and use
350 | -- a Word trie.  Any Integral type can be handled similarly.
351 | 
352 | #define IntInstance(IntType,WordType,TrieType) \
353 | instance HasTrie IntType where \
354 |     data IntType :->: a = TrieType (WordType :->: a); \
355 |     untrie (TrieType t) n = untrie t (fromIntegral n); \
356 |     trie f = TrieType (trie (f . fromIntegral)); \
357 |     enumerate (TrieType t) = enum' fromIntegral t
358 | 
359 | IntInstance(Int,Word,IntTrie)
360 | IntInstance(Int8,Word8,Int8Trie)
361 | IntInstance(Int16,Word16,Int16Trie)
362 | IntInstance(Int32,Word32,Int32Trie)
363 | IntInstance(Int64,Word64,Int64Trie)
364 | 
365 | -- For unbounded integers, we don't have a corresponding Word type, so
366 | -- extract the sign bit.
367 | 
368 | instance HasTrie Integer where
369 |     data Integer :->: a = IntegerTrie ((Bool,[Bool]) :->: a)
370 |     trie f = IntegerTrie (trie (f . unbitsZ))
371 |     untrie (IntegerTrie t) = untrie t . bitsZ
372 |     enumerate (IntegerTrie t) = enum' unbitsZ t
373 | 
374 | 
375 | unbitsZ :: (Bits n) => (Bool,[Bool]) -> n
376 | unbitsZ (positive,bs) = sig (unbits bs)
377 |  where
378 |    sig | positive  = id
379 |        | otherwise = negate
380 | 
381 | bitsZ :: (Ord n, Bits n) => n -> (Bool,[Bool])
382 | bitsZ = (>= 0) &&& (bits . abs)
383 | 
384 | -- bitsZ n = (sign n, bits (abs n))
385 | 
386 | 
387 | 
388 | -- TODO: make these definitions more systematic.
389 | 
390 | 
391 | ---- Instances
392 | 
393 | {-
394 | 
395 | The \"semantic function\" 'untrie' is a morphism over 'Monoid', 'Functor',
396 | 'Applicative', 'Monad', 'Category', and 'Arrow', i.e.,
397 | 
398 |   untrie mempty          == mempty
399 |   untrie (s `mappend` t) == untrie s `mappend` untrie t
400 | 
401 |   untrie (fmap f t)      == fmap f (untrie t)
402 | 
403 |   untrie (pure a)        == pure a
404 |   untrie (tf <*> tx)     == untrie tf <*> untrie tx
405 | 
406 |   untrie (return a)      == return a
407 |   untrie (u >>= k)       == untrie u >>= untrie . k
408 | 
409 |   untrie id              == id
410 |   untrie (s . t)         == untrie s . untrie t
411 | 
412 |   untrie (arr f)         == arr f
413 |   untrie (first t)       == first (untrie t)
414 | 
415 | These morphism properties imply that all of the expected laws hold,
416 | assuming that we interpret equality semantically (or observationally).
417 | For instance,
418 | 
419 |   untrie (mempty `mappend` a)
420 |     == untrie mempty `mappend` untrie a
421 |     == mempty `mappend` untrie a
422 |     == untrie a
423 | 
424 |   untrie (fmap f (fmap g a))
425 |     == fmap f (untrie (fmap g a))
426 |     == fmap f (fmap g (untrie a))
427 |     == fmap (f.g) (untrie a)
428 |     == untrie (fmap (f.g) a)
429 | 
430 | The implementation instances then follow from applying 'trie' to both
431 | sides of each of these morphism laws.
432 | 
433 | -}
434 | 
435 | {-
436 | instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
437 |   mempty  = trie mempty
438 |   s `mappend` t = trie (untrie s `mappend` untrie t)
439 | 
440 | instance HasTrie a => Functor ((:->:) a) where
441 |   fmap f t      = trie (fmap f (untrie t))
442 | 
443 | instance HasTrie a => Applicative ((:->:) a) where
444 |   pure b        = trie (pure b)
445 |   tf <*> tx     = trie (untrie tf <*> untrie tx)
446 | 
447 | instance HasTrie a => Monad ((:->:) a) where
448 |   return a      = trie (return a)
449 |   u >>= k       = trie (untrie u >>= untrie . k)
450 | 
451 | -- instance Category (:->:) where
452 | --   id            = trie id
453 | --   s . t         = trie (untrie s . untrie t)
454 | 
455 | -- instance Arrow (:->:) where
456 | --   arr f         = trie (arr f)
457 | --   first t       = trie (first (untrie t))
458 | -}
459 | 
460 | -- Simplify, using inTrie, inTrie2
461 | 
462 | instance (HasTrie a, Monoid b) => Monoid (a :->: b) where
463 |   mempty  = trie mempty
464 |   mappend = inTrie2 mappend
465 | 
466 | instance HasTrie a => Functor ((:->:) a) where
467 |   fmap f = inTrie (fmap f)
468 | 
469 | instance HasTrie a => Applicative ((:->:) a) where
470 |   pure b = trie (pure b)
471 |   (<*>)  = inTrie2 (<*>)
472 | 
473 | instance HasTrie a => Monad ((:->:) a) where
474 |   return a = trie (return a)
475 |   u >>= k  = trie (untrie u >>= untrie . k)
476 | 
477 | -- | Identity trie
478 | idTrie :: HasTrie a => a :->: a
479 | idTrie = trie id
480 | 
481 | infixr 9 @.@
482 | -- | Trie composition
483 | (@.@) :: (HasTrie a, HasTrie b) =>
484 |          (b :->: c) -> (a :->: b) -> (a :->: c)
485 | (@.@) = inTrie2 (.)
486 | 
487 | 
488 | 
489 | -- instance Category (:->:) where
490 | --   id  = idTrie
491 | --   (.) = (.:)
492 | 
493 | -- instance Arrow (:->:) where
494 | --   arr f = trie (arr f)
495 | --   first = inTrie first
496 | 
497 | {-
498 | 
499 | Correctness of these instances follows by applying 'untrie' to each side
500 | of each definition and using the property @'untrie' . 'trie' == 'id'@.
501 | 
502 | The `Category` and `Arrow` instances don't quite work, however, because of
503 | necessary but disallowed `HasTrie` constraints on the domain type.
504 | 
505 | -}
506 | 
507 | 
508 | ---- To go elsewhere
509 | 
510 | -- Matt Hellige's notation for @argument f . result g@.
511 | -- <http://matt.immute.net/content/pointless-fun>
512 | 
513 | (~>) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b'))
514 | g ~> f = (f .) . (. g)
515 | 
516 | {-
517 | -- Examples
518 | f1,f1' :: Int -> Int
519 | f1 n = n + n
520 | 
521 | f1' = memo f1
522 | -}


--------------------------------------------------------------------------------
/Control/Monad/RTS.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
  2 | {-# LANGUAGE RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies, DeriveDataTypeable, StandaloneDeriving, ExistentialQuantification #-}
  3 | module Control.Monad.RTS (
  4 |     Scheduler, unfair, roundRobin, streamed,
  5 |     RTS, runRTS,
  6 |     testScheduleSafe
  7 |   ) where
  8 | 
  9 | -- Ideas:
 10 | --  * It might be cool to have a mode that generates random asynchronous exceptions to try to crash other threads
 11 | --  * We have to be able to show failing schedulings in a nice way
 12 | --  * I could detect more unreachable states if I find that a MVar currently blocking a Pending gets GCed
 13 | 
 14 | 
 15 | import Control.Applicative (Applicative(..))
 16 | import Control.Arrow ((***))
 17 | import qualified Control.Exception as E
 18 | import Control.Monad
 19 | import qualified Control.Monad.Concurrent as MC
 20 | import Control.Monad.Fix
 21 | import Control.Monad.ST
 22 | import Control.Monad.ST.Class
 23 | 
 24 | import Data.Foldable (Foldable(foldMap))
 25 | import Data.List
 26 | import Data.Maybe (maybeToList)
 27 | import Data.Monoid (Monoid(..))
 28 | import Data.STRef
 29 | import qualified Data.STQueue as STQ
 30 | import Data.Traversable (Traversable(traverse))
 31 | import qualified Data.Traversable as Traversable
 32 | import Data.Typeable (Typeable(..), Typeable1(..), mkTyCon, mkTyConApp)
 33 | 
 34 | import Debug.Trace
 35 | 
 36 | import Test.LazySmallCheck hiding (Report(..))
 37 | import Test.QuickCheck hiding (Success, Result, (><))
 38 | import Test.QuickCheck.Gen
 39 | 
 40 | import System.Random
 41 | import System.IO.Unsafe
 42 | 
 43 | import Unsafe.Coerce (unsafeCoerce)
 44 | 
 45 | import Utilities
 46 | import Prelude hiding (catch)
 47 | 
 48 | 
 49 | 
 50 | instance Arbitrary StdGen where
 51 |     arbitrary = MkGen $ \gen _ -> gen
 52 |     shrink _ = []
 53 | 
 54 | 
 55 | -- I was initially inspired by Quviq/PULSE <http://www.protest-project.eu/upload/paper/icfp070-claessen.pdf>.
 56 | -- However the approach that I'm taking here is much more similar to that of the CHESS system
 57 | -- of Madanlal Musuvathi <http://research.microsoft.com/en-us/people/madanm/allpubs.aspx>
 58 | 
 59 | 
 60 | -- I used to use unsafeIsEvaluated to decide where to put in "...", but that pruned too heavily because
 61 | -- I couldn't show the schedule before it was actually poked on and those thunks turned into real values.
 62 | {-# NOINLINE showsExplored #-}
 63 | showsExplored :: (a -> ShowS) -> a -> ShowS
 64 | showsExplored shows x = unsafePerformIO $ fmap (maybe (showString "...") shows) $ tryIf isLSCError (E.evaluate x)
 65 |   where
 66 |     -- Looked at the LSC code to see what sort of errors it was generating...
 67 |     isLSCError (E.ErrorCall ('\0':_)) = True
 68 |     isLSCError _                      = False
 69 |     
 70 |     tryIf :: E.Exception e => (e -> Bool) -> IO a -> IO (Maybe a)
 71 |     tryIf p act = fmap (either (\() -> Nothing) Just) $ E.tryJust (\e -> guard (p e) >> return ()) act
 72 | 
 73 | 
 74 | instance Serial Nat where
 75 |     series d = drawnFrom $ map Nat [0..d]
 76 | 
 77 | 
 78 | data Stream a = a :< Stream a
 79 | 
 80 | instance Show a => Show (Stream a) where
 81 |     showsPrec d = showsExplored (\(x :< xs) -> showParen (d > 0) $ showsPrec 1 x . showString " :< " . showsPrec 1 xs)
 82 | 
 83 | instance Serial a => Serial (Stream a) where
 84 |     series = cons2 (:<)
 85 | 
 86 | genericIndexStream :: Num i => Stream a -> i -> a
 87 | genericIndexStream (x :< xs) n = if n == 0 then x else genericIndexStream xs (n - 1)
 88 | 
 89 | 
 90 | -- | A stream suitable for use for guiding the scheduler. The natural number stored in the nth element
 91 | -- of one of the Stream (Stream Nat) we contain is drawn uniformly from the range [0,n].
 92 | --
 93 | -- In one use of the scheduler, all but one element of each Stream will be discarded, since they correspond
 94 | -- to schedulings for executions with more or less pending processes than we actually saw
 95 | newtype SchedulerStream = SS { unSS :: Stream (Nat, SchedulerStream) }
 96 |                         deriving (Show)
 97 | 
 98 | instance Serial SchedulerStream where
 99 |     series = streamSeries0
100 |       where
101 |         streamSeries' :: Nat -> Series (Nat, SchedulerStream)
102 |         streamSeries' n = (cons (,) >< (\_ -> drawnFrom [0..n]) >< streamSeries0) . (+1)
103 |     
104 |         streamSeries0 :: Series SchedulerStream
105 |         streamSeries0 = streamSeriesN 0
106 |     
107 |         streamSeriesN :: Nat -> Series SchedulerStream
108 |         streamSeriesN n = cons (\n ss -> SS ((:<) n (unSS ss))) >< streamSeries' n >< streamSeriesN (n + 1)
109 | 
110 | 
111 | newtype Scheduler = Scheduler { schedule :: Nat              -- ^ One less than the number of pending processes (n)
112 |                                          -> (Scheduler, Nat) -- ^ Pending process to run, and the next scheduler (0-based index, so valid values are from 0 to n inclusive)
113 |                               }
114 | 
115 | unfair :: Scheduler
116 | unfair = Scheduler schedule
117 |   where schedule _ = (unfair, 0)
118 | 
119 | roundRobin :: Scheduler
120 | roundRobin = Scheduler schedule
121 |   where schedule n = (roundRobin, n)
122 | 
123 | streamed :: Stream Nat -> Scheduler
124 | streamed (i :< is) = Scheduler schedule
125 |   where schedule n = (streamed is, i `mod` n) -- A bit unsatisfactory because I really want a uniform chance of scheduling the available threads
126 | 
127 | schedulerStreamed :: SchedulerStream -> Scheduler
128 | schedulerStreamed (SS sss) = Scheduler schedule
129 |   where schedule n = (schedulerStreamed sss', i)
130 |           where (i, sss') = genericIndexStream sss n
131 | 
132 | randomised :: StdGen -> Scheduler
133 | randomised gen = Scheduler schedule
134 |   where schedule n = (randomised gen', i)
135 |           where (i, gen') = randomR (0, n) gen
136 | 
137 | instance Show Scheduler where
138 |     show _ = "Scheduler"
139 | 
140 | instance Arbitrary Scheduler where
141 |     arbitrary = fmap randomised arbitrary
142 |     shrink _ = []
143 | 
144 | instance Serial Scheduler where
145 |     series = cons schedulerStreamed >< series
146 | 
147 | -- TODO: think about what happens if we get something other than Success on a non-main thread.
148 | -- I'm not even sure what the current behaviour is, but I think it stops us immediately.
149 | data Result a = Success a
150 |               | BlockedIndefinitely
151 |               | UnhandledException E.SomeException
152 |               deriving (Show)
153 | 
154 | instance Eq a => Eq (Result a) where
155 |     Success x1            == Success x2            = x1 == x2
156 |     BlockedIndefinitely   == BlockedIndefinitely   = True
157 |     UnhandledException e1 == UnhandledException e2 = show e1 == show e2
158 |     _                     == _                     = False
159 | 
160 | instance Functor Result where
161 |     fmap = liftM
162 | 
163 | instance Applicative Result where
164 |     pure = return
165 |     (<*>) = ap
166 | 
167 | instance Monad Result where
168 |     return = Success
169 |     Success x              >>= f = f x
170 |     BlockedIndefinitely    >>= _ = BlockedIndefinitely
171 |     (UnhandledException e) >>= _ = UnhandledException e
172 | 
173 | instance Foldable Result where
174 |     foldMap f (Success x)            = f x
175 |     foldMap _ BlockedIndefinitely    = mempty
176 |     foldMap _ (UnhandledException _) = mempty
177 | 
178 | instance Traversable Result where
179 |     traverse f (Success x)            = pure Success <*> f x
180 |     traverse _ BlockedIndefinitely    = pure BlockedIndefinitely
181 |     traverse _ (UnhandledException e) = pure (UnhandledException e)
182 | 
183 | 
184 | data SyncObject s r = forall a. SyncMVar     (MVar s r a)
185 |                     |           SyncThreadId (ThreadId s r)
186 | 
187 | instance Eq (SyncObject s r) where
188 |     SyncMVar mvar1    == SyncMVar mvar2    = mvar1 == unsafeCoerce mvar2 -- Grr... nonetheless safe since (==) cannot look at the element (free theorem)
189 |     SyncThreadId tid1 == SyncThreadId tid2 = tid1 == tid2
190 |     _                 == _                 = False
191 | 
192 | 
193 | -- | A closure of a value from the user over the set of SyncObjects that it could possibly reference
194 | type Closure s r a = (SetEq (SyncObject s r), a)
195 | 
196 | 
197 | newtype SetEq a = SetEq { unSetEq :: [a] }
198 | 
199 | instance Eq a => Eq (SetEq a) where
200 |     se1 == se2 = all (`elem` unSetEq se2) (unSetEq se1) -- This is correct because elements in both sets must be unique
201 | 
202 | emptySetEq :: SetEq a
203 | emptySetEq = SetEq []
204 | 
205 | singletonSetEq :: a -> SetEq a
206 | singletonSetEq x = SetEq [x]
207 | 
208 | insertSetEq :: Eq a => a -> SetEq a -> SetEq a
209 | insertSetEq x se = if x `elem` unSetEq se then se else SetEq $ x : unSetEq se
210 | 
211 | unionSetEq :: Eq a => SetEq a -> SetEq a -> SetEq a
212 | unionSetEq se1 se2 = SetEq $ nub $ unSetEq se1 ++ unSetEq se2
213 | 
214 | instance Eq a => Monoid (SetEq a) where
215 |     mempty = emptySetEq
216 |     mappend = unionSetEq
217 | 
218 | 
219 | -- | Both blocked and unblocked threads have some information in common.
220 | type Thread s r = (ThreadId s r,
221 |                    Unwinder s r)
222 | 
223 | -- | Unblocked threads are those that are available for immediate execution. There is no immediate
224 | -- problem preventing them from making progress.
225 | --
226 | -- These threads will either take delivery of an asynchronous exception or continue normally when rescheduled.
227 | type Unblocked s r = (Thread s r, Pending s r)
228 | 
229 | -- | Blocked threads are those that cannot currently be executed because they are waiting for another
230 | -- thread to get back to them. In this case, the corresponding 'Pending' action is stored in the corresponding
231 | -- synchronisation object (i.e. the MVar or ThreadId blocked on).
232 | --
233 | -- These threads will either take delivery of an asynchronous exception or continue normally after both the
234 | -- other thread has got back to them and they get rescheduled.
235 | type Blocked s r = Thread s r
236 | 
237 | -- | A pending coroutine
238 | --
239 | -- You almost always want to use (scheduleM ((tid, throw, k) : unblockeds)) rather than (unPending k unblockeds) because
240 | -- scheduleM gives QuickCheck a chance to try other schedulings, whereas using unPending forces control
241 | -- flow to continue in the current thread.
242 | type Pending s r = Pending' s r (Result r)
243 | 
244 | -- | Generalised pending corountine (a reader monad)
245 | newtype Pending' s r a = Pending { unPending :: ([(Maybe (SyncObject s r), Unblocked s r)] -> Nat -> ST s (Result r)) -- ^ Rescheduling continuation: used whenever we are about to block on something (allow Nothing SyncObject for a yield call)
246 |                                              -> Nat                                                                   -- ^ Next ThreadId to allocate (NB: could extract reader monad structure w/ the continuation above?)
247 |                                              -> ST s a }
248 | 
249 | instance Functor (Pending' s r) where
250 |     fmap = liftM
251 | 
252 | instance Applicative (Pending' s r) where
253 |     pure = return
254 |     (<*>) = ap
255 | 
256 | instance Monad (Pending' s r) where
257 |     return x = liftST (return x)
258 |     mx >>= fxmy = Pending $ \k_schedule next_tid -> unPending mx k_schedule next_tid >>= \x -> unPending (fxmy x) k_schedule next_tid
259 | 
260 | reschedule :: [(Maybe (SyncObject s r), Unblocked s r)] -> Pending s r
261 | reschedule unblockeds = Pending $ \k_schedule next_tid -> k_schedule unblockeds next_tid
262 | 
263 | instance MonadST (Pending' s r) where
264 |     type StateThread (Pending' s r) = s
265 |     liftST st = Pending $ \_k_schedule _next_tid -> st
266 | 
267 | 
268 | newtype RTS s r a = RTS { unRTS :: (Closure s r a -> Pending s r) -- ^ Continuation: how we should continue after we have our result
269 |                                 -> STQ.STQueue s (Blocked s r)    -- ^ Blocked threads that may or may not have been resumed yet: this is necessary because we may want to deliver asyncronous exceptions to them. As such, everything in this list is Interruptible.
270 |                                 -> Closure s r (Thread s r)
271 |                                 -> Pending s r }
272 | -- | We have to be able to throw several exceptions in succession because we can have more than one pending asynchronous exceptions.
273 | data Unwinder s r = Unwinder {
274 |     -- | Where we stand wrt. asynchronous exceptions: this is used to control whether we can actually unwind
275 |     masking         :: E.MaskingState,
276 |     -- | The ST action be used as a one-shot thing. For blocked threads, once you run the ST action (to deliver an asynchronous exception), the thread
277 |     -- will be dumped from the suspended position and enqueued as pending by the user of Blocked
278 |     uncheckedUnwind :: Closure s r E.SomeException
279 |                     -> ST s (ThreadId s r -> Pending s r) -- After unwinding we actually always resume on the same thread -- the ThreadId business is a nice hack to reuse Unblocked
280 |   }
281 | 
282 | maskUnwinder :: Unwinder s r -> Interruptibility -> Unwinder s r
283 | maskUnwinder throw Interruptible   = throw { masking = case masking throw of E.MaskedUninterruptible -> E.MaskedUninterruptible; _ -> E.MaskedInterruptible }
284 | maskUnwinder throw Uninterruptible = throw { masking = E.MaskedUninterruptible }
285 | 
286 | 
287 | unwindAsync :: Thread s r -> Interruptibility -> Maybe (Closure s r E.SomeException -> ST s (Pending s r))
288 | unwindAsync (tid, throw) interruptible = guard (canThrow (masking throw) interruptible) >> return (fmap ($ tid) . uncheckedUnwind throw)
289 | 
290 | unwindSync :: Thread s r -> Closure s r E.SomeException -> Pending s r
291 | unwindSync (tid, throw) clo_e = join $ liftST $ fmap ($ tid) (uncheckedUnwind throw clo_e)
292 | 
293 | runRTS :: Scheduler -> (forall s. RTS s r r) -> Result r
294 | runRTS scheduler mx = runST $ do
295 |     tid <- newThreadId 0
296 |     blockeds <- STQ.new
297 |     unPending (unRTS mx (\(_syncobjs, x) -> return (Success x)) blockeds (singletonSetEq (SyncThreadId tid), (tid, unhandledException E.Unmasked))) (scheduleM scheduler blockeds) 1
298 | 
299 | unhandledException :: E.MaskingState -> Unwinder s r
300 | unhandledException masking = Unwinder {
301 |     masking = masking,
302 |     uncheckedUnwind = \(_syncobjs, e) -> return (\_tid -> return (UnhandledException e)) -- We only report the last unhandled exception. Could we do something else?
303 |   }
304 | 
305 | 
306 | instance Functor (RTS s r) where
307 |     fmap = liftM
308 | 
309 | instance Applicative (RTS s r) where
310 |    pure = return
311 |    -- We can be more precise about how syncobjs flow for an Applicative computation than if we just used `ap` directly. This helps trim the search space:
312 |    mfxy <*> mx = RTS $ \k_y blockeds (syncobjs, (tid, throw)) -> unRTS mfxy (\(syncobjs_fxy, fxy) -> unRTS mx (\(syncobjs_x, x) -> k_y (syncobjs_fxy `unionSetEq` syncobjs_x, fxy x)) blockeds (syncobjs, (tid, throw))) blockeds (syncobjs, (tid, throw))
313 | 
314 | instance Monad (RTS s r) where
315 |     return x = RTS $ \k _blockeds (syncobjs, _thread) -> k (syncobjs, x)
316 |     mx >>= fxmy = RTS $ \k_y blockeds (syncobjs, (tid, throw)) -> unRTS mx (\(syncobjs', x) -> unRTS (fxmy x) k_y blockeds (syncobjs', (tid, throw))) blockeds (syncobjs, (tid, throw))
317 | 
318 | instance MC.MonadException (RTS s r) where
319 |     mask = mask
320 |     uninterruptibleMask = uninterruptibleMask
321 |     getMaskingState = getMaskingState
322 |     
323 |     throwIO = throwIO
324 |     throwTo = throwTo
325 |     catch = catch
326 | 
327 | instance MC.MonadConcurrent (RTS s r) where
328 |     type MC.ThreadId (RTS s r) = ThreadId s r
329 | 
330 |     forkIO = forkIO
331 |     myThreadId = myThreadId
332 | 
333 |     yield = yield
334 | 
335 | data Interruptibility = Interruptible | Uninterruptible
336 | 
337 | mask :: ((forall a. RTS s r a -> RTS s r a) -> RTS s r b) -> RTS s r b
338 | mask = maskWith Interruptible
339 | 
340 | uninterruptibleMask :: ((forall a. RTS s r a -> RTS s r a) -> RTS s r b) -> RTS s r b
341 | uninterruptibleMask = maskWith Uninterruptible
342 | 
343 | getMaskingState :: RTS s r E.MaskingState
344 | getMaskingState = RTS $ \k _blockeds (syncobjs, (_tid, throw)) -> k (syncobjs, masking throw)
345 | 
346 | maskWith :: Interruptibility -> ((forall a. RTS s r a -> RTS s r a) -> RTS s r b) -> RTS s r b
347 | maskWith interruptible while = RTS $ \k blockeds (syncobjs, (tid, throw)) -> reschedule [(Just (SyncThreadId tid), ((tid, throw), unRTS (while (\unmask -> RTS $ \k' blockeds' (syncobjs', (tid', throw')) -> unRTS unmask k' blockeds' (syncobjs', (tid', throw' { masking = masking throw })))) (\b -> prepare [k b]) blockeds (syncobjs, (tid, throw `maskUnwinder` interruptible))))]
348 | 
349 | throwIO :: E.Exception e => e -> RTS s r a
350 | throwIO e = RTS $ \_k _blockeds (syncobjs, thread) -> unwindSync thread (syncobjs, E.SomeException e)
351 | 
352 | throwTo :: E.Exception e => ThreadId s r -> e -> RTS s r ()
353 | throwTo target_tid e = RTS $ \k blockeds (syncobjs, thread@(tid, throw)) -> case target_tid == tid of
354 |     True -> unwindSync thread (syncobjs, E.SomeException e) -- See GHC #4888: we always throw an exception regardless of the mask mode
355 |     False -> reschedule [(Just (SyncThreadId target_tid), (thread, do
356 |       -- If we ourselves get interrupted by an asynchronous exception before the one we sent was delivered,
357 |       -- recover by still delivering the exception but ensure that doing so does not cause the pending list to change
358 |       _ <- liftST $ mfix $ \kill_interruptable -> do
359 |         kill_blocked <- enqueueAsyncException target_tid (syncobjs, E.SomeException e) (thread, k (syncobjs, ())) kill_interruptable
360 |         blocked_loc <- flip STQ.enqueue blockeds (tid, throw { uncheckedUnwind = \e -> kill_blocked >> uncheckedUnwind throw e })
361 |         return $ STQ.delete blocked_loc >>= \(Just _) -> return ()
362 |       reschedule []))]
363 | 
364 | catch :: E.Exception e => RTS s r a -> (e -> RTS s r a) -> RTS s r a
365 | catch mx handle = RTS $ \k blockeds (syncobjs, (tid, throw)) -> unRTS mx k blockeds (syncobjs, (tid, throw { uncheckedUnwind = \(syncobjs', e) -> maybe (uncheckedUnwind throw (syncobjs', e)) (\e -> return (\tid -> unRTS (handle e) k blockeds (syncobjs `mappend` syncobjs', (tid, throw)))) (E.fromException e) }))
366 | 
367 | -- | Give up control to the scheduler. Control is automatically given up to the scheduler after calling every RTS primitive
368 | -- which might have effects observable outside the current thread. This is enough to almost guarantee that there exists some
369 | -- scheduler for which the RTS monad will give the same results as the IO monad.
370 | --
371 | -- The exception to this guarantee is if you write a non-terminating computation on a thread (other than the initial thread) which
372 | -- does not call any RTS primitive that gives up control to the scheduler. For such computations, you need to manually add a
373 | -- call to 'yield' to allow the scheduler to interrupt the loop.
374 | yield :: RTS s r ()
375 | yield = RTS $ \k _blockeds (syncobjs, thread) -> reschedule [(Nothing, (thread, k (syncobjs, ())))]
376 |   -- It is certainly enough to yield on every bind operation. But this is too much (and it breaks the monad laws).
377 |   -- Quviq/PULSE yields just before every side-effecting operation. I think we can just yield after every side-effecting
378 |   -- operation and get the same results.
379 | 
380 | 
381 | scheduleM :: Scheduler -> STQ.STQueue s (Blocked s r) -> [(Maybe (SyncObject s r), Unblocked s r)] -> Nat -> ST s (Result r)
382 | scheduleM scheduler blockeds unblockeds next_tid = do
383 |     -- 1) We could continue by just stepping the unblockeds to their next yield point
384 |     let possibilities0 = [return (pending, unblockeds') | ((_syncobject, (_thread, pending)), unblockeds') <- holes unblockeds]
385 |     -- 2) We could continue by delivering asynchronous exceptions to the unblocked threads
386 |     possibilities1 <- flip mapMaybeM (holes unblockeds) $ \((_syncobject, (thread, _pending)), unblockeds') -> fmap (fmap (fmap (\possibility -> (possibility, unblockeds')))) $ dequeueAsyncException' Uninterruptible thread
387 |     -- 3) We could continue by delivering asynchronous exceptions to the blocked threads
388 |     -- This is the only mechanism that lets such threads wake up, bar the blocking call resuming normally.
389 |     current_blockeds <- STQ.toList blockeds
390 |     possibilities2 <- flip mapMaybeM current_blockeds $ \thread -> fmap (fmap (fmap (\possibility -> (possibility, unblockeds)))) $ dequeueAsyncException' Interruptible thread
391 |       -- Note that the resumed thing will take care of deleting this blocked entery from the queue
392 |     
393 |     -- Use a scheduling strategy to decide which of these possibilities we should try out:
394 |     case possibilities0 ++ possibilities1 ++ possibilities2 of
395 |       [] -> return BlockedIndefinitely
396 |       possibilities -> do
397 |           let (scheduler', i) = schedule scheduler (genericLength possibilities - 1)
398 |           (pending, unblockeds') <- possibilities `genericIndex` i
399 |           unPending pending (\unblockeds'' -> scheduleM scheduler' blockeds (unblockeds' ++ unblockeds'')) next_tid
400 | 
401 | 
402 | instance MonadST (RTS s r) where
403 |     type StateThread (RTS s r) = s
404 |     liftST st = RTS $ \k _blockeds (syncobjs, _thread) -> Pending $ \k_schedule next_tid -> st >>= \x -> unPending (k (syncobjs, x)) k_schedule next_tid
405 | 
406 | canThrow :: E.MaskingState -> Interruptibility -> Bool
407 | canThrow E.Unmasked            _             = True
408 | canThrow E.MaskedInterruptible Interruptible = True
409 | canThrow _                     _             = False
410 | 
411 | dequeueAsyncException' :: Interruptibility -> Thread s r -> ST s (Maybe (ST s (Pending s r)))
412 | dequeueAsyncException' interruptible thread@(tid, _) = do
413 |     case unwindAsync thread interruptible of
414 |        -- Cannot unwind this (blocked) thread right now due to masking
415 |       Nothing -> return Nothing
416 |       Just unchecked_unwind -> do
417 |         no_exceptions <- nullAsyncExceptions tid
418 |         if no_exceptions
419 |          then return Nothing
420 |          else return $ Just $ do
421 |           Just (e, mb_resumable) <- dequeueAsyncException tid
422 |           pending <- unchecked_unwind e
423 |           return $ prepare (maybe [pending] (\(_, resumed_pending) -> resumed_pending : [pending]) mb_resumable)
424 | 
425 | data ThreadId s r = ThreadId Nat (STRef s (Queue (Closure s r E.SomeException, STRef s (Maybe (ST s (Unblocked s r))))))
426 | 
427 | instance Eq (ThreadId s r) where
428 |     ThreadId n1 _ == ThreadId n2 _ = n1 == n2
429 | 
430 | instance Ord (ThreadId s r) where
431 |     ThreadId n1 _ `compare` ThreadId n2 _ = n1 `compare` n2
432 | 
433 | instance Show (ThreadId s r) where
434 |     show (ThreadId n _) = show n
435 | 
436 | instance Typeable (ThreadId s r) where
437 |     typeOf _ = mkTyConApp (mkTyCon "Control.Monad.RTS.ThreadId") []
438 | 
439 | newThreadId :: Nat -> ST s (ThreadId s r)
440 | newThreadId tid = fmap (ThreadId tid) $ newSTRef emptyQueue
441 | 
442 | enqueueAsyncException :: ThreadId s r -> Closure s r E.SomeException -> Unblocked s r -> ST s () -> ST s (ST s ())
443 | enqueueAsyncException (ThreadId _ ref) e resumable notify_block_complete = do
444 |     asyncs <- readSTRef ref
445 |     resumable_ref <- newSTRef $ Just $ notify_block_complete >> return resumable
446 |     writeSTRef ref (queue (e, resumable_ref) asyncs)
447 |     return $ readSTRef resumable_ref >>= \(Just _) -> writeSTRef resumable_ref Nothing
448 | 
449 | nullAsyncExceptions :: ThreadId s r -> ST s Bool
450 | nullAsyncExceptions (ThreadId _ ref) = fmap nullQueue (readSTRef ref)
451 | 
452 | dequeueAsyncException :: ThreadId s r -> ST s (Maybe (Closure s r E.SomeException, Maybe (Unblocked s r)))
453 | dequeueAsyncException (ThreadId _ ref) = do
454 |     asyncs <- readSTRef ref
455 |     case dequeue asyncs of
456 |       Nothing                            -> return Nothing
457 |       Just ((e, resumable_ref), asyncs') -> writeSTRef ref asyncs' >> readSTRef resumable_ref >>= \mb_get_resumable -> Traversable.sequence mb_get_resumable >>= \mb_resumable -> return (Just (e, mb_resumable))
458 | 
459 | 
460 | forkIO :: RTS s r () -> RTS s r (MC.ThreadId (RTS s r))
461 | forkIO forkable = RTS $ \k blockeds (syncobjs, (_, Unwinder { masking = masking })) -> Pending $ \k_schedule next_tid -> do
462 |     tid' <- newThreadId next_tid
463 |     let syncobjs' = SyncThreadId tid' `insertSetEq` syncobjs
464 |     unPending (prepare [k (syncobjs', tid'), unRTS forkable (\(_syncobjs, ()) -> Pending $ \k_schedule -> k_schedule []) blockeds (syncobjs', (tid', unhandledException masking))]) k_schedule (next_tid + 1)
465 | 
466 | myThreadId :: RTS s r (MC.ThreadId (RTS s r))
467 | myThreadId = RTS $ \k _blockeds (syncobjs, (tid, _throw)) -> k (syncobjs, tid)
468 | 
469 | 
470 | instance MC.MonadMVar (RTS s r) where
471 |     type MC.MVar (RTS s r) = MVar s r
472 |     
473 |     newEmptyMVar = newEmptyMVar
474 |     newMVar = newMVar
475 |     
476 |     takeMVar = takeMVar
477 |     putMVar = putMVar
478 |     
479 |     tryTakeMVar = undefined
480 |     tryPutMVar = undefined
481 |     isEmptyMVar = undefined
482 | 
483 | 
484 | data MVar s r a = MVar {
485 |     mvar_data :: STRef s (Maybe a),
486 |     -- MVars have guaranteed FIFO semantics, hence the queues
487 |     mvar_putters :: STQ.STQueue s (                 ST s (a, Pending s r)),
488 |     mvar_takers  :: STQ.STQueue s (Closure s r a -> ST s (Pending s r))
489 |   }
490 | 
491 | deriving instance Eq (MVar s r a)
492 | 
493 | instance Typeable1 (MVar s r) where
494 |     typeOf1 _ = mkTyConApp (mkTyCon "Control.Monad.RTS.MVar") []
495 | 
496 | newEmptyMVar :: RTS s r (MVar s r a)
497 | newEmptyMVar = newMVarInternal Nothing
498 | 
499 | newMVar :: a -> RTS s r (MVar s r a)
500 | newMVar = newMVarInternal . Just
501 | 
502 | newMVarInternal :: Maybe a -> RTS s r (MVar s r a)
503 | newMVarInternal mb_x = RTS $ \k _blockeds (syncobjs, _thread) -> do
504 |     mvar <- liftST $ do
505 |         data_ref <- newSTRef mb_x
506 |         putter_queue <- STQ.new
507 |         taker_queue <- STQ.new
508 |         return (MVar data_ref putter_queue taker_queue)
509 |     -- NB: unPending legitimate here because newMVarInternal cannot have externally visible side effects
510 |     k (SyncMVar mvar `insertSetEq` syncobjs, mvar)
511 | 
512 | takeMVar :: MVar s r a -> RTS s r a
513 | takeMVar mvar = RTS $ \k blockeds (syncobjs, thread@(tid, throw)) -> reschedule [(Just (SyncMVar mvar), (thread, Pending $ \k_schedule next_tid -> do
514 |     dat <- readSTRef (mvar_data mvar)
515 |     case dat of
516 |        -- NB: we must guarantee that the woken thread doing a putMVar (if any) completes its operation since takeMVar has this guarantee
517 |       Just x  -> do
518 |           (dat', mb_unblocked) <- STQ.dequeue (mvar_putters mvar) >>= \it -> case it of
519 |               Nothing            -> return (Nothing, Nothing)
520 |               Just interrupt_act -> fmap (Just *** Just) interrupt_act
521 |           writeSTRef (mvar_data mvar) dat'
522 |           unPending (prepare (k (syncobjs, x) : maybeToList mb_unblocked)) k_schedule next_tid
523 |       Nothing -> do
524 |           _ <- mfix $ \interrupt_act -> do
525 |               success_loc <- STQ.enqueue interrupt_act (mvar_takers mvar)
526 |               -- If we are interrupted, an asynchronous exception won the race: make sure that the standard wakeup loses
527 |               interrupt_loc <- flip STQ.enqueue blockeds (tid, throw { uncheckedUnwind = \e -> STQ.delete success_loc >>= \(Just _) -> uncheckedUnwind throw e })
528 |               return $ \(syncobjs', x) -> STQ.delete interrupt_loc >>= \(Just _) -> return (k (syncobjs `mappend` syncobjs', x))
529 |           k_schedule [] next_tid))]
530 | 
531 | putMVar :: MVar s r a -> a -> RTS s r ()
532 | putMVar mvar x = RTS $ \k blockeds (syncobjs, thread@(tid, throw)) -> reschedule [(Just (SyncMVar mvar), (thread, Pending $ \k_schedule next_tid -> do
533 |     dat <- readSTRef (mvar_data mvar)
534 |     case dat of
535 |        -- NB: we must guarantee that the woken thread doing a takeMVar (if any) completes its operation since putMVar has this guarantee
536 |       Nothing -> do
537 |           (dat', mb_unblocked) <- STQ.dequeue (mvar_takers mvar) >>= \it -> case it of
538 |               Nothing            -> return (Just x, Nothing)
539 |               Just interrupt_act -> fmap (((,) Nothing) . Just) (interrupt_act (syncobjs, x))
540 |           writeSTRef (mvar_data mvar) dat'
541 |           unPending (prepare (k (syncobjs, ()) : maybeToList mb_unblocked)) k_schedule next_tid
542 |       Just x  -> do
543 |           _ <- mfix $ \interrupt_act -> do
544 |               success_loc <- STQ.enqueue interrupt_act (mvar_putters mvar)
545 |               -- If we are interrupted, an asynchronous exception won the race: make sure that the standard wakeup loses
546 |               interrupt_loc <- flip STQ.enqueue blockeds (tid, throw { uncheckedUnwind = \e -> STQ.delete success_loc >>= \(Just _) -> uncheckedUnwind throw e })
547 |               return $ STQ.delete interrupt_loc >>= \(Just _) -> return (x, (k (syncobjs, ())))
548 |           k_schedule [] next_tid))]
549 | 
550 | 
551 | prepare :: [Pending s r] -> Pending s r
552 | prepare = go []
553 |   where
554 |     go syncobjs_unblockeds []             = Pending $ \k_schedule next_tid -> k_schedule syncobjs_unblockeds next_tid
555 |     go syncobjs_unblockeds (pending:rest) = Pending $ \k_schedule next_tid -> unPending pending (\syncobjs_unblockeds' next_tid' -> unPending (go (syncobjs_unblockeds' ++ syncobjs_unblockeds) rest) k_schedule next_tid') next_tid
556 | 
557 | 
558 | _example1 :: RTS s r Integer
559 | _example1 = do
560 |     yield
561 |     v <- newEmptyMVar
562 |     --putMVar v 3
563 |     putMVar v 3
564 |     yield
565 |     --takeMVar v
566 |     takeMVar v
567 | 
568 | _example2 :: RTS s r Integer
569 | _example2 = do
570 |     v_in <- newMVar 1336
571 |     v_out <- newEmptyMVar
572 |     _ <- forkIO $ do
573 |         x <- takeMVar v_in
574 |         yield
575 |         putMVar v_out (x + 1)
576 |     takeMVar v_out
577 | 
578 | -- An example with a race: depending on scheduling, this either returns "Hello" or "World"
579 | _example3 :: RTS s r String
580 | _example3 = do
581 |     v <- newEmptyMVar
582 |     _ <- forkIO $ putMVar v "Hello"
583 |     _ <- forkIO $ putMVar v "World"
584 |     takeMVar v
585 | 
586 | 
587 | testScheduleSafe :: Eq r => (forall s. RTS s r r) -> IO ()
588 | -- Cuter:
589 | --testScheduleSafe act = test $ \sched -> expected == runRTS sched act
590 | -- More flexible:
591 | testScheduleSafe act = test $ \ss -> trace (show ss) $ expected == runRTS (schedulerStreamed ss) act
592 | -- Working:
593 | --testScheduleSafe act = quickCheck $ \gen -> expected == runRTS (randomised gen) act
594 |   where expected = runRTS roundRobin act
595 | 
596 | 
597 | _main :: IO ()
598 | _main = do
599 |     -- Demonstrates the presence of a data race - these two invocations return different results
600 |     print $ runRTS unfair _example3
601 |     print $ runRTS roundRobin _example3
602 | 
603 |     -- Let's see if we can find the race automatically!
604 |     testScheduleSafe _example3
605 | 
606 | 


--------------------------------------------------------------------------------