bfa1543 · patch · git.iko.soy

git.iko.soy/patch

Use running histograms instead of full recomputation for merge heights

bfa1543Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+157−98

@@ -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 #-}

2module Reflex.Spider.Internal (Spider, SpiderEnv (..), Global, SpiderHost, runSpiderHost, SpiderEventHandle (..), showSubscriberType, showEventType, ComputeM (..), MergeSubscribedParent (..), HasSpiderEnv (..), newSpiderEnv, SpiderPullM (..), SpiderPushM (..), ReadPhase (..)) where

4import qualified Reflex.Class as R

@@ -22,8 +22,8 @@ import Data.Dependent.Map (DMap, DSum (..))

22import qualified Data.Dependent.Map as DMap

23import Data.GADT.Compare

24import Data.Maybe

25−import Data.IntMap (IntMap)

25+import Data.IntMap.Strict (IntMap)

26−import qualified Data.IntMap as IntMap

26+import qualified Data.IntMap.Strict as IntMap

27import Control.Monad.Ref

28import Control.Monad.Exception

29import Data.Monoid ((<>))

@@ -287,7 +287,7 @@ getHoldEventSubscription h = do

287 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

288-}

289 -}

290− subscription@(_, subd) <- subscribe e =<< liftIO (newSubscriberHold h)

290+ subscription@(EventSubscription _ subd) <- subscribe e =<< liftIO (newSubscriberHold h)

291 liftIO $ writeIORef subscriptionRef subscription

292 occ <- liftIO $ readEventSubscribed subd

293 case occ of

@@ -409,11 +409,54 @@ data MergeSubscribedParent k a

409 , mergeSubscribedParentSubscriber :: !(Subscriber a)

410 }

411

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+

412data MergeSubscribed k

454data MergeSubscribed k

413 = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge

455 = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge

414 , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

456 , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

415 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

457 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

416 , mergeSubscribedHeight :: !(IORef Height)

458 , mergeSubscribedHeight :: !(IORef Height)

459+ , mergeSubscribedHeightBag :: !(IORef HeightBag)

417 , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))

460 , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))

418 , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))

461 , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))

419 , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))

462 , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))

@@ -540,7 +583,10 @@ showEventType = \case

540 EventHoldIdentity _ -> "EventHoldIdentity"

583 EventHoldIdentity _ -> "EventHoldIdentity"

541 EventDynIdentity _ -> "EventDynIdentity"

584 EventDynIdentity _ -> "EventDynIdentity"

542

585

586+data EventSubscription a = EventSubscription

543−type EventSubscription a = (Maybe (SubscriberListTicket a), EventSubscribed a)

587+ { _eventSubscription_ticket :: !(Maybe (SubscriberListTicket a))

588+ , _eventSubscription_subscribed :: !(EventSubscribed a)

589+ }

544

590

545data EventSubscribed a

591data EventSubscribed a

546 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)

592 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)

@@ -552,7 +598,7 @@ data EventSubscribed a

552 | EventSubscribedCoincidence !(CoincidenceSubscribed a)

598 | EventSubscribedCoincidence !(CoincidenceSubscribed a)

553

599

554unsubscribe :: EventSubscription a -> IO ()

600unsubscribe :: EventSubscription a -> IO ()

555−unsubscribe (msln, _) = forM_ msln $ \sln -> WeakBag.remove sln

601+unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln

556

602

557-- These function are constructor functions that are marked NOINLINE so they are

603-- These function are constructor functions that are marked NOINLINE so they are

558-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away

604-- 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

970 Nothing -> do

1016 Nothing -> do

971 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

1017 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

972 writeIORef (coincidenceSubscribedHeight subscribed) innerHeight

1018 writeIORef (coincidenceSubscribedHeight subscribed) innerHeight

973− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight

1019+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

974− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight

1020+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

975 Just o -> do -- Since it's already firing, no need to adjust height

1021 Just o -> do -- Since it's already firing, no need to adjust height

976 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

1022 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

977 scheduleClear $ coincidenceSubscribedOccurrence subscribed

1023 scheduleClear $ coincidenceSubscribedOccurrence subscribed

