Merge branch 'HeinrichApfelmus/fewer-finalizers'

In this branch, we fix the following TODO item:

When inserting an edge into a `GraphGC`, two new finalizers would be created and attached to the incident vertices. This would result in an accumulation of finalizers if either vertex stays reachable for a long time. The solution is to attach a single finalizer when the vertex is added to the `GraphGC` for the first time.

reactive-banana/reactive-banana.cabal

@@ -114,11 +114,30 @@ Test-Suite tests
                         vault,
                         these
 
+Benchmark space
+  default-language:     Haskell2010
+  type:                 exitcode-stdio-1.0
+  build-depends:        base
+                      , reactive-banana
+                      , tasty-quickcheck
+                      , tasty
+                      , QuickCheck
+  hs-source-dirs:       tests
+  main-is:              space.hs
+  other-modules:        Reactive.Banana.Test.Mid.Space
+                      , Reactive.Banana.Test.High.Space
+  ghc-options:        -rtsopts -eventlog
+
 
 Benchmark benchmark
-  default-language:   Haskell2010
-  type:          exitcode-stdio-1.0
-  build-depends: base, tasty-bench, reactive-banana, containers, random, tasty
-  hs-source-dirs: benchmark
-  main-is: Main.hs
-  ghc-options:  "-with-rtsopts=-A32m"
+  default-language:     Haskell2010
+  type:                 exitcode-stdio-1.0
+  build-depends:        base
+                      , reactive-banana
+                      , containers
+                      , random
+                      , tasty
+                      , tasty-bench
+  hs-source-dirs:       benchmark
+  main-is:              Main.hs
+  ghc-options:          "-with-rtsopts=-A32m"

reactive-banana/src/Reactive/Banana/Prim/Low/Graph.hs

@@ -271,7 +271,7 @@ walkSuccessors xs step g = go (Q.fromList $ zipLevels xs) Set.empty []
                           let successors = zipLevels $ map snd $ getOutgoing g v
                           in  insertList q1 successors
                 go q2 (Set.insert v seen) (v:visits)
-    
+
 
 insertList :: Ord k => Queue k v -> [(k,v)] -> Queue k v
 insertList = L.foldl' (\q (k,v) -> Q.insert k v q)

reactive-banana/src/Reactive/Banana/Prim/Low/GraphGC.hs

@@ -24,8 +24,10 @@ module Reactive.Banana.Prim.Low.GraphGC
 
 import Control.Applicative
     ( (<|>) )
+import Control.Monad
+    ( unless )
 import Data.IORef
-    ( IORef, atomicModifyIORef, newIORef, readIORef )
+    ( IORef, atomicModifyIORef', newIORef, readIORef )
 import Data.Maybe
     ( fromJust )
 import Data.Unique.Really
@@ -117,33 +119,37 @@ listReachableVertices GraphGC{graphRef} = do
 -- | Insert an edge from the first vertex to the second vertex.
 insertEdge :: (Ref v, Ref v) -> GraphGC v -> IO ()
 insertEdge (x,y) g@GraphGC{graphRef} = do
-    -- TODO: Reduce the number of finalizers if the vertex is
-    -- already in the graph
-    Ref.addFinalizer x (finalizeVertex g ux)
-    Ref.addFinalizer y (finalizeVertex g uy)
-    insertTheEdge =<< makeWeakPointerThatRepresentsEdge
+    (xKnown, yKnown) <-
+        insertTheEdge =<< makeWeakPointerThatRepresentsEdge
+    unless xKnown $ Ref.addFinalizer x (finalizeVertex g ux)
+    unless yKnown $ Ref.addFinalizer y (finalizeVertex g uy)
   where
     ux = Ref.getUnique x
     uy = Ref.getUnique y
 
     makeWeakPointerThatRepresentsEdge =
         Ref.mkWeak y x Nothing
 
-    insertTheEdge we = atomicModifyIORef_ graphRef $
-        \GraphD{graph,references} -> GraphD
-            { graph
-                = Graph.insertEdge (ux,uy) we
-                $ graph
-            , references
-                = Map.insert ux (Ref.getWeakRef x)
-                . Map.insert uy (Ref.getWeakRef y)
-                $ references
-            }
+    insertTheEdge we = atomicModifyIORef' graphRef $
+        \GraphD{graph,references} ->
+            ( GraphD
+                { graph
+                    = Graph.insertEdge (ux,uy) we
+                    $ graph
+                , references
+                    = Map.insert ux (Ref.getWeakRef x)
+                    . Map.insert uy (Ref.getWeakRef y)
+                    $ references
+                }
+            ,   ( ux `Map.member` references
+                , uy `Map.member` references
+                ) 
+            )
 
 -- | Remove all the edges that connect the vertex to its predecessors.
 clearPredecessors :: Ref v -> GraphGC v -> IO ()
 clearPredecessors x GraphGC{graphRef} = do
-    g <- atomicModifyIORef graphRef $ \g -> (removeIncomingEdges g, g)
+    g <- atomicModifyIORef' graphRef $ \g -> (removeIncomingEdges g, g)
     finalizeIncomingEdges g
   where
     removeIncomingEdges g@GraphD{graph} =
@@ -189,7 +195,7 @@ removeGarbage g@GraphGC{deletions} = do
 -- I think it's fine because we have a single thread that performs deletions.
 deleteVertex :: GraphGC v -> Unique -> IO ()
 deleteVertex GraphGC{graphRef} x =
-    atomicModifyIORef_ graphRef $ \GraphD{graph,references} -> GraphD
+    atomicModifyIORef'_ graphRef $ \GraphD{graph,references} -> GraphD
         { graph = Graph.deleteVertex x graph
         , references = Map.delete x references
         }
@@ -213,5 +219,5 @@ printDot format GraphGC{graphRef} = do
     Helper functions
 ------------------------------------------------------------------------------}
 -- | Atomically modify an 'IORef' without returning a result.
-atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
-atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())
+atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO ()
+atomicModifyIORef'_ ref f = atomicModifyIORef' ref $ \x -> (f x, ())

reactive-banana/tests/Reactive/Banana/Test/High/Space.hs

@@ -3,9 +3,7 @@
     reactive-banana
 ------------------------------------------------------------------------------}
 -- | Exemplar tests for space usage and garbage collection.
-module Reactive.Banana.Test.High.Space
-    ( tests
-    ) where
+module Reactive.Banana.Test.High.Space where
 
 import Control.Monad
     ( forM )
@@ -51,9 +49,9 @@ observeAccumE1 e = pure $ observeE (accumE () never <$ e)
 -- | Execute an FRP network with a sequence of inputs
 -- with intermittend of garbage collection and record network sizes.
 runNetworkSizes
-    :: (Event Int -> MomentIO (Event ignore))
-    -> Int -> IO [Int]
-runNetworkSizes f n = do
+    :: (Event a -> MomentIO (Event ignore))
+    -> [a] -> IO [Int]
+runNetworkSizes f xs = do
     (network, fire) <- setup
     run network fire
   where
@@ -67,11 +65,11 @@ runNetworkSizes f n = do
         actuate network
         pure (network, fire)
 
-    run network fire = forM [1..n] $ \i -> do
+    run network fire = forM xs $ \i -> do
         fire i
         performSufficientGC
         System.yield
-        getSize network
+        Memory.evaluate =<< getSize network
 
 -- | Test whether the network size stays bounded.
 testBoundedNetworkSize
@@ -80,7 +78,7 @@ testBoundedNetworkSize
     -> TestTree
 testBoundedNetworkSize name f = testProperty name $
     Q.once $ Q.monadicIO $ do
-        sizes <- liftIO $ runNetworkSizes f n
+        sizes <- liftIO $ runNetworkSizes f [1..n]
         Q.monitor
             $ Q.counterexample "network size grows"
             . Q.counterexample ("network sizes: " <> show sizes)

reactive-banana/tests/Reactive/Banana/Test/Low/GraphGC.hs

@@ -77,7 +77,7 @@ prop_performGC =
             let rootRefs = map (vertices Map.!) roots
             Memory.evaluate $ Memory.rnf rootRefs
 
-            performSufficientGC
+            System.performMajorGC
             GraphGC.removeGarbage actual
             reachables <- traverse Ref.read =<<
                 GraphGC.listReachableVertices actual
@@ -98,7 +98,7 @@ prop_notPerformGC =
     $ \n -> Q.monadicIO $ liftIO $ do
         -- Trigger a garbage collection now so that it is
         -- highly unlikely to happen in the subsequent lines
-        performSufficientGC
+        System.performMinorGC
 
         let g = Q.mkLinearChain n
 
@@ -110,9 +110,6 @@ prop_notPerformGC =
         pure $
             Set.fromList reachables === Set.fromList [1..n]
 
-performSufficientGC :: IO ()
-performSufficientGC = System.performMinorGC
-
 {-----------------------------------------------------------------------------
     Test graphs
 ------------------------------------------------------------------------------}

reactive-banana/tests/Reactive/Banana/Test/Mid/Space.hs

@@ -2,10 +2,10 @@
     reactive-banana
 ------------------------------------------------------------------------------}
 -- | Exemplar tests for space usage and garbage collection.
-module Reactive.Banana.Test.Mid.Space
-    ( tests
-    ) where
+module Reactive.Banana.Test.Mid.Space where
 
