diff options
| -rw-r--r-- | Assistant/Alert.hs | 10 | ||||
| -rw-r--r-- | Assistant/Alert/Utility.hs | 4 | ||||
| -rw-r--r-- | Assistant/DaemonStatus.hs | 19 | ||||
| -rw-r--r-- | Assistant/ScanRemotes.hs | 2 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 11 | ||||
| -rw-r--r-- | debian/changelog | 2 | ||||
| -rw-r--r-- | doc/bugs/import_memleak_from_the_assistant.mdwn | 10 | ||||
| -rw-r--r-- | doc/bugs/import_memleak_from_the_assistant/leakafter.png | bin | 0 -> 43348 bytes | |||
| -rw-r--r-- | doc/bugs/import_memleak_from_the_assistant/leakbefore.png | bin | 0 -> 24006 bytes |
9 files changed, 39 insertions, 19 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index c767d429d..055e66de5 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE OverloadedStrings, CPP, BangPatterns #-} module Assistant.Alert where @@ -367,8 +367,8 @@ fileAlert msg files = (activityAlert Nothing shortfiles) where maxfilesshown = 10 - (somefiles, counter) = splitcounter (dedupadjacent files) - shortfiles = map (fromString . shortFile . takeFileName) somefiles + (!somefiles, !counter) = splitcounter (dedupadjacent files) + !shortfiles = map (fromString . shortFile . takeFileName) somefiles renderer alert = tenseWords $ msg : alertData alert ++ showcounter where @@ -391,9 +391,9 @@ fileAlert msg files = (activityAlert Nothing shortfiles) in (keep, length rest) combiner new old = - let (fs, n) = splitcounter $ + let (!fs, n) = splitcounter $ dedupadjacent $ alertData new ++ alertData old - cnt = n + alertCounter new + alertCounter old + !cnt = n + alertCounter new + alertCounter old in old { alertData = fs , alertCounter = cnt diff --git a/Assistant/Alert/Utility.hs b/Assistant/Alert/Utility.hs index db2ea1925..960c3385b 100644 --- a/Assistant/Alert/Utility.hs +++ b/Assistant/Alert/Utility.hs @@ -13,7 +13,7 @@ import Utility.Tense import qualified Data.Text as T import Data.Text (Text) -import qualified Data.Map as M +import qualified Data.Map.Strict as M {- This is as many alerts as it makes sense to display at a time. - A display might be smaller, or larger, the point is to not overwhelm the @@ -122,7 +122,7 @@ mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al) let (f, rest) = partition (\(_, a) -> isFiller a) l in drop bloat f ++ rest updatePrune = pruneBloat $ M.filterWithKey pruneSame $ - M.insertWith' const i al m + M.insert i al m updateCombine combiner = let combined = M.mapMaybe (combiner al) m in if M.null combined diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 7268bbbfb..ed73c210a 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Assistant.DaemonStatus where import Assistant.Common @@ -23,7 +25,7 @@ import System.Posix.Types import Data.Time.Clock.POSIX import Data.Time import System.Locale -import qualified Data.Map as M +import qualified Data.Map.Strict as M import qualified Data.Text as T getDaemonStatus :: Assistant DaemonStatus @@ -37,7 +39,7 @@ modifyDaemonStatus a = do dstatus <- getAssistant daemonStatusHandle liftIO $ do (s, b) <- atomically $ do - r@(s, _) <- a <$> takeTMVar dstatus + r@(!s, _) <- a <$> takeTMVar dstatus putTMVar dstatus s return r sendNotification $ changeNotifier s @@ -153,7 +155,8 @@ tenMinutes = 10 * 60 adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM () adjustTransfersSTM dstatus a = do s <- takeTMVar dstatus - putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) } + let !v = a (currentTransfers s) + putTMVar dstatus $ s { currentTransfers = v } {- Checks if a transfer is currently running. -} checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool @@ -168,7 +171,7 @@ alterTransferInfo t a = updateTransferInfo' $ M.adjust a t - or if already present, updates it while preserving the old transferTid, - transferPaused, and bytesComplete values, which are not written to disk. -} updateTransferInfo :: Transfer -> TransferInfo -> Assistant () -updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info +updateTransferInfo t info = updateTransferInfo' $ M.insertWith merge t info where merge new old = new { transferTid = maybe (transferTid new) Just (transferTid old) @@ -213,8 +216,8 @@ addAlert alert = do where add s = (s { lastAlertId = i, alertMap = m }, i) where - i = nextAlertId $ lastAlertId s - m = mergeAlert i alert (alertMap s) + !i = nextAlertId $ lastAlertId s + !m = mergeAlert i alert (alertMap s) removeAlert :: AlertId -> Assistant () removeAlert i = updateAlert i (const Nothing) @@ -225,7 +228,9 @@ updateAlert i a = updateAlertMap $ \m -> M.update a i m updateAlertMap :: (AlertMap -> AlertMap) -> Assistant () updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update where - update s = s { alertMap = a (alertMap s) } + update s = + let !m = a (alertMap s) + in s { alertMap = a (alertMap s) } {- Displays an alert while performing an activity that returns True on - success. diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs index 2743c0f36..79df2e123 100644 --- a/Assistant/ScanRemotes.hs +++ b/Assistant/ScanRemotes.hs @@ -13,7 +13,7 @@ import qualified Types.Remote as Remote import Data.Function import Control.Concurrent.STM -import qualified Data.Map as M +import qualified Data.Map.Strict as M {- Blocks until there is a remote or remotes that need to be scanned. - diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index f94e73c2b..05b0ba73a 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Assistant.TransferQueue ( TransferQueue, Schedule(..), @@ -32,7 +34,7 @@ import Annex.Wanted import Utility.TList import Control.Concurrent.STM -import qualified Data.Map as M +import qualified Data.Map.Strict as M import qualified Data.Set as S type Reason = String @@ -189,7 +191,7 @@ getNextTransfer acceptable = do if acceptable info then do adjustTransfersSTM dstatus $ - M.insertWith' const t info + M.insert t info return $ Just r else return Nothing @@ -217,7 +219,8 @@ dequeueTransfers c = do dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] dequeueTransfersSTM q c = do - (removed, ts) <- partition (c . fst) <$> readTList (queuelist q) - void $ writeTVar (queuesize q) (length ts) + !(removed, ts) <- partition (c . fst) <$> readTList (queuelist q) + let !len = length ts + void $ writeTVar (queuesize q) len setTList (queuelist q) ts return removed diff --git a/debian/changelog b/debian/changelog index 0a2a45df4..a7339fded 100644 --- a/debian/changelog +++ b/debian/changelog @@ -18,6 +18,8 @@ git-annex (5.20131231) UNRELEASED; urgency=medium * addurl, importfeed: Honor annex.diskreserve as long as the size of the url can be checked. * add: Fix rollback when disk is completely full. + * assistant: Fixed several minor memory leaks that manifested when + adding a large number of files. -- Joey Hess <joeyh@debian.org> Tue, 31 Dec 2013 13:41:18 -0400 diff --git a/doc/bugs/import_memleak_from_the_assistant.mdwn b/doc/bugs/import_memleak_from_the_assistant.mdwn index 541d1707d..5a0a0225b 100644 --- a/doc/bugs/import_memleak_from_the_assistant.mdwn +++ b/doc/bugs/import_memleak_from_the_assistant.mdwn @@ -1596,3 +1596,13 @@ rsync error: error in rsync protocol data stream (code 12) at io.c(605) [sender= # End of transcript or log. """]] + +> [[Fixed|done]]. This was several garden-variety haskell laziness leaks, +> all fixed by adding strictness annotations. +> +> Before: [[leakbefore.png]] +> After: [[leakafter.png]] +> +> Looks like I got them all, and it returns to running in constant space +> after adding and uploading the files (which can take memory porportional +> to the number of files that were added/changed at once). --[[Joey]] diff --git a/doc/bugs/import_memleak_from_the_assistant/leakafter.png b/doc/bugs/import_memleak_from_the_assistant/leakafter.png Binary files differnew file mode 100644 index 000000000..32c27f370 --- /dev/null +++ b/doc/bugs/import_memleak_from_the_assistant/leakafter.png diff --git a/doc/bugs/import_memleak_from_the_assistant/leakbefore.png b/doc/bugs/import_memleak_from_the_assistant/leakbefore.png Binary files differnew file mode 100644 index 000000000..9a04bfb20 --- /dev/null +++ b/doc/bugs/import_memleak_from_the_assistant/leakbefore.png |