@@ -1008,7 +1054,7 @@ data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a

1008subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)

1054subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)

1009subscribeCoincidenceInner o outerHeight subscribedUnsafe = do

1055subscribeCoincidenceInner o outerHeight subscribedUnsafe = do

1010 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

1056 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

1011− subscription@(_, innerSubd) <- subscribe o subInner

1057+ subscription@(EventSubscription _ innerSubd) <- subscribe o subInner

1012 innerOcc <- liftIO $ readEventSubscribed innerSubd

1058 innerOcc <- liftIO $ readEventSubscribed innerSubd

1013 innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd

1059 innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd

1014 let height = max innerHeight outerHeight

1060 let height = max innerHeight outerHeight

@@ -1141,7 +1187,7 @@ readMergeSubscribed subscribed = do

1141

1187

1142readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)

1188readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)

1143readFanSubscribed k fs = do

1189readFanSubscribed k fs = do

1144− parentOcc <- readEventSubscribed $ snd $ fanSubscribedParent fs

1190+ parentOcc <- readEventSubscribed $ _eventSubscription_subscribed $ fanSubscribedParent fs

1145 return $ coerce $ DMap.lookup k =<< parentOcc

1191 return $ coerce $ DMap.lookup k =<< parentOcc

1146

1192

1147readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)

1193readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)

@@ -1162,11 +1208,11 @@ readCoincidenceSubscribed subscribed = do

1162zeroRef :: IORef Height

1208zeroRef :: IORef Height

1163zeroRef = unsafePerformIO $ newIORef zeroHeight

1209zeroRef = unsafePerformIO $ newIORef zeroHeight

1164

1210

1165−{-# SPECIALIZE getEventSubscribed :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}

1211+{-# SPECIALIZE subscribe :: Event a -> Subscriber a -> EventM x (EventSubscription a) #-}

1166−getEventSubscribed :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)

1212+subscribe :: forall x m a. CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)

1167−getEventSubscribed e sub = case e of

1213+subscribe e sub = case e of

1168 EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r

1214 EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r

1169− EventNever -> return (Nothing, EventSubscribedNever)

1215+ EventNever -> return $ EventSubscription Nothing EventSubscribedNever

1170 EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p

1216 EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p

1171 EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f

1217 EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f

1172 EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m

1218 EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m

@@ -1180,14 +1226,14 @@ getEventSubscribed e sub = case e of

1180 wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)

1226 wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)

1181 wrap tag getSpecificSubscribed = do

1227 wrap tag getSpecificSubscribed = do

1182 (sln, subd) <- getSpecificSubscribed sub

1228 (sln, subd) <- getSpecificSubscribed sub

1183− return (Just sln, tag subd)

1229+ return $ EventSubscription (Just sln) $ tag subd

1184

1230

1185{-# INLINE subscribeHoldEvent #-}

1231{-# INLINE subscribeHoldEvent #-}

1186subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))

1232subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))

1187subscribeHoldEvent h sub = do

1233subscribeHoldEvent h sub = do

1188− (_, subd) <- getHoldEventSubscription h

1234+ EventSubscription _ subd <- getHoldEventSubscription h

1189 sln <- liftIO $ subscribeEventSubscribed subd sub

1235 sln <- liftIO $ subscribeEventSubscribed subd sub

1190− return (sln, subd)

1236+ return $ EventSubscription sln subd

1191

1237

1192{-# INLINE debugSubscribe #-}

1238{-# INLINE debugSubscribe #-}

1193debugSubscribe :: Bool

1239debugSubscribe :: Bool

@@ -1224,7 +1270,7 @@ eventSubscribedHeightRef = \case

1224 EventSubscribedRoot _ -> zeroRef

1270 EventSubscribedRoot _ -> zeroRef

1225 EventSubscribedNever -> zeroRef

1271 EventSubscribedNever -> zeroRef

1226 EventSubscribedPush subscribed -> pushSubscribedHeight subscribed

1272 EventSubscribedPush subscribed -> pushSubscribedHeight subscribed

1227− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ snd $ fanSubscribedParent subscribed

1273+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

1228 EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed

1274 EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed

1229 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed

1275 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed

1230 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed

1276 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed

@@ -1245,17 +1291,17 @@ eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]

1245eventSubscribedGetParents = \case

1291eventSubscribedGetParents = \case

1246 EventSubscribedRoot _ -> return []

1292 EventSubscribedRoot _ -> return []

1247 EventSubscribedNever -> return []

1293 EventSubscribedNever -> return []

1248− EventSubscribedPush subscribed -> return [Some.This $ snd $ pushSubscribedParent subscribed]

1294+ EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]