+import Control.Monad
+    ( foldM )
 import Control.Monad.IO.Class
     ( liftIO )
 import Test.Tasty
@@ -48,23 +48,14 @@ executeAccum1 p1 = do
 {-----------------------------------------------------------------------------
     Test harness
 ------------------------------------------------------------------------------}
--- | Execute an FRP network with a sequence of inputs
--- with intermittend of garbage collection and record network sizes.
-runNetworkSizes
+-- | Compile an FRP network description into a state machine,
+-- which also performs garbage collection after every step.
+compileToStateMachine
     :: (Pulse a -> BuildIO (Pulse ignore))
-    -> [a] -> IO ([Int], Network)
-runNetworkSizes f xs = do
-    (step,network) <- Prim.compile build =<< Prim.emptyNetwork
-
-    let fire x network1 = do
-            (outputs, network2) <- step x network1
-            outputs -- don't forget to execute outputs
-            performSufficientGC
-            System.yield
-            size <- Prim.getSize network2
-            pure (size, network2)
-
-    Prim.mapAccumM fire network xs
+    -> IO (Network, a -> Network -> IO Network)
+compileToStateMachine f = do
+    (step,network0) <- Prim.compile build =<< Prim.emptyNetwork
+    pure (network0, doStep step)
   where
     build = do
         (p1, step) <- Prim.newInput
@@ -73,14 +64,34 @@ runNetworkSizes f xs = do
         Prim.addHandler p3 (\_ -> pure ())
         pure step
 
+    doStep step x network1 = do
+        (outputs, network2) <- step x network1
+        outputs         -- don't forget to execute outputs
+        performSufficientGC
+        System.yield    -- wait for finalizers to run
+        pure network2
+
+-- | Execute an FRP network with a sequence of inputs
+-- with intermittend of garbage collection and record network sizes.
+runNetworkSizes
+    :: (Pulse a -> BuildIO (Pulse ignore))
+    -> [a] -> IO [Int]
+runNetworkSizes f xs = do
+    (network0, step0) <- compileToStateMachine f
+    let step1 x network1 = do
+            network2 <- step0 x network1
+            size <- Memory.evaluate =<< Prim.getSize network2
+            pure (size, network2)
+    fst <$> Prim.mapAccumM step1 network0 xs
+
 -- | Test whether the network size stays bounded.
 testBoundedNetworkSize
     :: String
     -> (Pulse Int -> Build (Pulse ignore))
     -> TestTree
 testBoundedNetworkSize name f = testProperty name $
     Q.once $ Q.monadicIO $ do
-        (sizes,_) <- liftIO $ runNetworkSizes f [1..n]
+        sizes <- liftIO $ runNetworkSizes f [1..n]
         Q.monitor
             $ Q.counterexample "network size grows"
             . Q.counterexample ("network sizes: " <> show sizes)
@@ -97,8 +108,9 @@ performSufficientGC = System.performMinorGC
 ------------------------------------------------------------------------------}
 -- | Print network after a given sequence of inputs
 printNetwork
-    :: (Pulse Int -> BuildIO (Pulse ignore))
-    -> [Int] -> IO String
+    :: (Pulse a -> BuildIO (Pulse ignore))
+    -> [a] -> IO String
 printNetwork f xs = do
-    (_, network) <- runNetworkSizes executeAccum1 xs
-    Prim.printDot network
+    (network0, step) <- compileToStateMachine f
+    network1 <- foldM (flip step) network0 xs
+    Prim.printDot network1

reactive-banana/tests/space.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE BangPatterns #-}
+{-----------------------------------------------------------------------------
+    reactive-banana
+------------------------------------------------------------------------------}
+module Main where
+
+import Control.Monad
+  ( foldM, void )
+
+import qualified Reactive.Banana.Test.Mid.Space as Mid
+import qualified Reactive.Banana.Test.High.Space as High
+
+main :: IO ()
+main = do
+    say "Running..."
+    -- void $ High.runNetworkSizes High.executeAccumE1 [1..30000]
+    -- void $ High.runNetworkSizes High.observeAccumE1 [1..10000]
+    void $ runMidNetwork Mid.executeAccum1 [1..50000]
+    say "Done"
+
+say :: String -> IO ()
+say = putStrLn
+
+{-----------------------------------------------------------------------------
+    Test harness
+------------------------------------------------------------------------------}
+runMidNetwork f xs = do
+    (network0, step) <- Mid.compileToStateMachine f
+    void $ runStrict step xs network0
+
+runStrict :: Monad m => (a -> s -> m s) -> [a] -> s -> m s
+runStrict f [] !s = pure s
+runStrict f (x:xs) !s = runStrict f xs =<< f x s