@@ -183,7 +183,186 @@ unsafeNodeId a = unsafePerformIO $ do
183183 newNodeId
184184#endif
185185
186−--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
186+--------------------------------------------------------------------------------
187+-- Event
188+--------------------------------------------------------------------------------
189+
190+data Event a
191+ = forall k. GCompare k => EventRoot !(k a) !(Root k)
192+ | EventNever
193+ | forall b. EventPush !(Push b a)
194+ | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
195+ | forall k. GCompare k => EventFan !(k a) !(Fan k)
196+ | EventSwitch !(Switch a)
197+ | EventCoincidence !(Coincidence a)
198+ | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
199+ | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
200+ | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
201+ | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
202+
203+{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
204+subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
205+subscribe e sub = case e of
206+ EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
207+ EventNever -> return $ EventSubscription Nothing EventSubscribedNever
208+ EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
209+ EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
210+ EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
211+ EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
212+ EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
213+ EventHold h -> subscribeHoldEvent h sub
214+ EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
215+ EventHoldIdentity h -> subscribeHoldEvent h sub
216+ EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
217+ where
218+ wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
219+ wrap tag getSpecificSubscribed = do
220+ (sln, subd) <- getSpecificSubscribed sub
221+ return $ EventSubscription (Just sln) $ tag subd
222+
223+{-# INLINE subscribeCoincidenceInner #-}
224+subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
225+subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
226+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
227+ subscription@(EventSubscription _ innerSubd) <- subscribe o subInner
228+ innerOcc <- liftIO $ readEventSubscribed innerSubd
229+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
230+ let height = max innerHeight outerHeight
231+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
232+ return (innerOcc, height, innerSubd)
233+
234+--------------------------------------------------------------------------------
235+-- EventSubscribed
236+--------------------------------------------------------------------------------
237+
238+data EventSubscribed a
239+ = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
240+ | EventSubscribedNever
241+ | forall b. EventSubscribedPush !(PushSubscribed b a)
242+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
243+ | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
244+ | EventSubscribedSwitch !(SwitchSubscribed a)
245+ | EventSubscribedCoincidence !(CoincidenceSubscribed a)
246+
247+readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
248+readEventSubscribed = \case
249+ EventSubscribedRoot rs -> readRootSubscribed rs
250+ EventSubscribedNever -> return Nothing
251+ EventSubscribedPush ps -> readPushSubscribed ps
252+ EventSubscribedMerge ms -> readMergeSubscribed ms
253+ EventSubscribedFan k fs -> readFanSubscribed k fs
254+ EventSubscribedSwitch ss -> readSwitchSubscribed ss
255+ EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
256+
257+{-# INLINE subscribeEventSubscribed #-}
258+subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
259+subscribeEventSubscribed es sub = case es of
260+ EventSubscribedRoot r -> do
261+ traceSubscribe $ "subscribeEventSubscribed Root"
262+ Just <$> subscribeRootSubscribed r sub
263+ EventSubscribedNever -> do
264+ traceSubscribe $ "subscribeEventSubscribed Never"
265+ return Nothing
266+ EventSubscribedPush subscribed -> do
267+ traceSubscribe $ "subscribeEventSubscribed Push"
268+ Just <$> subscribePushSubscribed subscribed sub
269+ EventSubscribedFan k subscribed -> do
270+ traceSubscribe $ "subscribeEventSubscribed Fan"
271+ Just <$> subscribeFanSubscribed k subscribed sub
272+ EventSubscribedMerge subscribed -> do
273+ traceSubscribe $ "subscribeEventSubscribed Merge"
274+ Just <$> subscribeMergeSubscribed subscribed sub
275+ EventSubscribedSwitch subscribed -> do
276+ traceSubscribe $ "subscribeEventSubscribed Switch"
277+ Just <$> subscribeSwitchSubscribed subscribed sub
278+ EventSubscribedCoincidence subscribed -> do
279+ traceSubscribe $ "subscribeEventSubscribed Coincidence"
280+ Just <$> subscribeCoincidenceSubscribed subscribed sub
281+
282+{-# INLINE eventSubscribedGetParents #-}
283+eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
284+eventSubscribedGetParents = \case
285+ EventSubscribedRoot _ -> return []
286+ EventSubscribedNever -> return []
287+ EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
288+ EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
289+ EventSubscribedMerge subscribed -> do
290+ ps <- readIORef $ mergeSubscribedParents subscribed
291+ return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
292+ EventSubscribedSwitch subscribed -> do
293+ s <- readIORef $ switchSubscribedCurrentParent subscribed
294+ return [Some.This $ _eventSubscription_subscribed s]
295+ EventSubscribedCoincidence subscribed -> do
296+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
297+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
298+ innerParents = maybeToList $ fmap Some.This innerSubscription
299+ return $ outerParent : innerParents
300+
301+getEventSubscribedHeight :: EventSubscribed a -> IO Height
302+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
303+
304+{-# INLINE eventSubscribedHeightRef #-}
305+eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
306+eventSubscribedHeightRef = \case
307+ EventSubscribedRoot _ -> zeroRef
308+ EventSubscribedNever -> zeroRef
309+ EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
310+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
311+ EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
312+ EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
313+ EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
314+
315+whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
316+whoCreatedEventSubscribed = \case
317+ EventSubscribedRoot _ -> return ["root"]
318+ EventSubscribedNever -> return ["never"]
319+ EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
320+ EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
321+ EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
322+ EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
323+ EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
324+
325+{-# INLINE eventSubscribedHasOwnHeightRef #-}
326+eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
327+eventSubscribedHasOwnHeightRef = \case
328+ EventSubscribedRoot _ -> False
329+ EventSubscribedNever -> False
330+ EventSubscribedPush _ -> False
331+ EventSubscribedFan _ _ -> False
332+ EventSubscribedMerge _ -> True
333+ EventSubscribedSwitch _ -> True
334+ EventSubscribedCoincidence _ -> True
335+
336+walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
337+walkInvalidHeightParents s0 = do
338+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
339+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
340+ when (h == invalidHeight) $ do
341+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
342+ modify (Some.This s :)
343+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
344+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
345+ return subscribers
346+
347+--------------------------------------------------------------------------------
348+-- EventSubscription
349+--------------------------------------------------------------------------------
350+
351+data EventSubscription a = EventSubscription
352+ { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
353+ , _eventSubscription_subscribed :: !(EventSubscribed a)
354+ }
355+
356+unsubscribe :: EventSubscription a -> IO ()
357+unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
358+
359+--------------------------------------------------------------------------------
360+-- Combinators
361+--------------------------------------------------------------------------------
362+
363+--TODO: Figure out why certain things are not 'representational', then make them
364+--representational so we can use coerce
365+
187366--type role Hold representational
188367data Hold p a
189368 = Hold { holdValue :: !(IORef a)
@@ -579,36 +758,6 @@ data Subscriber a
579758 | SubscriberCoincidenceInner (CoincidenceSubscribed a)
580759 | SubscriberHandle
581760
582−data Event a
583− = forall k. GCompare k => EventRoot !(k a) !(Root k)
584− | EventNever
585− | forall b. EventPush !(Push b a)
586− | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)
587− | forall k. GCompare k => EventFan !(k a) !(Fan k)
588− | EventSwitch !(Switch a)
589− | EventCoincidence !(Coincidence a)
590− | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
591− | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
592− | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
593− | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
594−
595−data EventSubscription a = EventSubscription
596− { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
597− , _eventSubscription_subscribed :: !(EventSubscribed a)
598− }
599−
600−data EventSubscribed a
601− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
602− | EventSubscribedNever
603− | forall b. EventSubscribedPush !(PushSubscribed b a)
604− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)
605− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)
606− | EventSubscribedSwitch !(SwitchSubscribed a)
607− | EventSubscribedCoincidence !(CoincidenceSubscribed a)
608−
609−unsubscribe :: EventSubscription a -> IO ()
610−unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
611−
612761-- These function are constructor functions that are marked NOINLINE so they are
613762-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
614763-- so any weak references that are attached to the constructors will have their
@@ -924,27 +1073,6 @@ traceMWhen b getMessage = when b $ do
9241073whoCreatedIORef :: IORef a -> IO [String]
9251074whoCreatedIORef (IORef a) = whoCreated $! a
9261075
927−whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
928−whoCreatedEventSubscribed = \case
929− EventSubscribedRoot _ -> return ["root"]
930− EventSubscribedNever -> return ["never"]
931− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
932− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
933− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
934− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
935− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
936−
937−walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
938−walkInvalidHeightParents s0 = do
939− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
940− h <- liftIO $ readIORef $ eventSubscribedHeightRef s
941− when (h == invalidHeight) $ do
942− when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
943− modify (Some.This s :)
944− mapM_ loop =<< liftIO (eventSubscribedGetParents s)
945− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
946− return subscribers
947−
9481076groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
9491077groupByHead = \case
9501078 [] -> []
@@ -1059,17 +1187,6 @@ propagateSubscriberHold h a = do
10591187
10601188data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
10611189
1062−{-# INLINE subscribeCoincidenceInner #-}
1063−subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
1064−subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
1065− subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
1066− subscription@(EventSubscription _ innerSubd) <- subscribe o subInner
1067− innerOcc <- liftIO $ readEventSubscribed innerSubd
1068− innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
1069− let height = max innerHeight outerHeight
1070− defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
1071− return (innerOcc, height, innerSubd)
1072−
10731190{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
10741191{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
10751192readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
@@ -1153,16 +1270,6 @@ getDynHold d = do
11531270 liftIO $ writeIORef (unDyn d) $ Right h
11541271 return h
11551272
1156−readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
1157−readEventSubscribed = \case
1158− EventSubscribedRoot rs -> readRootSubscribed rs
1159− EventSubscribedNever -> return Nothing
1160− EventSubscribedPush ps -> readPushSubscribed ps
1161− EventSubscribedMerge ms -> readMergeSubscribed ms
1162− EventSubscribedFan k fs -> readFanSubscribed k fs
1163− EventSubscribedSwitch ss -> readSwitchSubscribed ss
1164− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
1165−
11661273readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
11671274readRootSubscribed = rootSubscribedOccurrence
11681275
@@ -1201,26 +1308,6 @@ readCoincidenceSubscribed subscribed = do
12011308zeroRef :: IORef Height
12021309zeroRef = unsafePerformIO $ newIORef zeroHeight
12031310
1204−{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
1205−subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1206−subscribe e sub = case e of
1207− EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
1208− EventNever -> return $ EventSubscription Nothing EventSubscribedNever
1209− EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
1210− EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
1211− EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
1212− EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
1213− EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
1214− EventHold h -> subscribeHoldEvent h sub
1215− EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1216− EventHoldIdentity h -> subscribeHoldEvent h sub
1217− EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1218− where
1219− wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
1220− wrap tag getSpecificSubscribed = do
1221− (sln, subd) <- getSpecificSubscribed sub
1222− return $ EventSubscription (Just sln) $ tag subd
1223−
12241311{-# INLINE subscribeHoldEvent #-}
12251312subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
12261313subscribeHoldEvent h sub = do
@@ -1232,71 +1319,6 @@ subscribeHoldEvent h sub = do
12321319debugSubscribe :: Bool
12331320debugSubscribe = False
12341321
1235−{-# INLINE subscribeEventSubscribed #-}
1236−subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
1237−subscribeEventSubscribed es sub = case es of
1238− EventSubscribedRoot r -> do
1239− traceSubscribe $ "subscribeEventSubscribed Root"
1240− Just <$> subscribeRootSubscribed r sub
1241− EventSubscribedNever -> do
1242− traceSubscribe $ "subscribeEventSubscribed Never"
1243− return Nothing
1244− EventSubscribedPush subscribed -> do
1245− traceSubscribe $ "subscribeEventSubscribed Push"
1246− Just <$> subscribePushSubscribed subscribed sub
1247− EventSubscribedFan k subscribed -> do
1248− traceSubscribe $ "subscribeEventSubscribed Fan"
1249− Just <$> subscribeFanSubscribed k subscribed sub
1250− EventSubscribedMerge subscribed -> do
1251− traceSubscribe $ "subscribeEventSubscribed Merge"
1252− Just <$> subscribeMergeSubscribed subscribed sub
1253− EventSubscribedSwitch subscribed -> do
1254− traceSubscribe $ "subscribeEventSubscribed Switch"
1255− Just <$> subscribeSwitchSubscribed subscribed sub
1256− EventSubscribedCoincidence subscribed -> do
1257− traceSubscribe $ "subscribeEventSubscribed Coincidence"
1258− Just <$> subscribeCoincidenceSubscribed subscribed sub
1259−
1260−{-# INLINE eventSubscribedHeightRef #-}
1261−eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
1262−eventSubscribedHeightRef = \case
1263− EventSubscribedRoot _ -> zeroRef
1264− EventSubscribedNever -> zeroRef
1265− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
1266− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
1267− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
1268− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
1269− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
1270−
1271−{-# INLINE eventSubscribedHasOwnHeightRef #-}
1272−eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
1273−eventSubscribedHasOwnHeightRef = \case
1274− EventSubscribedRoot _ -> False
1275− EventSubscribedNever -> False
1276− EventSubscribedPush _ -> False
1277− EventSubscribedFan _ _ -> False
1278− EventSubscribedMerge _ -> True
1279− EventSubscribedSwitch _ -> True
1280− EventSubscribedCoincidence _ -> True
1281−
1282−{-# INLINE eventSubscribedGetParents #-}
1283−eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
1284−eventSubscribedGetParents = \case
1285− EventSubscribedRoot _ -> return []
1286− EventSubscribedNever -> return []
1287− EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
1288− EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
1289− EventSubscribedMerge subscribed -> do
1290− ps <- readIORef $ mergeSubscribedParents subscribed
1291− return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
1292− EventSubscribedSwitch subscribed -> do
1293− s <- readIORef $ switchSubscribedCurrentParent subscribed
1294− return [Some.This $ _eventSubscription_subscribed s]
1295− EventSubscribedCoincidence subscribed -> do
1296− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1297− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1298− innerParents = maybeToList $ fmap Some.This innerSubscription
1299− return $ outerParent : innerParents
13001322
13011323type CanSubscribe x m =
13021324 ( HasSpiderEnv x m
@@ -1406,12 +1428,12 @@ getMergeSubscribed m sub = do
14061428 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
14071429 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
14081430 initialParents <- readBehaviorUntracked $ current $ mergeParents m
1409− subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1410− s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1411− subscription@(EventSubscription _ parentSubd) <- subscribe e s
1412− parentOcc <- liftIO $ readEventSubscribed parentSubd
1413− height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
1414− return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)
1431+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> do
1432+ s <- {-# SCC "getMergeSubscribed.a.1" #-} liftIO $ newSubscriberMerge k subscribedUnsafe
1433+ subscription@(EventSubscription _ parentSubd) <- {-# SCC "getMergeSubscribed.a.2" #-} subscribe e s
1434+ parentOcc <- {-# SCC "getMergeSubscribed.a.3" #-} liftIO $ readEventSubscribed parentSubd
1435+ height <- {-# SCC "getMergeSubscribed.a.4" #-} liftIO $ getEventSubscribedHeight parentSubd
1436+ {-# SCC "getMergeSubscribed.a.5" #-} return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription s)
14151437 let dm = DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
14161438 heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
14171439 myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
@@ -1542,7 +1564,7 @@ getSwitchSubscribed s sub = do
15421564 parentOcc <- liftIO $ readEventSubscribed subd
15431565 occRef <- liftIO $ newIORef parentOcc
15441566 when (isJust parentOcc) $ scheduleClear occRef
1545− heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
1567+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
15461568 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
15471569 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
15481570 let !subscribed = SwitchSubscribed
@@ -1589,7 +1611,7 @@ getCoincidenceSubscribed c sub = do
15891611 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
15901612 outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
15911613 outerOcc <- liftIO $ readEventSubscribed outerSubd
1592− outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
1614+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
15931615 (occ, height, mInnerSubd) <- case outerOcc of
15941616 Nothing -> return (Nothing, outerHeight, Nothing)
15951617 Just o -> do
@@ -1716,7 +1738,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17161738 liftIO $ addMergeHeight newParentHeight m
17171739 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
17181740 forM_ mOldSubd $ \oldSubd -> do
1719− oldHeight <- liftIO $ readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1741+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
17201742 liftIO $ removeMergeHeight oldHeight m
17211743 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
17221744 (subscriptionsToKill, newParents) <- flip runEventM env $ foldM f ([], oldParents) $ DMap.toList p --TODO: I think this runEventM is OK, since no events are firing at this time, but it might not be
@@ -1754,7 +1776,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17541776 forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
17551777 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
17561778 EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
1757− parentHeight <- readIORef $ eventSubscribedHeightRef subd'
1779+ parentHeight <- getEventSubscribedHeight subd'
17581780 myHeight <- readIORef $ switchSubscribedHeight subscribed
17591781 when (parentHeight /= myHeight) $ do
17601782 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
@@ -1924,16 +1946,13 @@ recalculateCoincidenceHeight subscribed = do
19241946 writeIORef (coincidenceSubscribedHeight subscribed) $! height
19251947 WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
19261948
1927−getEventSubscribedHeight :: EventSubscribed a -> IO Height
1928−getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
1929−
19301949calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1931−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
1950+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
19321951
19331952calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
19341953calculateCoincidenceHeight subscribed = do
1935− outerHeight <- readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1936− innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1954+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
1955+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
19371956 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
19381957
19391958data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)