1249− EventSubscribedFan _ subscribed -> return [Some.This $ snd $ fanSubscribedParent subscribed]

1295+ EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

1250 EventSubscribedMerge subscribed -> do

1296 EventSubscribedMerge subscribed -> do

1251 ps <- readIORef $ mergeSubscribedParents subscribed

1297 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

1253 EventSubscribedSwitch subscribed -> do

1299 EventSubscribedSwitch subscribed -> do

1254 s <- readIORef $ switchSubscribedCurrentParent subscribed

1300 s <- readIORef $ switchSubscribedCurrentParent subscribed

1255− return [Some.This $ snd s]

1301+ return [Some.This $ _eventSubscription_subscribed s]

1256 EventSubscribedCoincidence subscribed -> do

1302 EventSubscribedCoincidence subscribed -> do

1257 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

1303 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

1258− let outerParent = Some.This $ snd $ coincidenceSubscribedOuterParent subscribed

1304+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

1259 innerParents = maybeToList $ fmap Some.This innerSubscription

1305 innerParents = maybeToList $ fmap Some.This innerSubscription

1260 return $ outerParent : innerParents

1306 return $ outerParent : innerParents

1261

1307

@@ -1268,10 +1314,6 @@ type CanSubscribe x m =

1268 , Defer SomeResetCoincidence m

1314 , Defer SomeResetCoincidence m

1269 )

1315 )

1270

1316

1271−{-# INLINE subscribe #-}

1272−subscribe :: CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)

1273−subscribe = getEventSubscribed

1274−

1275getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)

1317getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)

1276getRootSubscribed k r sub = do

1318getRootSubscribed k r sub = do

1277 mSubscribed <- readIORef $ rootSubscribed r

1319 mSubscribed <- readIORef $ rootSubscribed r

@@ -1299,7 +1341,7 @@ getRootSubscribed k r sub = do

1299#endif

1341#endif

1300 }

1342 }

1301 writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "RootSubscribed"

1343 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

1303 return (sln, subscribed)

1345 return (sln, subscribed)

1304

1346

1305cleanupRootSubscribed :: RootSubscribed a -> IO ()

1347cleanupRootSubscribed :: RootSubscribed a -> IO ()

@@ -1324,7 +1366,7 @@ getPushSubscribed p sub = do

1324 subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"

1366 subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"

1325 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1367 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1326 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe

1368 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe

1327− subscription@(_, subd) <- subscribe (pushParent p) s

1369+ subscription@(EventSubscription _ subd) <- subscribe (pushParent p) s

1328 parentOcc <- liftIO $ readEventSubscribed subd

1370 parentOcc <- liftIO $ readEventSubscribed subd

1329 occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc

1371 occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc

1330 occRef <- liftIO $ newIORef occ

1372 occRef <- liftIO $ newIORef occ

@@ -1372,13 +1414,16 @@ getMergeSubscribed m sub = do

1372 initialParents <- readBehaviorUntracked $ current $ mergeParents m

1414 initialParents <- readBehaviorUntracked $ current $ mergeParents m

1373 subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1415 subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1374 s <- liftIO $ newSubscriberMerge k subscribedUnsafe

1416 s <- liftIO $ newSubscriberMerge k subscribedUnsafe

1375− subscription@(_, parentSubd) <- subscribe e s

1417+ subscription@(EventSubscription _ parentSubd) <- subscribe e s

1376 parentOcc <- liftIO $ readEventSubscribed parentSubd

1418 parentOcc <- liftIO $ readEventSubscribed parentSubd

1377 height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd

1419 height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd

1378 return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))

1420 return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))

1379 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers

1421 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers

