-
Notifications
You must be signed in to change notification settings - Fork 149
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* Get everything working with GHC 8 * Fix all warnings (on GHC 8) * Improve code style consistency * Make benchmarks run in a separate process, and include GC time * Remove the inherent memory leak (retained results) in the benchmarks * Use -Wall for all build outputs * Use -auto-all for profiling * Create Data.WeakBag (a better way of managing subscribers) * Update Data.Functor.Misc to use new primitives exposed by Data.Dependent.Map * Add Show, GShow, and ShowTag instances for Const2 * Add Functor (Dynamic t) * Make Dynamic a primitive supplied by Reflex implementations * Add Incremental, a new primitive reactive datatype * Add mergeIncremental, a merge that can have inputs added and removed efficiently * Make all time-invariant operations on Dynamics pure * Add a phantom type to Spider, to distinguish different Spider domains * Add a mutex around Spider domains * Add a way of creating new Spider domains * Substantially refactor Spider internals to increase clarity * Add a (much) more useful error message when an Event causality loop is detected; with profiling enabeled, it will include the stack traces of all Events participating in the loop * Clean up tests and benchmarks
- Loading branch information
Ryan Trinkle
committed
May 28, 2016
1 parent
53b06db
commit d20ce36
Showing
15 changed files
with
1,916 additions
and
971 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,81 @@ | ||
| {-# LANGUAGE BangPatterns #-} | ||
| module Data.WeakBag (WeakBag, WeakBagTicket, empty, singleton, insert, Data.WeakBag.traverse, remove) where | ||
|
|
||
| import Control.Concurrent.STM | ||
| import Control.Exception | ||
| import Control.Monad | ||
| import Control.Monad.IO.Class | ||
| import Data.IORef | ||
| import System.Mem.Weak | ||
| import Data.IntMap.Strict (IntMap) | ||
| import qualified Data.IntMap.Strict as IntMap | ||
|
|
||
| data WeakBag a = WeakBag | ||
| { _weakBag_nextId :: {-# UNPACK #-} !(TVar Int) --TODO: what if this wraps around? | ||
| , _weakBag_children :: {-# UNPACK #-} !(TVar (IntMap (Weak a))) | ||
| } | ||
|
|
||
| data WeakBagTicket a = WeakBagTicket | ||
| { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a) | ||
| , _weakBagTicket_item :: {-# NOUNPACK #-} !a | ||
| } | ||
|
|
||
| {-# INLINE insert #-} | ||
| insert :: a -> WeakBag a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBagTicket a) | ||
| insert a (WeakBag nextId children) wbRef finalizer = do | ||
| a' <- evaluate a | ||
| wbRef' <- evaluate wbRef | ||
| myId <- atomically $ do | ||
| myId <- readTVar nextId | ||
| writeTVar nextId $! succ myId | ||
| return myId | ||
| let cleanup = do | ||
| wb <- readIORef wbRef' | ||
| mb <- deRefWeak wb | ||
| forM_ mb $ \b -> do | ||
| isLastNode <- atomically $ do | ||
| cs <- readTVar children | ||
| let csWithoutMe = IntMap.delete myId cs | ||
| writeTVar children $! csWithoutMe | ||
| return $ IntMap.size csWithoutMe == 0 | ||
| when isLastNode $ finalizer b | ||
| return () | ||
| return () | ||
| wa <- mkWeakPtr a' $ Just cleanup | ||
| atomically $ modifyTVar' children $ IntMap.insert myId wa | ||
| return $ WeakBagTicket | ||
| { _weakBagTicket_weakItem = wa | ||
| , _weakBagTicket_item = a' | ||
| } | ||
|
|
||
| {-# INLINE empty #-} | ||
| empty :: IO (WeakBag a) | ||
| empty = do | ||
| nextId <- newTVarIO 1 | ||
| children <- newTVarIO IntMap.empty | ||
| let bag = WeakBag | ||
| { _weakBag_nextId = nextId | ||
| , _weakBag_children = children | ||
| } | ||
| return bag | ||
|
|
||
| {-# INLINE singleton #-} | ||
| singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket a) | ||
| singleton a wbRef finalizer = do | ||
| bag <- empty | ||
| ticket <- insert a bag wbRef finalizer | ||
| return (bag, ticket) | ||
|
|
||
| {-# INLINE traverse #-} | ||
| -- | Visit every node in the given list. If new nodes are appended during the traversal, they will not be visited. | ||
| -- Every live node that was in the list when the traversal began will be visited exactly once; however, no guarantee is made about the order of the traversal. | ||
| traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m () | ||
| traverse (WeakBag _ children) f = do | ||
| cs <- liftIO $ readTVarIO children | ||
| forM_ cs $ \c -> do | ||
| ma <- liftIO $ deRefWeak c | ||
| mapM_ f ma | ||
|
|
||
| {-# INLINE remove #-} | ||
| remove :: WeakBagTicket a -> IO () | ||
| remove = finalize . _weakBagTicket_weakItem |
Oops, something went wrong.