@@ -194,25 +194,25 @@ wrap tag getSpecificSubscribed sub = do
194194 return $ EventSubscription (Just sln) $ tag subd
195195
196196eventRoot :: GCompare k => k a -> Root x k -> Event x a
197−eventRoot !k !r = Event $ wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
197+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
198198
199199eventNever :: Event x a
200−eventNever = Event $ \_ -> return $ EventSubscription Nothing EventSubscribedNever
200+eventNever = Event $ \_ -> return $ EventSubscription Nothing eventSubscribedNever
201201
202202eventPush :: Push x b a -> Event x a
203−eventPush !p = Event $ wrap EventSubscribedPush $ getPushSubscribed p
203+eventPush !p = Event $ wrap eventSubscribedPush $ getPushSubscribed p
204204
205205eventMerge :: (GCompare k, a ~ DMap k Identity) => Merge x k -> Event x a
206−eventMerge !m = Event $ wrap EventSubscribedMerge $ getMergeSubscribed m
206+eventMerge !m = Event $ wrap eventSubscribedMerge $ getMergeSubscribed m
207207
208208eventFan :: GCompare k => k a -> Fan x k -> Event x a
209−eventFan !k !f = Event $ wrap (EventSubscribedFan k) $ getFanSubscribed k f
209+eventFan !k !f = Event $ wrap (eventSubscribedFan k) $ getFanSubscribed k f
210210
211211eventSwitch :: Switch x a -> Event x a
212−eventSwitch !s = Event $ wrap EventSubscribedSwitch $ getSwitchSubscribed s
212+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
213213
214214eventCoincidence :: Coincidence x a -> Event x a
215−eventCoincidence !c = Event $ wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
215+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
216216
217217eventHold :: (a ~ p b, R.Patch p) => Hold x p b -> Event x a
218218eventHold !h = Event $ subscribeHoldEvent h
@@ -302,7 +302,7 @@ newSubscriberMerge k subscribed = return $ Subscriber
302302 if height /= invalidHeight
303303 then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
304304 else liftIO $ do
305− nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed
305+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
306306 stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
307307 error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)
308308 scheduleMerge height subscribed
@@ -438,103 +438,104 @@ propagate a subscribers = withIncreasedDepth $ do
438438-- EventSubscribed
439439--------------------------------------------------------------------------------
440440
441−data EventSubscribed x a
442− = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed x a)
443− | EventSubscribedNever
444− | forall b. EventSubscribedPush !(PushSubscribed x b a)
445− | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed x k)
446− | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed x k)
447− | EventSubscribedSwitch !(SwitchSubscribed x a)
448− | EventSubscribedCoincidence !(CoincidenceSubscribed x a)
441+data EventSubscribed x a = EventSubscribed
442+ { eventSubscribedSubscribe :: !(Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a))))
443+ , eventSubscribedRead :: !(IO (Maybe a))
444+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
445+ , eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
446+ , eventSubscribedHasOwnHeightRef :: !Bool
447+ , eventSubscribedWhoCreated :: !(IO [String])
448+ }
449449
450450readEventSubscribed :: EventSubscribed x a -> IO (Maybe a)
451−readEventSubscribed = \case
452− EventSubscribedRoot rs -> readRootSubscribed rs
453− EventSubscribedNever -> return Nothing
454− EventSubscribedPush ps -> readPushSubscribed ps
455− EventSubscribedMerge ms -> readMergeSubscribed ms
456− EventSubscribedFan k fs -> readFanSubscribed k fs
457− EventSubscribedSwitch ss -> readSwitchSubscribed ss
458− EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
459−
460−{-# INLINE subscribeEventSubscribed #-}
451+readEventSubscribed = eventSubscribedRead
452+
461453subscribeEventSubscribed :: EventSubscribed x a -> Subscriber x a -> IO (Maybe (WeakBagTicket (Subscriber x a)))
462−subscribeEventSubscribed es sub = case es of
463− EventSubscribedRoot r -> do
464− traceSubscribe $ "subscribeEventSubscribed Root"
465− Just <$> subscribeRootSubscribed r sub
466− EventSubscribedNever -> do
467− traceSubscribe $ "subscribeEventSubscribed Never"
468− return Nothing
469− EventSubscribedPush subscribed -> do
470− traceSubscribe $ "subscribeEventSubscribed Push"
471− Just <$> subscribePushSubscribed subscribed sub
472− EventSubscribedFan k subscribed -> do
473− traceSubscribe $ "subscribeEventSubscribed Fan"
474− Just <$> subscribeFanSubscribed k subscribed sub
475− EventSubscribedMerge subscribed -> do
476− traceSubscribe $ "subscribeEventSubscribed Merge"
477− Just <$> subscribeMergeSubscribed subscribed sub
478− EventSubscribedSwitch subscribed -> do
479− traceSubscribe $ "subscribeEventSubscribed Switch"
480− Just <$> subscribeSwitchSubscribed subscribed sub
481− EventSubscribedCoincidence subscribed -> do
482− traceSubscribe $ "subscribeEventSubscribed Coincidence"
483− Just <$> subscribeCoincidenceSubscribed subscribed sub
484−
485−{-# INLINE eventSubscribedGetParents #-}
486−eventSubscribedGetParents :: EventSubscribed x a -> IO [Some (EventSubscribed x)]
487−eventSubscribedGetParents = \case
488− EventSubscribedRoot _ -> return []
489− EventSubscribedNever -> return []
490− EventSubscribedPush subscribed -> return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
491− EventSubscribedFan _ subscribed -> return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
492− EventSubscribedMerge subscribed -> do
493− ps <- readIORef $ mergeSubscribedParents subscribed
494− return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
495− EventSubscribedSwitch subscribed -> do
496− s <- readIORef $ switchSubscribedCurrentParent subscribed
497− return [Some.This $ _eventSubscription_subscribed s]
498− EventSubscribedCoincidence subscribed -> do
499− innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
500− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
501− innerParents = maybeToList $ fmap Some.This innerSubscription
502− return $ outerParent : innerParents
454+subscribeEventSubscribed = eventSubscribedSubscribe
455+
456+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x a
457+eventSubscribedRoot !r = EventSubscribed
458+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeRootSubscribed r sub
459+ , eventSubscribedRead = readRootSubscribed r
460+ , eventSubscribedGetParents = return []
461+ , eventSubscribedHeightRef = zeroRef
462+ , eventSubscribedHasOwnHeightRef = False
463+ , eventSubscribedWhoCreated = return ["root"]
464+ }
465+
466+eventSubscribedNever :: EventSubscribed x a
467+eventSubscribedNever = EventSubscribed
468+ { eventSubscribedSubscribe = \_ -> return Nothing
469+ , eventSubscribedRead = return Nothing
470+ , eventSubscribedGetParents = return []
471+ , eventSubscribedHeightRef = zeroRef
472+ , eventSubscribedHasOwnHeightRef = False
473+ , eventSubscribedWhoCreated = return ["never"]
474+ }
475+
476+eventSubscribedPush :: PushSubscribed x b a -> EventSubscribed x a
477+eventSubscribedPush !subscribed = EventSubscribed
478+ { eventSubscribedSubscribe = \sub -> Just <$> subscribePushSubscribed subscribed sub
479+ , eventSubscribedRead = readPushSubscribed subscribed
480+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ pushSubscribedParent subscribed]
481+ , eventSubscribedHeightRef = pushSubscribedHeight subscribed
482+ , eventSubscribedHasOwnHeightRef = False
483+ , eventSubscribedWhoCreated = whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
484+ }
485+
486+eventSubscribedMerge :: a ~ DMap k Identity => MergeSubscribed x k -> EventSubscribed x a
487+eventSubscribedMerge !subscribed = EventSubscribed
488+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeMergeSubscribed subscribed sub
489+ , eventSubscribedRead = readMergeSubscribed subscribed
490+ , eventSubscribedGetParents = do
491+ ps <- readIORef $ mergeSubscribedParents subscribed
492+ return $ R.ffor (DMap.toList ps) $ \(_ :=> v) -> Some.This $ _eventSubscription_subscribed $ mergeSubscribedParentSubscription v
493+ , eventSubscribedHeightRef = mergeSubscribedHeight subscribed
494+ , eventSubscribedHasOwnHeightRef = True
495+ , eventSubscribedWhoCreated = whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
496+ }
497+
498+eventSubscribedFan :: GCompare k => k a -> FanSubscribed x k -> EventSubscribed x a
499+eventSubscribedFan !k !subscribed = EventSubscribed
500+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeFanSubscribed k subscribed sub
501+ , eventSubscribedRead = readFanSubscribed k subscribed
502+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
503+ , eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
504+ , eventSubscribedHasOwnHeightRef = False
505+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
506+ }
507+
508+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x a
509+eventSubscribedSwitch !subscribed = EventSubscribed
510+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeSwitchSubscribed subscribed sub
511+ , eventSubscribedRead = readSwitchSubscribed subscribed
512+ , eventSubscribedGetParents = do
513+ s <- readIORef $ switchSubscribedCurrentParent subscribed
514+ return [Some.This $ _eventSubscription_subscribed s]
515+ , eventSubscribedHeightRef = switchSubscribedHeight subscribed
516+ , eventSubscribedHasOwnHeightRef = True
517+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
518+ }
519+
520+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x a
521+eventSubscribedCoincidence !subscribed = EventSubscribed
522+ { eventSubscribedSubscribe = \sub -> Just <$> subscribeCoincidenceSubscribed subscribed sub
523+ , eventSubscribedRead = readCoincidenceSubscribed subscribed
524+ , eventSubscribedGetParents = do
525+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
526+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
527+ innerParents = maybeToList $ fmap Some.This innerSubscription
528+ return $ outerParent : innerParents
529+ , eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
530+ , eventSubscribedHasOwnHeightRef = True
531+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
532+ }
503533
504534getEventSubscribedHeight :: EventSubscribed x a -> IO Height
505535getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
506536
507−{-# INLINE eventSubscribedHeightRef #-}
508−eventSubscribedHeightRef :: EventSubscribed x a -> IORef Height
509−eventSubscribedHeightRef = \case
510− EventSubscribedRoot _ -> zeroRef
511− EventSubscribedNever -> zeroRef
512− EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
513− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
514− EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
515− EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
516− EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
517−
518537whoCreatedEventSubscribed :: EventSubscribed x a -> IO [String]
519−whoCreatedEventSubscribed = \case
520− EventSubscribedRoot _ -> return ["root"]
521− EventSubscribedNever -> return ["never"]
522− EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
523− EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
524− EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
525− EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
526− EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
527−
528−{-# INLINE eventSubscribedHasOwnHeightRef #-}
529−eventSubscribedHasOwnHeightRef :: EventSubscribed x a -> Bool
530−eventSubscribedHasOwnHeightRef = \case
531− EventSubscribedRoot _ -> False
532− EventSubscribedNever -> False
533− EventSubscribedPush _ -> False
534− EventSubscribedFan _ _ -> False
535− EventSubscribedMerge _ -> True
536− EventSubscribedSwitch _ -> True
537− EventSubscribedCoincidence _ -> True
538+whoCreatedEventSubscribed = eventSubscribedWhoCreated
538539
539540walkInvalidHeightParents :: EventSubscribed x a -> IO [Some (EventSubscribed x)]
540541walkInvalidHeightParents s0 = do
@@ -1191,10 +1192,6 @@ type CanTrace x m = (HasSpiderEnv x m, MonadIO m)
11911192tracePropagate :: (CanTrace x m) => String -> m ()
11921193tracePropagate = traceWhen debugPropagate
11931194
1194−{-# INLINE traceSubscribe #-}
1195−traceSubscribe :: String -> IO ()
1196−traceSubscribe = when debugSubscribe . liftIO . putStrLn
1197−
11981195{-# INLINE traceInvalidate #-}
11991196traceInvalidate :: String -> IO ()
12001197traceInvalidate = when debugInvalidate . liftIO . putStrLn
@@ -1368,10 +1365,6 @@ readCoincidenceSubscribed subscribed = do
13681365zeroRef :: IORef Height
13691366zeroRef = unsafePerformIO $ newIORef zeroHeight
13701367
1371−{-# INLINE debugSubscribe #-}
1372−debugSubscribe :: Bool
1373−debugSubscribe = False
1374−
13751368type CanSubscribe x m =
13761369 ( HasSpiderEnv x m
13771370 , HasCurrentHeight x m