1380− subscriberHeights = map (\(_, x, _) -> x) subscribers

1422+ heights = fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1381− myHeight = succHeight $ foldr maxHeight zeroHeight subscriberHeights

1423+ myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1424+ myHeight = if any (== invalidHeight) heights

1425+ then invalidHeight

1426+ else succHeight $ heightBagMax myHeightBag

1382 currentHeight <- getCurrentHeight

1427 currentHeight <- getCurrentHeight

1383 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1428 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1384 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1429 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

@@ -1389,6 +1434,7 @@ getMergeSubscribed m sub = do

1389 when (isJust occ) $ scheduleClear occRef

1434 when (isJust occ) $ scheduleClear occRef

1390 accumRef <- liftIO $ newIORef accum

1435 accumRef <- liftIO $ newIORef accum

1391 heightRef <- liftIO $ newIORef myHeight

1436 heightRef <- liftIO $ newIORef myHeight

1437+ heightMapRef <- liftIO $ newIORef myHeightBag

1392 weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"

1438 weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"

1393 (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed

1439 (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed

1394 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1440 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

@@ -1398,6 +1444,7 @@ getMergeSubscribed m sub = do

1398 , mergeSubscribedOccurrence = occRef

1444 , mergeSubscribedOccurrence = occRef

1399 , mergeSubscribedAccum = accumRef

1445 , mergeSubscribedAccum = accumRef

1400 , mergeSubscribedHeight = heightRef

1446 , mergeSubscribedHeight = heightRef

1447+ , mergeSubscribedHeightBag = heightMapRef

1401 , mergeSubscribedSubscribers = subs

1448 , mergeSubscribedSubscribers = subs

1402 , mergeSubscribedChange = changeSubdRef

1449 , mergeSubscribedChange = changeSubdRef

1403 , mergeSubscribedParents = parentsRef

1450 , mergeSubscribedParents = parentsRef

@@ -1493,7 +1540,7 @@ getSwitchSubscribed s sub = do

1493 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior

1540 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior

1494 holdInits <- getDeferralQueue

1541 holdInits <- getDeferralQueue

1495 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits

1542 e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits

1496− subscription@(_, subd) <- subscribe e mySub

1543+ subscription@(EventSubscription _ subd) <- subscribe e mySub

1497 subscriptionRef <- liftIO $ newIORef subscription

1544 subscriptionRef <- liftIO $ newIORef subscription

1498 parentOcc <- liftIO $ readEventSubscribed subd

1545 parentOcc <- liftIO $ readEventSubscribed subd

1499 occRef <- liftIO $ newIORef parentOcc

1546 occRef <- liftIO $ newIORef parentOcc

@@ -1543,7 +1590,7 @@ getCoincidenceSubscribed c sub = do

1543 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"

1590 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"

1544 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1591 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

1545 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe

1592 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe

1546− outerSubscription@(_, outerSubd) <- subscribe (coincidenceParent c) subOuter

1593+ outerSubscription@(EventSubscription _ outerSubd) <- subscribe (coincidenceParent c) subOuter

1547 outerOcc <- liftIO $ readEventSubscribed outerSubd

1594 outerOcc <- liftIO $ readEventSubscribed outerSubd

1548 outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd

1595 outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd

1549 (occ, height, mInnerSubd) <- case outerOcc of

1596 (occ, height, mInnerSubd) <- case outerOcc of

@@ -1625,7 +1672,7 @@ initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1625initMerge :: SomeMergeInit -> EventM x ()

1672initMerge :: SomeMergeInit -> EventM x ()

1626initMerge (SomeMergeInit subscribed changed) = do

1673initMerge (SomeMergeInit subscribed changed) = do

1627 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1674 changeSub <- liftIO $ newSubscriberMergeChange subscribed

1628− (_, changeSubd) <- subscribe changed changeSub

1675+ EventSubscription _ changeSubd <- subscribe changed changeSub

1629 change <- liftIO $ readEventSubscribed changeSubd

1676 change <- liftIO $ readEventSubscribed changeSubd

1630 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed

1677 forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed

1631 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)

1678 liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)

@@ -1665,20 +1712,25 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1665 mergeUpdates <- readIORef mergeUpdateRef

