From 9aee30ac574c67047fe166d2720ce7582a50fb36 Mon Sep 17 00:00:00 2001
From: Michael Walker <mike@barrucadu.co.uk>
Date: Mon, 12 Jan 2015 00:08:53 +0000
Subject: [PATCH] Deconflate lifting and creating new CVars in Fixed

---
 Control/Monad/Conc/Fixed/IO.hs       |  6 +++---
 Control/Monad/Conc/Fixed/Internal.hs | 14 ++++++++++++++
 Control/Monad/Conc/Fixed/ST.hs       |  6 +++---
 3 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/Control/Monad/Conc/Fixed/IO.hs b/Control/Monad/Conc/Fixed/IO.hs
index 1cce709..15684df 100644
--- a/Control/Monad/Conc/Fixed/IO.hs
+++ b/Control/Monad/Conc/Fixed/IO.hs
@@ -106,9 +106,9 @@ fork (C ma) = C $ cont $ \c -> AFork (runCont ma $ const AStop) $ c ()
 
 -- | Create a new empty 'CVar'.
 newEmptyCVar :: Conc t (CVar t a)
-newEmptyCVar = liftIO $ do
-  ioref <- newIORef (Nothing, [])
-  return $ V ioref
+newEmptyCVar = C $ cont lifted where
+  lifted c = ANew $ c <$> newEmptyCVar'
+  newEmptyCVar' = V <$> newIORef (Nothing, [])
 
 -- | Block on a 'CVar' until it is empty, then write to it.
 putCVar :: CVar t a -> a -> Conc t ()
diff --git a/Control/Monad/Conc/Fixed/Internal.hs b/Control/Monad/Conc/Fixed/Internal.hs
index 57e2d7c..25135b1 100644
--- a/Control/Monad/Conc/Fixed/Internal.hs
+++ b/Control/Monad/Conc/Fixed/Internal.hs
@@ -50,6 +50,7 @@ data Action n r =
   | forall a. AGet     (R r a) (a -> Action n r)
   | forall a. ATake    (R r a) (a -> Action n r)
   | forall a. ATryTake (R r a) (Maybe a -> Action n r)
+  | ANew  (n (Action n r))
   | ALift (n (Action n r))
   | AStop
 
@@ -76,6 +77,8 @@ type Trace = [(ThreadId, ThreadAction)]
 data ThreadAction =
     Fork ThreadId
   -- ^ Start a new thread.
+  | New
+  -- ^ Create a new 'CVar'.
   | Put [ThreadId]
   -- ^ Put into a 'CVar', possibly waking up some threads.
   | BlockedPut
@@ -169,6 +172,7 @@ stepThread (ATryPut  ref a c) = stepTryPut  ref a c
 stepThread (AGet     ref c)   = stepGet     ref c
 stepThread (ATake    ref c)   = stepTake    ref c
 stepThread (ATryTake ref c)   = stepTryTake ref c
+stepThread (ANew     na)      = stepNew     na
 stepThread (ALift    na)      = stepLift    na
 stepThread  AStop             = stepStop
 
@@ -250,6 +254,16 @@ stepTryTake ref c fixed i threads = do
       return (goto (c val) i threads', TryTake True woken)
     Nothing   -> return (goto (c Nothing) i threads, TryTake False [])
 
+-- | Create a new @CVar@. This is exactly the same as lifting a value,
+-- except by separating the two we can (a) produce a more useful
+-- trace, and (b) make smarter pre-emption decisions.
+stepNew :: (Monad (c t), Monad n)
+        => n (Action n r)
+        -> Fixed c n r t -> ThreadId -> Threads n r -> n (Threads n r, ThreadAction)
+stepNew na _ i threads = do
+  a <- na
+  return (goto a i threads, New)
+
 -- | Lift an action from the underlying monad into the @Conc@
 -- computation.
 stepLift :: (Monad (c t), Monad n)
diff --git a/Control/Monad/Conc/Fixed/ST.hs b/Control/Monad/Conc/Fixed/ST.hs
index 0852ed9..a2ff078 100644
--- a/Control/Monad/Conc/Fixed/ST.hs
+++ b/Control/Monad/Conc/Fixed/ST.hs
@@ -102,9 +102,9 @@ fork (C ma) = C $ cont $ \c -> AFork (runCont ma $ const AStop) $ c ()
 
 -- | Create a new empty 'CVar'.
 newEmptyCVar :: Conc t (CVar t a)
-newEmptyCVar = liftST $ do
-  stref <- newSTRef (Nothing, [])
-  return $ V stref
+newEmptyCVar = C $ cont lifted where
+  lifted c = ANew $ c <$> newEmptyCVar'
+  newEmptyCVar' = V <$> newSTRef (Nothing, [])
 
 -- | Block on a 'CVar' until it is empty, then write to it.
 putCVar :: CVar t a -> a -> Conc t ()