assistant: Fixed several minor memory leaks that manifested when adding a large number of files.

5 files changed, 27 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