1712 mergeUpdates <- readIORef mergeUpdateRef

1666 writeIORef mergeUpdateRef []

1713 writeIORef mergeUpdateRef []

1667 let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]

1714 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

1669 oldParents <- readIORef $ mergeSubscribedParents m

1716 oldParents <- readIORef $ mergeSubscribedParents m

1670 let f (subscriptionsToKill, ps) (k :=> Compose me) = do

1717 let f (subscriptionsToKill, ps) (k :=> Compose me) = do

1671 (mOldSubd, newPs) <- case me of

1718 (mOldSubd, newPs) <- case me of

1672 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1719 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1673 Just e -> do

1720 Just e -> do

1674 s <- liftIO $ newSubscriberMerge k m

1721 s <- liftIO $ newSubscriberMerge k m

1675− subscription <- subscribe e s

1722+ subscription@(EventSubscription _ subd) <- subscribe e s

1676 let newParent = MergeSubscribedParent subscription s

1723 let newParent = MergeSubscribedParent subscription s

1724+ newParentHeight <- liftIO $ getEventSubscribedHeight subd

1725+ liftIO $ addMergeHeight newParentHeight m

1677 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1726 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

1679 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)

1730 return (maybeToList (SomeEventSubscription . mergeSubscribedParentSubscription <$> mOldSubd) ++ subscriptionsToKill, newPs)

