diff --git a/alarmclock.cabal b/alarmclock.cabal
--- a/alarmclock.cabal
+++ b/alarmclock.cabal
@@ -1,5 +1,5 @@
 name:                alarmclock
-version:             0.2.0.4
+version:             0.2.0.5
 synopsis:            Wake up and perform an action at a certain time.
 description:         Wake up and perform an action at a certain time.
 homepage:            https://bitbucket.org/davecturner/alarmclock
diff --git a/src/Control/Concurrent/AlarmClock.hs b/src/Control/Concurrent/AlarmClock.hs
--- a/src/Control/Concurrent/AlarmClock.hs
+++ b/src/Control/Concurrent/AlarmClock.hs
@@ -32,12 +32,13 @@
   ) where
 
 import Control.Applicative ((<$>), (<*>))
-import Control.Concurrent (forkIO)
+import Control.Concurrent (forkIO, newEmptyMVar, readMVar, putMVar)
 import Control.Concurrent.STM (STM, atomically, retry, TVar, newTVar, writeTVar, readTVar, modifyTVar')
 import Control.Concurrent.Timeout (timeout)
 import Control.Exception (finally)
 import Control.Monad (void)
 import Data.Time (UTCTime, diffUTCTime, getCurrentTime)
+import GHC.Conc (labelThread, myThreadId)
 
 {-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -}
 data AlarmClock = AlarmClock
@@ -55,14 +56,11 @@
     -- the alarm has gone off to cause it to go off again.
   -> IO AlarmClock
 newAlarmClock onWakeUp = do
-  joinVar <- atomically $ newTVar False
-  ac <- atomically $ AlarmClock (waitOn joinVar) <$> newTVar AlarmNotSet <*> newTVar False
-  void $ forkIO $ runAlarmClock ac (onWakeUp ac) `finally` atomically (writeTVar joinVar True)
+  joinVar <- newEmptyMVar
+  ac <- atomically $ AlarmClock (readMVar joinVar) <$> newTVar AlarmNotSet <*> newTVar False
+  void $ forkIO $ runAlarmClock ac (onWakeUp ac) `finally` putMVar joinVar ()
   return ac
 
-waitOn :: TVar Bool -> IO ()
-waitOn v = atomically $ readTVar v >>= \case True -> return (); False -> retry
-
 {-| Destroy the 'AlarmClock' so no further alarms will occur. If the alarm is currently going off
 then this will block until the action is finished. -}
 destroyAlarmClock :: AlarmClock -> IO ()
@@ -98,34 +96,34 @@
 
 data AlarmSetting = AlarmNotSet | AlarmSet UTCTime | AlarmDestroyed
 
-readNextAlarmSetting :: AlarmClock -> IO (Maybe UTCTime)
-readNextAlarmSetting AlarmClock{..} = atomically $ readTVar acNewSetting >>= \case
-  AlarmNotSet    -> retry
-  AlarmDestroyed -> return Nothing
-  AlarmSet t     -> do
-    writeTVar acNewSetting AlarmNotSet
-    writeTVar acIsSet True
-    return $ Just t
+labelMyThread :: String -> IO ()
+labelMyThread threadLabel = myThreadId >>= flip labelThread threadLabel
 
 runAlarmClock :: AlarmClock -> IO () -> IO ()
-runAlarmClock ac wakeUpAction = loop
+runAlarmClock AlarmClock{..} wakeUpAction = labelMyThread "alarmclock" >> loop
   where
-  loop = readNextAlarmSetting ac >>= go
+  loop = readNextSetting >>= go
 
+  readNextSetting = atomically $ readTVar acNewSetting >>= \case
+    AlarmNotSet    -> retry
+    AlarmDestroyed -> return Nothing
+    AlarmSet t     -> do
+      writeTVar acNewSetting AlarmNotSet
+      writeTVar acIsSet True
+      return $ Just t
+
   go Nothing           = return ()
   go (Just wakeUpTime) = wakeNoLaterThan wakeUpTime
 
   wakeNoLaterThan wakeUpTime = do
-    dt <- diffUTCTime wakeUpTime <$> getCurrentTime
+    dt <- ceiling <$> (1000000 *) <$> diffUTCTime wakeUpTime <$> getCurrentTime
     if dt <= 0
       then actAndContinue
-      else timeout (ceiling $ 1000000 * dt)
-                   (readNextAlarmSetting ac)
-            >>= \case
-              Nothing -> actAndContinue
-              Just newSetting -> go newSetting
+      else timeout dt readNextSetting >>= \case
+            Nothing -> actAndContinue
+            Just newSetting -> go newSetting
 
   actAndContinue = do
-    atomically $ writeTVar (acIsSet ac) False
+    atomically $ writeTVar acIsSet False
     wakeUpAction
     loop