@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators, FlexibleContexts, ConstraintKinds, MagicHash, UnboxedTuples, FunctionalDependencies #-}
1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators, FlexibleContexts, ConstraintKinds, MagicHash, UnboxedTuples, FunctionalDependencies, MultiWayIf #-}
22module Reflex.Spider.Internal (Spider, SpiderEnv (..), Global, SpiderHost, runSpiderHost, SpiderEventHandle (..), showSubscriberType, showEventType, ComputeM (..), MergeSubscribedParent (..), HasSpiderEnv (..), newSpiderEnv, SpiderPullM (..), SpiderPushM (..), ReadPhase (..)) where
33
44import qualified Reflex.Class as R
@@ -22,8 +22,8 @@ import Data.Dependent.Map (DMap, DSum (..))
2222import qualified Data.Dependent.Map as DMap
2323import Data.GADT.Compare
2424import Data.Maybe
25−import Data.IntMap (IntMap)
26−import qualified Data.IntMap as IntMap
25+import Data.IntMap.Strict (IntMap)
26+import qualified Data.IntMap.Strict as IntMap
2727import Control.Monad.Ref
2828import Control.Monad.Exception
2929import Data.Monoid ((<>))
@@ -287,7 +287,7 @@ getHoldEventSubscription h = do
287287 2) Have a finalizer on every SubscriberListNode that only runs if its parent is still alive, and does a normal unsubscribe if so; this would seem to double the number of weakRefs we use, but perhaps not the weakDepth, so maybe it's OK; we will probably need to move the regular call to unsubscribe into the finalizer and then use finalize instead of that call; we can have a strong reference to the SubscriberListNode, which means we just need a single weak reference to each EventSubscribed, which we can reuse in all of the finalizers that need to (potentially) unsubscribe from it
288288-}
289289 -}
290− subscription@(_, subd) <- subscribe e =<< liftIO (newSubscriberHold h)
290+ subscription@(EventSubscription _ subd) <- subscribe e =<< liftIO (newSubscriberHold h)
291291 liftIO $ writeIORef subscriptionRef subscription
292292 occ <- liftIO $ readEventSubscribed subd
293293 case occ of
@@ -409,11 +409,54 @@ data MergeSubscribedParent k a
409409 , mergeSubscribedParentSubscriber :: !(Subscriber a)
410410 }
411411
412+data HeightBag = HeightBag
413+ { _heightBag_size :: {-# UNPACK #-} !Int
414+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
415+ }
416+ deriving (Show, Read, Eq, Ord)
417+
418+heightBagEmpty :: HeightBag
419+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
420+
421+heightBagSize :: HeightBag -> Int
422+heightBagSize = _heightBag_size
423+
424+heightBagFromList :: [Height] -> HeightBag
425+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
426+
427+heightBagAdd :: Height -> HeightBag -> HeightBag
428+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
429+
430+heightBagRemove :: Height -> HeightBag -> HeightBag
431+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
432+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
433+ Just old -> HeightBag (pred s) $ case old of
434+ 0 -> IntMap.delete h c
435+ _ -> IntMap.insert h (pred old) c
436+
437+heightBagMax :: HeightBag -> Height
438+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
439+ Just ((h, _), _) -> Height h
440+ Nothing -> zeroHeight
441+
442+heightBagVerify :: HeightBag -> HeightBag
443+#ifdef DEBUG
444+heightBagVerify b@(HeightBag s c) = if
445+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
446+ -> error $ "heightBagVerify: size doesn't match: " <> show b
447+ | unHeight invalidHeight `IntMap.member` c
448+ -> error $ "heightBagVerify: contains invalid height: " <> show b
449+ | otherwise -> b
450+#else
451+heightBagVerify = id
452+#endif
453+
412454data MergeSubscribed k
413455 = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge
414456 , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
415457 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
416458 , mergeSubscribedHeight :: !(IORef Height)
459+ , mergeSubscribedHeightBag :: !(IORef HeightBag)
417460 , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))
418461 , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))
419462 , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))
@@ -540,7 +583,10 @@ showEventType = \case
540583 EventHoldIdentity _ -> "EventHoldIdentity"
541584 EventDynIdentity _ -> "EventDynIdentity"
542585
543−type EventSubscription a = (Maybe (SubscriberListTicket a), EventSubscribed a)
586+data EventSubscription a = EventSubscription
587+ { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))
588+ , _eventSubscription_subscribed :: !(EventSubscribed a)
589+ }
544590
545591data EventSubscribed a
546592 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
@@ -552,7 +598,7 @@ data EventSubscribed a
552598 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
553599
554600unsubscribe :: EventSubscription a -> IO ()
555−unsubscribe (msln, _) = forM_ msln $ \sln -> WeakBag.remove sln
601+unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
556602
557603-- These function are constructor functions that are marked NOINLINE so they are
558604-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
@@ -970,8 +1016,8 @@ propagate a subscribers = withIncreasedDepth $ do
9701016 Nothing -> do
9711017 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
9721018 writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
973− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
974− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight
1019+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
1020+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
9751021 Just o -> do -- Since it's already firing, no need to adjust height
9761022 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
9771023 scheduleClear $ coincidenceSubscribedOccurrence subscribed
@@ -1008,7 +1054,7 @@ data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a
10081054subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
10091055subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
10101056 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
1011− subscription@(_, innerSubd) <- subscribe o subInner
1057+ subscription@(EventSubscription _ innerSubd) <- subscribe o subInner
10121058 innerOcc <- liftIO $ readEventSubscribed innerSubd
10131059 innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
10141060 let height = max innerHeight outerHeight
@@ -1141,7 +1187,7 @@ readMergeSubscribed subscribed = do
11411187
11421188readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)
11431189readFanSubscribed k fs = do
1144− parentOcc <- readEventSubscribed $ snd $ fanSubscribedParent fs
1190+ parentOcc <- readEventSubscribed $ _eventSubscription_subscribed $ fanSubscribedParent fs
11451191 return $ coerce $ DMap.lookup k =<< parentOcc
11461192
11471193readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
@@ -1162,11 +1208,11 @@ readCoincidenceSubscribed subscribed = do
11621208zeroRef :: IORef Height
11631209zeroRef = unsafePerformIO $ newIORef zeroHeight
11641210
1165−{-# SPECIALIZE getEventSubscribed :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
1166−getEventSubscribed :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1167−getEventSubscribed e sub = case e of
1211+{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}
1212+subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1213+subscribe e sub = case e of
11681214 EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
1169− EventNever -> return (Nothing, EventSubscribedNever)
1215+ EventNever -> return $ EventSubscription Nothing EventSubscribedNever
11701216 EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
11711217 EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
11721218 EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
@@ -1180,14 +1226,14 @@ getEventSubscribed e sub = case e of
11801226 wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
11811227 wrap tag getSpecificSubscribed = do
11821228 (sln, subd) <- getSpecificSubscribed sub
1183− return (Just sln, tag subd)
1229+ return $ EventSubscription (Just sln) $ tag subd
11841230
11851231{-# INLINE subscribeHoldEvent #-}
11861232subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
11871233subscribeHoldEvent h sub = do
1188− (_, subd) <- getHoldEventSubscription h
1234+ EventSubscription _ subd <- getHoldEventSubscription h
11891235 sln <- liftIO $ subscribeEventSubscribed subd sub
1190− return (sln, subd)
1236+ return $ EventSubscription sln subd
11911237
11921238{-# INLINE debugSubscribe #-}
11931239debugSubscribe :: Bool
@@ -1224,7 +1270,7 @@ eventSubscribedHeightRef = \case
12241270 EventSubscribedRoot _ -> zeroRef
12251271 EventSubscribedNever -> zeroRef
12261272 EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
1227− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ snd $ fanSubscribedParent subscribed
1273+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
12281274 EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
12291275 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
12301276 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
@@ -1245,17 +1291,17 @@ eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
12451291eventSubscribedGetParents = \case
12461292 EventSubscribedRoot _ -> return []
12471293 EventSubscribedNever -> return []
1248− EventSubscribedPush subscribed -> return [Some.This $ snd $ pushSubscribedParent subscribed]
1249− EventSubscribedFan _ subscribed -> return [Some.This $ snd $ fanSubscribedParent subscribed]
1294+ EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
1295+ EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
12501296 EventSubscribedMerge subscribed -> do
12511297 ps <- readIORef $ mergeSubscribedParents subscribed
1252− return $ fmap (\(_ :=> v) -> Some.This $ snd $ mergeSubscribedParentSubscription v) $ DMap.toList ps
1298+ return $ fmap (\(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v) $ DMap.toList ps
12531299 EventSubscribedSwitch subscribed -> do
12541300 s <- readIORef $ switchSubscribedCurrentParent subscribed
1255− return [Some.This $ snd s]
1301+ return [Some.This $ _eventSubscription_subscribed s]
12561302 EventSubscribedCoincidence subscribed -> do
12571303 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1258− let outerParent = Some.This $ snd $ coincidenceSubscribedOuterParent subscribed
1304+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
12591305 innerParents = maybeToList $ fmap Some.This innerSubscription
12601306 return $ outerParent : innerParents
12611307
@@ -1268,10 +1314,6 @@ type CanSubscribe x m =
12681314 , Defer SomeResetCoincidence m
12691315 )
12701316
1271−{-# INLINE subscribe #-}
1272−subscribe :: CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1273−subscribe = getEventSubscribed
1274−
12751317getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)
12761318getRootSubscribed k r sub = do
12771319 mSubscribed <- readIORef $ rootSubscribed r
@@ -1299,7 +1341,7 @@ getRootSubscribed k r sub = do
12991341#endif
13001342 }
13011343 writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "RootSubscribed"
1302− modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root" <> showNodeId r) k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1344+ modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
13031345 return (sln, subscribed)
13041346
13051347cleanupRootSubscribed :: RootSubscribed a -> IO ()
@@ -1324,7 +1366,7 @@ getPushSubscribed p sub = do
13241366 subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
13251367 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
13261368 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
1327− subscription@(_, subd) <- subscribe (pushParent p) s
1369+ subscription@(EventSubscription _ subd) <- subscribe (pushParent p) s
13281370 parentOcc <- liftIO $ readEventSubscribed subd
13291371 occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc
13301372 occRef <- liftIO $ newIORef occ
@@ -1372,13 +1414,16 @@ getMergeSubscribed m sub = do
13721414 initialParents <- readBehaviorUntracked $ current $ mergeParents m
13731415 subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
13741416 s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1375− subscription@(_, parentSubd) <- subscribe e s
1417+ subscription@(EventSubscription _ parentSubd) <- subscribe e s
13761418 parentOcc <- liftIO $ readEventSubscribed parentSubd
13771419 height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
13781420 return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))
13791421 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers
1380− subscriberHeights = map (\(_, x, _) -> x) subscribers
1381− myHeight = succHeight $ foldr maxHeight zeroHeight subscriberHeights
1422+ heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1423+ myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1424+ myHeight = if any (== invalidHeight) heights
1425+ then invalidHeight
1426+ else succHeight $ heightBagMax myHeightBag
13821427 currentHeight <- getCurrentHeight
13831428 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
13841429 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
@@ -1389,6 +1434,7 @@ getMergeSubscribed m sub = do
13891434 when (isJust occ) $ scheduleClear occRef
13901435 accumRef <- liftIO $ newIORef accum
13911436 heightRef <- liftIO $ newIORef myHeight
1437+ heightMapRef <- liftIO $ newIORef myHeightBag
13921438 weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"
13931439 (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed
13941440 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
@@ -1398,6 +1444,7 @@ getMergeSubscribed m sub = do
13981444 , mergeSubscribedOccurrence = occRef
13991445 , mergeSubscribedAccum = accumRef
14001446 , mergeSubscribedHeight = heightRef
1447+ , mergeSubscribedHeightBag = heightMapRef
14011448 , mergeSubscribedSubscribers = subs
14021449 , mergeSubscribedChange = changeSubdRef
14031450 , mergeSubscribedParents = parentsRef
@@ -1493,7 +1540,7 @@ getSwitchSubscribed s sub = do
14931540 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
14941541 holdInits <- getDeferralQueue
14951542 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1496− subscription@(_, subd) <- subscribe e mySub
1543+ subscription@(EventSubscription _ subd) <- subscribe e mySub
14971544 subscriptionRef <- liftIO $ newIORef subscription
14981545 parentOcc <- liftIO $ readEventSubscribed subd
14991546 occRef <- liftIO $ newIORef parentOcc
@@ -1543,7 +1590,7 @@ getCoincidenceSubscribed c sub = do
15431590 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
15441591 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
15451592 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1546− outerSubscription@(_, outerSubd) <- subscribe (coincidenceParent c) subOuter
1593+ outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter
15471594 outerOcc <- liftIO $ readEventSubscribed outerSubd
15481595 outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
15491596 (occ, height, mInnerSubd) <- case outerOcc of
@@ -1625,7 +1672,7 @@ initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
16251672initMerge :: SomeMergeInit -> EventM x ()
16261673initMerge (SomeMergeInit subscribed changed) = do
16271674 changeSub <- liftIO $ newSubscriberMergeChange subscribed
1628− (_, changeSubd) <- subscribe changed changeSub
1675+ EventSubscription _ changeSubd <- subscribe changed changeSub
16291676 change <- liftIO $ readEventSubscribed changeSubd
16301677 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
16311678 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
@@ -1665,20 +1712,25 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
16651712 mergeUpdates <- readIORef mergeUpdateRef
16661713 writeIORef mergeUpdateRef []
16671714 let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]
1668− updateMerge (SomeMergeUpdate (R.PatchDMap p) m) = do
1715+ updateMerge (SomeMergeUpdate (R.PatchDMap p :: R.PatchDMap (DMap k Event)) m) = do
16691716 oldParents <- readIORef $ mergeSubscribedParents m
16701717 let f (subscriptionsToKill, ps) (k :=> Compose me) = do
16711718 (mOldSubd, newPs) <- case me of
16721719 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
16731720 Just e -> do
16741721 s <- liftIO $ newSubscriberMerge k m
1675− subscription <- subscribe e s
1722+ subscription@(EventSubscription _ subd) <- subscribe e s
16761723 let newParent = MergeSubscribedParent subscription s
1724+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1725+ liftIO $ addMergeHeight newParentHeight m
16771726 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1678− liftIO $ invalidateMergeHeight k m
1727+ forM_ mOldSubd $ \oldSubd -> do
1728+ oldHeight <- liftIO $ readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription oldSubd
1729+ liftIO $ removeMergeHeight oldHeight m
16791730 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
16801731 (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
16811732 writeIORef (mergeSubscribedParents m) $! newParents
1733+ invalidateMergeHeight m
16821734 return subscriptionsToKill
16831735 mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
16841736 toReconnect <- readIORef toReconnectRef
@@ -1696,7 +1748,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
16961748 runEventM (runHoldInits holdInitRef mergeInitRef) env --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
16971749 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
16981750 sub <- newSubscriberSwitch subscribed
1699− subscription@(_, subd') <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
1751+ subscription@(EventSubscription _ subd') <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderEnv --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
17001752 {-
17011753 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
17021754 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
@@ -1708,8 +1760,8 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17081760 parentHeight <- readIORef $ eventSubscribedHeightRef subd'
17091761 myHeight <- readIORef $ switchSubscribedHeight subscribed
17101762 when (parentHeight /= myHeight) $ do
1711− writeIORef (switchSubscribedHeight subscribed) parentHeight
1712− WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1763+ writeIORef (switchSubscribedHeight subscribed) invalidHeight
1764+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
17131765 return $ SomeEventSubscription oldSubscription
17141766 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
17151767 unsubscribe subscription
@@ -1717,9 +1769,10 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
17171769 forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
17181770 forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
17191771 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1720− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> recalculateMergeHeight m
1772+ forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m
17211773 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1722− WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
1774+ height <- calculateSwitchHeight subscribed
1775+ updateSwitchHeight height subscribed
17231776 return result
17241777
17251778newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
@@ -1744,29 +1797,22 @@ succHeight h@(Height a) =
17441797 then invalidHeight
17451798 else Height $ succ a
17461799
1747−-- Get the maximum height; if either of the inputs is invalid, the output will also be invalid
1748−{-# INLINE maxHeight #-}
1749−maxHeight :: Height -> Height -> Height
1750−maxHeight ha@(Height a) hb@(Height b) =
1751− if ha == invalidHeight || hb == invalidHeight
1752− then invalidHeight
1753− else Height $ max a b
1754−
1755−invalidateSubscriberHeight :: Subscriber a -> IO ()
1756−invalidateSubscriberHeight s = case s of
1800+invalidateSubscriberHeight :: Height -> Subscriber a -> IO ()
1801+invalidateSubscriberHeight old s = case s of
17571802 SubscriberPush _ subscribed -> do
17581803 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1759− WeakBag.traverse (pushSubscribedSubscribers subscribed) invalidateSubscriberHeight
1804+ WeakBag.traverse (pushSubscribedSubscribers subscribed) $ invalidateSubscriberHeight old
17601805 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1761− SubscriberMerge k subscribed -> do
1806+ SubscriberMerge _ subscribed -> do
17621807 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1763− invalidateMergeHeight k subscribed
1808+ removeMergeHeight old subscribed
1809+ invalidateMergeHeight subscribed
17641810 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
17651811 SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed
17661812 SubscriberFan subscribed -> do
17671813 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
17681814 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1769− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) invalidateSubscriberHeight
1815+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
17701816 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
17711817 SubscriberHold _ -> return ()
17721818 SubscriberHoldIdentity _ -> return ()
@@ -1775,7 +1821,7 @@ invalidateSubscriberHeight s = case s of
17751821 oldHeight <- readIORef $ switchSubscribedHeight subscribed
17761822 when (oldHeight /= invalidHeight) $ do
17771823 writeIORef (switchSubscribedHeight subscribed) invalidHeight
1778− WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1824+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
17791825 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
17801826 SubscriberCoincidenceOuter subscribed -> do
17811827 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
@@ -1787,59 +1833,69 @@ invalidateSubscriberHeight s = case s of
17871833 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
17881834 SubscriberHandle -> return ()
17891835
1790−--TODO: Actually use the key
1791−invalidateMergeHeight :: k a -> MergeSubscribed k -> IO ()
1792−invalidateMergeHeight _ subscribed = do
1836+removeMergeHeight :: Height -> MergeSubscribed k -> IO ()
1837+removeMergeHeight oldParentHeight subscribed = do
1838+ oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1839+ let newHeights = heightBagRemove oldParentHeight oldHeights
1840+ putStrLn $ "removeMergeHeight " <> showNodeId subscribed <> ": " <> show oldHeights <> " => " <> show newHeights
1841+ writeIORef (mergeSubscribedHeightBag subscribed) newHeights
1842+
1843+invalidateMergeHeight :: MergeSubscribed k -> IO ()
1844+invalidateMergeHeight subscribed = do
17931845 oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1846+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
17941847 when (oldHeight /= invalidHeight) $ do
17951848 writeIORef (mergeSubscribedHeight subscribed) invalidHeight
1796− WeakBag.traverse (mergeSubscribedSubscribers subscribed) invalidateSubscriberHeight
1797−
1798−recalculateMergeHeight :: MergeSubscribed k -> IO ()
1799−recalculateMergeHeight subscribed = do
1800− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1801− when (oldHeight == invalidHeight) $ do
1802− height <- calculateMergeHeight subscribed
1849+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
1850+
1851+addMergeHeight :: Height -> MergeSubscribed k -> IO ()
1852+addMergeHeight newParentHeight subscribed = do
1853+ oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed
1854+ let newHeights = heightBagAdd newParentHeight oldHeights
1855+ putStrLn $ "addMergeHeight " <> showNodeId subscribed <> ": " <> show oldHeights <> " => " <> show newHeights
1856+ writeIORef (mergeSubscribedHeightBag subscribed) newHeights
1857+
1858+revalidateMergeHeight :: MergeSubscribed k -> IO ()
1859+revalidateMergeHeight subscribed = do
1860+ heights <- readIORef $ mergeSubscribedHeightBag subscribed
1861+ parents <- readIORef $ mergeSubscribedParents subscribed
1862+ putStrLn $ "revalidateMergeHeight " <> showNodeId subscribed <> ": " <> show (heightBagSize heights, DMap.size parents)
1863+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1864+ when (heightBagSize heights == DMap.size parents) $ do
1865+ let height = succHeight $ heightBagMax heights
18031866 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1804− when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated
1805− writeIORef (mergeSubscribedHeight subscribed) height
1806− WeakBag.traverse (mergeSubscribedSubscribers subscribed) recalculateSubscriberHeight
1867+ writeIORef (mergeSubscribedHeight subscribed) height
1868+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
18071869
18081870invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
18091871invalidateCoincidenceHeight subscribed = do
18101872 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
18111873 when (oldHeight /= invalidHeight) $ do
18121874 writeIORef (coincidenceSubscribedHeight subscribed) invalidHeight
1813− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
1814−
1815−--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy
1875+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
18161876
1817−recalculateSubscriberHeight :: Subscriber a -> IO ()
1818−recalculateSubscriberHeight s = case s of
1877+recalculateSubscriberHeight :: Height -> Subscriber a -> IO ()
1878+recalculateSubscriberHeight new s = case s of
18191879 SubscriberPush _ subscribed -> do
18201880 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1821− WeakBag.traverse (pushSubscribedSubscribers subscribed) recalculateSubscriberHeight
1881+ WeakBag.traverse (pushSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
18221882 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
18231883 SubscriberMerge _ subscribed -> do
18241884 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1825− recalculateMergeHeight subscribed
1885+ addMergeHeight new subscribed
1886+ revalidateMergeHeight subscribed
18261887 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
18271888 SubscriberMergeChange _ -> return ()
18281889 SubscriberFan subscribed -> do
18291890 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
18301891 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1831− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) recalculateSubscriberHeight
1892+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
18321893 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
18331894 SubscriberHold _ -> return ()
18341895 SubscriberHoldIdentity _ -> return ()
18351896 SubscriberSwitch subscribed -> do
18361897 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1837− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1838− when (oldHeight == invalidHeight) $ do
1839− height <- calculateSwitchHeight subscribed
1840− when (height /= invalidHeight) $ do
1841− writeIORef (switchSubscribedHeight subscribed) height
1842− WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
1898+ updateSwitchHeight new subscribed
18431899 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
18441900 SubscriberCoincidenceOuter subscribed -> do
18451901 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
@@ -1851,29 +1907,32 @@ recalculateSubscriberHeight s = case s of
18511907 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
18521908 SubscriberHandle -> return ()
18531909
1910+updateSwitchHeight :: Height -> SwitchSubscribed a -> IO ()
1911+updateSwitchHeight new subscribed = do
1912+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1913+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1914+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
1915+ writeIORef (switchSubscribedHeight subscribed) new
1916+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
1917+
18541918recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
18551919recalculateCoincidenceHeight subscribed = do
18561920 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
1857− when (oldHeight == invalidHeight) $ do
1921+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
18581922 height <- calculateCoincidenceHeight subscribed
18591923 when (height /= invalidHeight) $ do
18601924 writeIORef (coincidenceSubscribedHeight subscribed) height
1861− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight --TODO: This should probably be mandatory, just like with the merge and switch ones
1925+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
18621926
1863−calculateMergeHeight :: MergeSubscribed k -> IO Height
1864−calculateMergeHeight subscribed = do
1865− parents <- readIORef $ mergeSubscribedParents subscribed
1866− if DMap.null parents then return zeroHeight else do
1867− heights <- forM (DMap.toList parents) $ \(_ :=> es) -> do
1868− readIORef $ eventSubscribedHeightRef $ snd $ mergeSubscribedParentSubscription es
1869− return $ succHeight $ foldr maxHeight zeroHeight heights
1927+getEventSubscribedHeight :: EventSubscribed a -> IO Height
1928+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
18701929
18711930calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1872−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . snd =<< readIORef (switchSubscribedCurrentParent subscribed)
1931+calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
18731932
18741933calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
18751934calculateCoincidenceHeight subscribed = do
1876− outerHeight <- readIORef $ eventSubscribedHeightRef $ snd $ coincidenceSubscribedOuterParent subscribed
1935+ outerHeight <- readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
18771936 innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
18781937 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
18791938
@@ -2060,7 +2119,7 @@ instance R.ReflexHost (SpiderEnv x) where
20602119instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where
20612120 {-# INLINABLE readEvent #-}
20622121 readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do
2063− let (sln, subscribed) = unSpiderEventHandle h
2122+ let EventSubscription sln subscribed = unSpiderEventHandle h
20642123 result <- readEventSubscribed subscribed
20652124 touch sln
20662125 return result
@@ -2154,7 +2213,7 @@ instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where
21542213
21552214subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)
21562215subscribeEventSpiderHost e = do
2157− subscription <- runFrame $ getEventSubscribed (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2216+ subscription <- runFrame $ subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
21582217 return $ SpiderEventHandle subscription
21592218
21602219newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)