ryantrinkle/weak-refs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add failing test case with cyclic graph

Browse Source
This commit is contained in:
Ryan Trinkle 2023-04-07 18:09:31 -04:00
parent 8f2f4d7478
commit a671900c9b
1 changed files with 21 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
main.hs
View File

@ -13,9 +13,12 @@ import GHC.Prim
import Control.Monad.Primitive import Control.Monad.Primitive
import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap import qualified Data.IntMap.Strict as IntMap
import Data.Set (Set)
import qualified Data.Set as Set
import System.IO.Unsafe import System.IO.Unsafe
import Control.Monad import Control.Monad
import Control.Concurrent import Control.Concurrent
import Data.Foldable
main :: IO () main :: IO ()
main = do main = do
@ -89,6 +92,18 @@ testGraphX = do
print =<< findForward nai print =<< findForward nai
print =<< findForward nbi print =<< findForward nbi
testGraphO :: IO ()
testGraphO = do
(nai, nao) <- newNode "a"
(nbi, nbo) <- newNode "b"
(nci, nco) <- newNode "c"
link nao nbi
link nbo nci
link nco nai
performGCUntilFinalizersQuiesce
[] <- toList <$> findForward nai
pure ()
data NodeContents a = NodeContents data NodeContents a = NodeContents
{ _nodeContents_key :: !Int { _nodeContents_key :: !Int
, _nodeContents_value :: a , _nodeContents_value :: a
@ -151,6 +166,9 @@ link aOut bIn = do
atomicModifyIORef' (_nodeContents_forwardLinks a) $ \m -> (IntMap.insert (_nodeContents_key b) bIn m, ()) atomicModifyIORef' (_nodeContents_forwardLinks a) $ \m -> (IntMap.insert (_nodeContents_key b) bIn m, ())
atomicModifyIORef' (_nodeContents_backLinks b) $ \m -> (IntMap.insert (_nodeContents_key a) aOut m, ()) atomicModifyIORef' (_nodeContents_backLinks b) $ \m -> (IntMap.insert (_nodeContents_key a) aOut m, ())
findForwardVals :: Ord a => NodeInput a -> IO (Set a)
findForwardVals i = Set.fromList . IntMap.elems <$> findForward i
findForward :: forall a. NodeInput a -> IO (IntMap a) findForward :: forall a. NodeInput a -> IO (IntMap a)
findForward i = go mempty (IntMap.singleton (_nodeInput_key i) i) findForward i = go mempty (IntMap.singleton (_nodeInput_key i) i)
where where
@ -162,10 +180,10 @@ findForward i = go mempty (IntMap.singleton (_nodeInput_key i) i)
Nothing -> go found restToSearch Nothing -> go found restToSearch
Just this -> do Just this -> do
newLinks <- readIORef (_nodeContents_forwardLinks this) newLinks <- readIORef (_nodeContents_forwardLinks this)
go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch newLinks) go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch (newLinks `IntMap.difference` found))
findBackward :: forall a. NodeOutput a -> IO (IntMap a) findBackward :: forall a. NodeOutput a -> IO (IntMap a)
findBackward i = go mempty (IntMap.singleton (_nodeOutput_key i) i) findBackward o = go mempty (IntMap.singleton (_nodeOutput_key o) o)
where where
go :: IntMap a -> IntMap (NodeOutput a) -> IO (IntMap a) go :: IntMap a -> IntMap (NodeOutput a) -> IO (IntMap a)
go found toSearch = case IntMap.minViewWithKey toSearch of go found toSearch = case IntMap.minViewWithKey toSearch of
@ -175,7 +193,7 @@ findBackward i = go mempty (IntMap.singleton (_nodeOutput_key i) i)
Nothing -> go found restToSearch Nothing -> go found restToSearch
Just this -> do Just this -> do
newLinks <- readIORef (_nodeContents_backLinks this) newLinks <- readIORef (_nodeContents_backLinks this)
go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch newLinks) go (IntMap.insert k (_nodeContents_value this) found) (IntMap.union restToSearch (newLinks `IntMap.difference` found))
testDualWeak :: IO () testDualWeak :: IO ()
testDualWeak = do testDualWeak = do