git.iko.soy/distributed-process
on master help sign in
Make sure handleIncomingMessages uses strict state

This fixes another memory leak

commit068711ac8c667faad48dd0253ab16d3c9626745d authorEdsko de Vries <edsko@edsko.net> dateWed 15 Aug 2012, 16:27 (14 years ago) parent17ad36a
1 file changed+18−18
distributed-process/src/Control/Distributed/Process/Node.hs+18−18
distributed-process/src/Control/Distributed/Process/Node.hs+18−18
@@ -26,9 +26,8 @@ import qualified Data.Map as Map
2626 , partitionWithKey
2727 , filterWithKey
2828 )
29−import qualified Data.List as List (delete, (\\))
3029import Data.Set (Set)
31−import qualified Data.Set as Set (empty, insert, delete, member, (\\), fromList)
30+import qualified Data.Set as Set (empty, insert, delete, member, filter)
3231import Data.Foldable (forM_)
3332import Data.Maybe (isJust)
3433import Data.Typeable (Typeable)
@@ -238,25 +237,25 @@ forkProcess node proc = modifyMVar (localState node) $ \st -> do
238237 )
239238
240239handleIncomingMessages :: LocalNode -> IO ()
241−handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
240+handleIncomingMessages node = go Set.empty Map.empty Map.empty Set.empty
242241 where
243− go :: [NT.ConnectionId] -- ^ Connections whose purpose we don't yet know
242+ go :: Set NT.ConnectionId -- ^ Connections whose purpose we don't yet know
244243 -> Map NT.ConnectionId LocalProcess -- ^ Connections to local processes
245244 -> Map NT.ConnectionId TypedChannel -- ^ Connections to typed channels
246245 -> Set NT.ConnectionId -- ^ Connections to our controller
247246 -> IO ()
248− go uninitConns procs chans ctrls = do
247+ go !uninitConns !procs !chans !ctrls = do
249248 event <- NT.receive endpoint
250249 case event of
251250 NT.ConnectionOpened cid _rel _theirAddr ->
252251 -- TODO: Check if _rel is ReliableOrdered, and if not, treat as
253252 -- (**) below.
254− go (cid : uninitConns) procs chans ctrls
253+ go (Set.insert cid uninitConns) procs chans ctrls
255254 NT.Received cid payload ->
256255 case ( Map.lookup cid procs
257256 , Map.lookup cid chans
258257 , cid `Set.member` ctrls
259− , cid `elem` uninitConns
258+ , cid `Set.member` uninitConns
260259 ) of
261260 (Just proc, _, _, _) -> do
262261 let msg = payloadToMessage payload
@@ -276,7 +275,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
276275 mProc <- withMVar state $ return . (^. localProcessWithId lpid)
277276 case mProc of
278277 Just proc ->
279− go (List.delete cid uninitConns)
278+ go (Set.delete cid uninitConns)
280279 (Map.insert cid proc procs)
281280 chans
282281 ctrls
@@ -288,7 +287,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
288287 -- remote node as having died, and we should close
289288 -- incoming connections (this requires a Transport layer
290289 -- extension). (**)
291− go (List.delete cid uninitConns) procs chans ctrls
290+ go (Set.delete cid uninitConns) procs chans ctrls
292291 SendPortIdentifier chId -> do
293292 let lcid = sendPortLocalId chId
294293 lpid = processLocalId (sendPortProcessId chId)
@@ -298,20 +297,20 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
298297 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)
299298 case mChannel of
300299 Just channel ->
301− go (List.delete cid uninitConns)
300+ go (Set.delete cid uninitConns)
302301 procs
303302 (Map.insert cid channel chans)
304303 ctrls
305304 Nothing ->
306305 -- Unknown typed channel
307306 -- TODO (**) above
308− go (List.delete cid uninitConns) procs chans ctrls
307+ go (Set.delete cid uninitConns) procs chans ctrls
309308 Nothing ->
310309 -- Unknown process
311310 -- TODO (**) above
312− go (List.delete cid uninitConns) procs chans ctrls
311+ go (Set.delete cid uninitConns) procs chans ctrls
313312 NodeIdentifier _ ->
314− go (List.delete cid uninitConns)
313+ go (Set.delete cid uninitConns)
315314 procs
316315 chans
317316 (Set.insert cid ctrls)
@@ -320,7 +319,7 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
320319 -- TODO (**) above
321320 go uninitConns procs chans ctrls
322321 NT.ConnectionClosed cid ->
323− go (List.delete cid uninitConns)
322+ go (Set.delete cid uninitConns)
324323 (Map.delete cid procs)
325324 (Map.delete cid chans)
326325 (Set.delete cid ctrls)
@@ -331,10 +330,11 @@ handleIncomingMessages node = go [] Map.empty Map.empty Set.empty
331330 { ctrlMsgSender = nid
332331 , ctrlMsgSignal = Died nid DiedDisconnect
333332 }
334− go (uninitConns List.\\ cids)
335− (Map.filterWithKey (\k _ -> k `notElem` cids) procs)
336− (Map.filterWithKey (\k _ -> k `notElem` cids) chans)
337− (ctrls Set.\\ Set.fromList cids)
333+ let notRemoved k = k `notElem` cids
334+ go (Set.filter notRemoved uninitConns)
335+ (Map.filterWithKey (const . notRemoved) procs)
336+ (Map.filterWithKey (const . notRemoved) chans)
337+ (Set.filter notRemoved ctrls)
338338 NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost Nothing _) _) ->
339339 -- TODO: We should treat an asymetrical connection loss (incoming
340340 -- connection broken, but outgoing connection still potentially ok)