summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-01-29 22:55:06 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-01-29 22:55:06 -0400
commita964012fc36d22e4554dd12e3594579fb3190501 (patch)
tree31c3a5ea4fb78088b4981eb4185737353ec1ff3e
parent0609e102396083afa6380f8b67a69fa849235d16 (diff)
switch to the strict state monad
I had not realized what a memory leak the lazy state monad could be, although I have not seen much evidence of actual leaking in git-annex. However, if running git-annex on a great many files, this could matter. The additional Utility.State.changeState adds even more strictness, avoiding a problem I saw in github-backup where repeatedly modifying state built up a huge pile of thunks.
-rw-r--r--Annex.hs15
-rw-r--r--Command/Status.hs2
-rw-r--r--Common.hs2
-rw-r--r--Git/CatFile.hs1
-rw-r--r--Utility/State.hs26
5 files changed, 30 insertions, 16 deletions
diff --git a/Annex.hs b/Annex.hs
index 3b79ea270..de36c816d 100644
--- a/Annex.hs
+++ b/Annex.hs
@@ -26,7 +26,7 @@ module Annex (
fromRepo,
) where
-import Control.Monad.State
+import Control.Monad.State.Strict
import Control.Monad.Trans.Control (StM, MonadBaseControl, liftBaseWith, restoreM)
import Control.Monad.Base (liftBase, MonadBase)
import System.Posix.Types (Fd)
@@ -41,6 +41,7 @@ import qualified Types.Remote
import Types.Crypto
import Types.BranchState
import Types.TrustLevel
+import Utility.State
import qualified Utility.Matcher
import qualified Data.Map as M
@@ -125,18 +126,6 @@ run s a = runStateT (runAnnex a) s
eval :: AnnexState -> Annex a -> IO a
eval s a = evalStateT (runAnnex a) s
-{- Gets a value from the internal state, selected by the passed value
- - constructor. -}
-getState :: (AnnexState -> a) -> Annex a
-getState = gets
-
-{- Applies a state mutation function to change the internal state.
- -
- - Example: changeState $ \s -> s { output = QuietOutput }
- -}
-changeState :: (AnnexState -> AnnexState) -> Annex ()
-changeState = modify
-
{- Sets a flag to True -}
setFlag :: String -> Annex ()
setFlag flag = changeState $ \s ->
diff --git a/Command/Status.hs b/Command/Status.hs
index d2d8d4c07..a1d4eea08 100644
--- a/Command/Status.hs
+++ b/Command/Status.hs
@@ -7,7 +7,7 @@
module Command.Status where
-import Control.Monad.State
+import Control.Monad.State.Strict
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Set (Set)
diff --git a/Common.hs b/Common.hs
index 385d1aba4..fb998214b 100644
--- a/Common.hs
+++ b/Common.hs
@@ -3,7 +3,7 @@ module Common (module X) where
import Control.Monad as X hiding (join)
import Control.Monad.IfElse as X
import Control.Applicative as X
-import Control.Monad.State as X (liftIO)
+import Control.Monad.State.Strict as X (liftIO)
import Control.Exception.Extensible as X (IOException)
import Data.Maybe as X
diff --git a/Git/CatFile.hs b/Git/CatFile.hs
index 16f0b11b9..2a2eb5e6f 100644
--- a/Git/CatFile.hs
+++ b/Git/CatFile.hs
@@ -13,7 +13,6 @@ module Git.CatFile (
catObject
) where
-import Control.Monad.State
import System.Cmd.Utils
import System.IO
import qualified Data.ByteString.Char8 as S
diff --git a/Utility/State.hs b/Utility/State.hs
new file mode 100644
index 000000000..c27f3c261
--- /dev/null
+++ b/Utility/State.hs
@@ -0,0 +1,26 @@
+{- state monad support
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.State where
+
+import Control.Monad.State.Strict
+
+{- Modifies Control.Monad.State's state, forcing a strict update.
+ - This avoids building thunks in the state and leaking.
+ - Why it's not the default, I don't know.
+ -
+ - Example: changeState $ \s -> s { foo = bar }
+ -}
+changeState :: MonadState s m => (s -> s) -> m ()
+changeState f = do
+ x <- get
+ put $! f x
+
+{- Gets a value from the internal state, selected by the passed value
+ - constructor. -}
+getState :: MonadState s m => (s -> a) -> m a
+getState = gets