1680 (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

1731 (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

1681 writeIORef (mergeSubscribedParents m) $! newParents

1732 writeIORef (mergeSubscribedParents m) $! newParents

1733+ invalidateMergeHeight m

1682 return subscriptionsToKill

1734 return subscriptionsToKill

1683 mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates

1735 mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates

1684 toReconnect <- readIORef toReconnectRef

1736 toReconnect <- readIORef toReconnectRef

@@ -1696,7 +1748,7 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1696 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

1748 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

1697 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1749 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1698 sub <- newSubscriberSwitch subscribed

1750 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

1700 {-

1752 {-

1701 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1753 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1702 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

1754 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

@@ -1708,8 +1760,8 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1708 parentHeight <- readIORef $ eventSubscribedHeightRef subd'

1760 parentHeight <- readIORef $ eventSubscribedHeightRef subd'

1709 myHeight <- readIORef $ switchSubscribedHeight subscribed

1761 myHeight <- readIORef $ switchSubscribedHeight subscribed

1710 when (parentHeight /= myHeight) $ do

1762 when (parentHeight /= myHeight) $ do

1711− writeIORef (switchSubscribedHeight subscribed) parentHeight

1763+ writeIORef (switchSubscribedHeight subscribed) invalidHeight

1712− WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight

1764+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

1713 return $ SomeEventSubscription oldSubscription

1765 return $ SomeEventSubscription oldSubscription

1714 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

1766 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

1715 unsubscribe subscription

1767 unsubscribe subscription

@@ -1717,9 +1769,10 @@ runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do

1717 forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription

1769 forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription

1718 forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription

1770 forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription

1719 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs

1771 forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs

1720− forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> recalculateMergeHeight m

1772+ forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> revalidateMergeHeight m

1721 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do

1773 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do

1722− WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight

1774+ height <- calculateSwitchHeight subscribed

1775+ updateSwitchHeight height subscribed

1723 return result

1776 return result

1724

1777

1725newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)

1778newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)

@@ -1744,29 +1797,22 @@ succHeight h@(Height a) =

1744 then invalidHeight

1797 then invalidHeight

1745 else Height $ succ a

1798 else Height $ succ a

1746

1799

1747−-- Get the maximum height; if either of the inputs is invalid, the output will also be invalid

1800+invalidateSubscriberHeight :: Height -> Subscriber a -> IO ()

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

1801+invalidateSubscriberHeight old s = case s of

1757 SubscriberPush _ subscribed -> do

1802 SubscriberPush _ subscribed -> do

1758 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed

1803 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed

1759− WeakBag.traverse (pushSubscribedSubscribers subscribed) invalidateSubscriberHeight

1804+ WeakBag.traverse (pushSubscribedSubscribers subscribed) $ invalidateSubscriberHeight old

1760 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"

1805 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"

1761− SubscriberMerge k subscribed -> do

1806+ SubscriberMerge _ subscribed -> do

1762 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed

1807 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed

1808+ removeMergeHeight old subscribed

1763− invalidateMergeHeight k subscribed

1809+ invalidateMergeHeight subscribed

1764 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"

1810 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"

1765 SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed

1811 SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed

1766 SubscriberFan subscribed -> do

1812 SubscriberFan subscribed -> do

1767 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1813 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1768 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1814 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

1770 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1816 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1771 SubscriberHold _ -> return ()

1817 SubscriberHold _ -> return ()

1772 SubscriberHoldIdentity _ -> return ()

1818 SubscriberHoldIdentity _ -> return ()

@@ -1775,7 +1821,7 @@ invalidateSubscriberHeight s = case s of

1775 oldHeight <- readIORef $ switchSubscribedHeight subscribed

1821 oldHeight <- readIORef $ switchSubscribedHeight subscribed

1776 when (oldHeight /= invalidHeight) $ do

1822 when (oldHeight /= invalidHeight) $ do

1777 writeIORef (switchSubscribedHeight subscribed) invalidHeight

1823 writeIORef (switchSubscribedHeight subscribed) invalidHeight

1778− WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight

1824+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1779 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

1825 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

1780 SubscriberCoincidenceOuter subscribed -> do

1826 SubscriberCoincidenceOuter subscribed -> do

1781 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

1827 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

@@ -1787,59 +1833,69 @@ invalidateSubscriberHeight s = case s of

1787 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

1833 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

1788 SubscriberHandle -> return ()

1834 SubscriberHandle -> return ()

1789

1835

1790−--TODO: Actually use the key

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+

1791−invalidateMergeHeight :: k a -> MergeSubscribed k -> IO ()

1843+invalidateMergeHeight :: MergeSubscribed k -> IO ()

1792−invalidateMergeHeight _ subscribed = do

1844+invalidateMergeHeight subscribed = do

1793 oldHeight <- readIORef $ mergeSubscribedHeight subscribed

1845 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

1794 when (oldHeight /= invalidHeight) $ do

1847 when (oldHeight /= invalidHeight) $ do

1795 writeIORef (mergeSubscribedHeight subscribed) invalidHeight

1848 writeIORef (mergeSubscribedHeight subscribed) invalidHeight

1796− WeakBag.traverse (mergeSubscribedSubscribers subscribed) invalidateSubscriberHeight

1849+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1797−

1850+

1798−recalculateMergeHeight :: MergeSubscribed k -> IO ()

1851+addMergeHeight :: Height -> MergeSubscribed k -> IO ()

1799−recalculateMergeHeight subscribed = do

1852+addMergeHeight newParentHeight subscribed = do

1800− oldHeight <- readIORef $ mergeSubscribedHeight subscribed

1853+ oldHeights <- readIORef $ mergeSubscribedHeightBag subscribed

1801− when (oldHeight == invalidHeight) $ do

1854+ let newHeights = heightBagAdd newParentHeight oldHeights

1802− height <- calculateMergeHeight subscribed

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

1803 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1866 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

1867+ writeIORef (mergeSubscribedHeight subscribed) height

1806− WeakBag.traverse (mergeSubscribedSubscribers subscribed) recalculateSubscriberHeight

1868+ WeakBag.traverse (mergeSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

1807

1869

1808invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()

1870invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()

1809invalidateCoincidenceHeight subscribed = do

1871invalidateCoincidenceHeight subscribed = do

1810 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1872 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1811 when (oldHeight /= invalidHeight) $ do

1873 when (oldHeight /= invalidHeight) $ do

1812 writeIORef (coincidenceSubscribedHeight subscribed) invalidHeight

1874 writeIORef (coincidenceSubscribedHeight subscribed) invalidHeight

1813− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight

1875+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

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

1816

1876

1817−recalculateSubscriberHeight :: Subscriber a -> IO ()

1877+recalculateSubscriberHeight :: Height -> Subscriber a -> IO ()

1818−recalculateSubscriberHeight s = case s of

1878+recalculateSubscriberHeight new s = case s of

1819 SubscriberPush _ subscribed -> do

1879 SubscriberPush _ subscribed -> do

1820 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed

1880 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed

1821− WeakBag.traverse (pushSubscribedSubscribers subscribed) recalculateSubscriberHeight

1881+ WeakBag.traverse (pushSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

1822 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"

1882 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"

1823 SubscriberMerge _ subscribed -> do

1883 SubscriberMerge _ subscribed -> do

1824 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed

1884 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed

1825− recalculateMergeHeight subscribed

1885+ addMergeHeight new subscribed

1886+ revalidateMergeHeight subscribed

1826 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"

1887 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"

1827 SubscriberMergeChange _ -> return ()

1888 SubscriberMergeChange _ -> return ()

1828 SubscriberFan subscribed -> do

1889 SubscriberFan subscribed -> do

1829 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1890 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1830 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1891 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

1832 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1893 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1833 SubscriberHold _ -> return ()

1894 SubscriberHold _ -> return ()

1834 SubscriberHoldIdentity _ -> return ()

1895 SubscriberHoldIdentity _ -> return ()

1835 SubscriberSwitch subscribed -> do

1896 SubscriberSwitch subscribed -> do

1836 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

1897 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

1837− oldHeight <- readIORef $ switchSubscribedHeight subscribed

1898+ updateSwitchHeight new 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

1843 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

1899 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

1844 SubscriberCoincidenceOuter subscribed -> do

1900 SubscriberCoincidenceOuter subscribed -> do

1845 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

1901 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

@@ -1851,29 +1907,32 @@ recalculateSubscriberHeight s = case s of

1851 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

1907 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

1852 SubscriberHandle -> return ()

1908 SubscriberHandle -> return ()

1853

1909

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+

1854recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()

1918recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()

1855recalculateCoincidenceHeight subscribed = do

1919recalculateCoincidenceHeight subscribed = do

1856 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1920 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1857− when (oldHeight == invalidHeight) $ do

1921+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1858 height <- calculateCoincidenceHeight subscribed

1922 height <- calculateCoincidenceHeight subscribed

1859 when (height /= invalidHeight) $ do

1923 when (height /= invalidHeight) $ do

1860 writeIORef (coincidenceSubscribedHeight subscribed) height

1924 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

1862

1926

1863−calculateMergeHeight :: MergeSubscribed k -> IO Height

1927+getEventSubscribedHeight :: EventSubscribed a -> 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

1928+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

1869− return $ succHeight $ foldr maxHeight zeroHeight heights

1870

1929

1871calculateSwitchHeight :: SwitchSubscribed a -> IO Height

1930calculateSwitchHeight :: SwitchSubscribed a -> IO Height

1872−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . snd =<< readIORef (switchSubscribedCurrentParent subscribed)

1931+calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

1873

1932

1874calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height

1933calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height

1875calculateCoincidenceHeight subscribed = do

1934calculateCoincidenceHeight subscribed = do

1876− outerHeight <- readIORef $ eventSubscribedHeightRef $ snd $ coincidenceSubscribedOuterParent subscribed

1935+ outerHeight <- readIORef $ eventSubscribedHeightRef $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

1877 innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)

1936 innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)

1878 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight

1937 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight

1879

1938

@@ -2060,7 +2119,7 @@ instance R.ReflexHost (SpiderEnv x) where

2060instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2119instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where

2061 {-# INLINABLE readEvent #-}

2120 {-# INLINABLE readEvent #-}

2062 readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do

2121 readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do

2063− let (sln, subscribed) = unSpiderEventHandle h

2122+ let EventSubscription sln subscribed = unSpiderEventHandle h

2064 result <- readEventSubscribed subscribed

2123 result <- readEventSubscribed subscribed

2065 touch sln

2124 touch sln

2066 return result

2125 return result

@@ -2154,7 +2213,7 @@ instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where

2154

2213

2155subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)

2214subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)

2156subscribeEventSpiderHost e = do

2215subscribeEventSpiderHost 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)

2158 return $ SpiderEventHandle subscription

2217 return $ SpiderEventHandle subscription

2159

2218

2160newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)

2219newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)