@@ -1,9 +1,12 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}
2−module Reflex.Spider.Internal where
1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators, FlexibleContexts, ConstraintKinds, MagicHash, UnboxedTuples, FunctionalDependencies #-}
2+module 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
55import qualified Reflex.Host.Class as R
6+import Data.WeakBag (WeakBag, WeakBagTicket)
7+import qualified Data.WeakBag as WeakBag
68
9+import Data.List
710import Data.IORef
811import System.Mem.Weak
912import Data.Foldable
@@ -11,8 +14,10 @@ import Data.Traversable
1114import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)
1215import Control.Monad.Identity hiding (mapM, mapM_, forM_, forM, sequence)
1316import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)
14−import GHC.Exts
17+import Control.Monad.State hiding (mapM, mapM_, forM_, forM, sequence)
1518import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2
19+import Data.Some (Some)
20+import qualified Data.Some as Some
1621import Data.Dependent.Map (DMap, DSum (..))
1722import qualified Data.Dependent.Map as DMap
1823import Data.GADT.Compare
@@ -22,32 +27,52 @@ import qualified Data.IntMap as IntMap
2227import Control.Monad.Ref
2328import Control.Monad.Exception
2429import Data.Monoid ((<>))
25−import Data.Coerce
30+import Data.Functor.Compose
2631import Control.Exception
32+import Control.Concurrent
33+import Data.Function
34+import Data.These
35+import Data.Align
36+
37+import GHC.IORef (IORef (..))
38+import GHC.Base (IO (..))
39+import GHC.Stack
2740
2841import System.IO.Unsafe
2942import Unsafe.Coerce
43+import Data.Coerce
3044import Control.Monad.Primitive
3145
46+import qualified Data.List.NonEmpty as NonEmpty
47+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
48+import Data.Tree (Tree (..), Forest, drawForest)
49+
3250-- Note: must come last to silence warnings due to AMP on GHC < 7.10
3351import Prelude hiding (mapM, mapM_, any, sequence, concat)
3452
53+type SubscriberList a = WeakBag (Subscriber a)
54+type SubscriberListTicket a = WeakBagTicket (Subscriber a)
55+
3556debugPropagate :: Bool
3657
3758debugInvalidateHeight :: Bool
3859
60+debugInvalidate :: Bool
61+
3962#ifdef DEBUG
4063
4164#define DEBUG_NODEIDS
4265
4366debugPropagate = True
4467
45−debugInvalidateHeight = True
68+debugInvalidateHeight = False
69+
70+debugInvalidate = True
4671
4772class HasNodeId a where
4873 getNodeId :: a -> Int
4974
50−instance HasNodeId (Hold a) where
75+instance HasNodeId (Hold p a) where
5176 getNodeId = holdNodeId
5277
5378instance HasNodeId (PushSubscribed a b) where
@@ -68,6 +93,10 @@ instance HasNodeId (CoincidenceSubscribed a) where
6893instance HasNodeId (RootSubscribed a) where
6994 getNodeId = rootSubscribedNodeId
7095
96+instance HasNodeId (Pull a) where
97+ getNodeId = pullNodeId
98+
99+{-# INLINE showNodeId #-}
71100showNodeId :: HasNodeId a => a -> String
72101showNodeId = ("#"<>) . show . getNodeId
73102
@@ -77,8 +106,12 @@ debugPropagate = False
77106
78107debugInvalidateHeight = False
79108
109+debugInvalidate = False
110+
111+-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
112+{-# INLINE showNodeId #-}
80113showNodeId :: a -> String
81−showNodeId = const ""
114+showNodeId _ = ""
82115
83116#endif
84117
@@ -87,116 +120,208 @@ showNodeId = const ""
87120nextNodeIdRef :: IORef Int
88121nextNodeIdRef = unsafePerformIO $ newIORef 1
89122
123+newNodeId :: IO Int
124+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
125+
90126{-# NOINLINE unsafeNodeId #-}
91127unsafeNodeId :: a -> Int
92128unsafeNodeId a = unsafePerformIO $ do
93129 touch a
94− atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
130+ newNodeId
95131#endif
96132
97133--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce
98134--type role Hold representational
99−data Hold a
135+data Hold p a
100136 = Hold { holdValue :: !(IORef a)
101137 , holdInvalidators :: !(IORef [Weak Invalidator])
102− -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce'
103− , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef
104− , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef
138+ , holdParent :: !(IORef (Either (Event (p a)) (EventSubscription (p a)))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
105139#ifdef DEBUG_NODEIDS
106140 , holdNodeId :: Int
107141#endif
108142 }
109143
110−data EventEnv
111− = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])
112− , eventEnvHoldInits :: !(IORef [SomeHoldInit])
113− , eventEnvClears :: !(IORef [SomeMaybeIORef])
114− , eventEnvRootClears :: !(IORef [SomeDMapIORef])
115− , eventEnvCurrentHeight :: !(IORef Int)
116− , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])
144+data EventEnv x
145+ = EventEnv { eventEnvSpiderEnv :: !(SpiderEnv x)
146+ , eventEnvAssignments :: !(IORef [SomeAssignment]) -- Needed for Subscribe
147+ , eventEnvHoldInits :: !(IORef [SomeHoldInit]) -- Needed for Subscribe
148+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate])
149+ , eventEnvMergeInits :: !(IORef [SomeMergeInit]) -- Needed for Subscribe
150+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
151+ , eventEnvRootClears :: !(IORef [SomeRootClear])
152+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
153+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence]) -- Needed for Subscribe
117154 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
118155 }
119156
120−runEventM :: EventM a -> EventEnv -> IO a
157+{-# INLINE runEventM #-}
158+runEventM :: EventM x a -> EventEnv x -> IO a
121159runEventM = runReaderT . unEventM
122160
123−askToAssignRef :: EventM (IORef [SomeAssignment])
124−askToAssignRef = EventM $ asks eventEnvAssignments
125−
126−askHoldInitRef :: EventM (IORef [SomeHoldInit])
127−askHoldInitRef = EventM $ asks eventEnvHoldInits
128−
129−getCurrentHeight :: EventM Int
130−getCurrentHeight = EventM $ do
131− heightRef <- asks eventEnvCurrentHeight
132− liftIO $ readIORef heightRef
133−
134−putCurrentHeight :: Int -> EventM ()
161+class MonadIO m => Defer a m where
162+ getDeferralQueue :: m (IORef [a])
163+
164+{-# INLINE defer #-}
165+defer :: Defer a m => a -> m ()
166+defer a = do
167+ q <- getDeferralQueue
168+ liftIO $ modifyIORef' q (a:)
169+
170+instance Defer SomeAssignment (EventM x) where
171+ {-# INLINE getDeferralQueue #-}
172+ getDeferralQueue = EventM $ asks eventEnvAssignments
173+
174+instance Defer SomeHoldInit (EventM x) where
175+ {-# INLINE getDeferralQueue #-}
176+ getDeferralQueue = EventM $ asks eventEnvHoldInits
177+
178+instance Defer SomeHoldInit BehaviorM where
179+ {-# INLINE getDeferralQueue #-}
180+ getDeferralQueue = BehaviorM $ asks snd
181+
182+instance Defer SomeMergeUpdate (EventM x) where
183+ {-# INLINE getDeferralQueue #-}
184+ getDeferralQueue = EventM $ asks eventEnvMergeUpdates
185+
186+instance Defer SomeMergeInit (EventM x) where
187+ {-# INLINE getDeferralQueue #-}
188+ getDeferralQueue = EventM $ asks eventEnvMergeInits
189+
190+class HasCurrentHeight m where
191+ getCurrentHeight :: m Height
192+ scheduleMerge :: Height -> MergeSubscribed a -> m ()
193+
194+instance HasCurrentHeight (EventM x) where
195+ {-# INLINE getCurrentHeight #-}
196+ getCurrentHeight = EventM $ do
197+ heightRef <- asks eventEnvCurrentHeight
198+ liftIO $ readIORef heightRef
199+ {-# INLINE scheduleMerge #-}
200+ scheduleMerge height subscribed = EventM $ do
201+ delayedRef <- asks eventEnvDelayedMerges
202+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [DelayedMerge subscribed]
203+
204+class HasSpiderEnv x m | m -> x where
205+ askSpiderEnv :: m (SpiderEnv x)
206+
207+instance HasSpiderEnv x (EventM x) where
208+ {-# INLINE askSpiderEnv #-}
209+ askSpiderEnv = EventM $ asks eventEnvSpiderEnv
210+
211+instance HasSpiderEnv x (SpiderHost x) where
212+ {-# INLINE askSpiderEnv #-}
213+ askSpiderEnv = SpiderHost ask
214+
215+putCurrentHeight :: Height -> EventM x ()
135216putCurrentHeight h = EventM $ do
136217 heightRef <- asks eventEnvCurrentHeight
137218 liftIO $ writeIORef heightRef h
138219
139−scheduleClear :: IORef (Maybe a) -> EventM ()
140−scheduleClear r = EventM $ do
141− clears <- asks eventEnvClears
142− liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
220+instance Defer SomeClear (EventM x) where
221+ {-# INLINE getDeferralQueue #-}
222+ getDeferralQueue = EventM $ asks eventEnvClears
143223
144−scheduleRootClear :: IORef (DMap k Identity) -> EventM ()
145−scheduleRootClear r = EventM $ do
146− clears <- asks eventEnvRootClears
147− liftIO $ modifyIORef' clears (SomeDMapIORef r :)
224+{-# INLINE scheduleClear #-}
225+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
226+scheduleClear r = defer $ SomeClear r
148227
149−scheduleMerge :: Int -> MergeSubscribed a -> EventM ()
150−scheduleMerge height subscribed = EventM $ do
151− delayedRef <- asks eventEnvDelayedMerges
152− liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed]
228+instance Defer SomeRootClear (EventM x) where
229+ {-# INLINE getDeferralQueue #-}
230+ getDeferralQueue = EventM $ asks eventEnvRootClears
153231
154−emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()
155−emitCoincidenceInfo sci = EventM $ do
156− ciRef <- asks eventEnvCoincidenceInfos
157− liftIO $ modifyIORef' ciRef (sci:)
232+{-# INLINE scheduleRootClear #-}
233+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
234+scheduleRootClear r = defer $ SomeRootClear r
235+
236+instance Defer SomeResetCoincidence (EventM x) where
237+ {-# INLINE getDeferralQueue #-}
238+ getDeferralQueue = EventM $ asks eventEnvResetCoincidences
158239
159240-- Note: hold cannot examine its event until after the phase is over
160−hold :: a -> Event a -> EventM (Behavior a)
241+{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> EventM x (Hold p a) #-}
242+{-# SPECIALIZE hold :: R.Patch p => a -> Event (p a) -> ComputeM (Hold p a) #-}
243+hold :: (R.Patch p, Defer SomeHoldInit m) => a -> Event (p a) -> m (Hold p a)
161244hold v0 e = do
162− holdInitRef <- askHoldInitRef
163− liftIO $ do
164− valRef <- newIORef v0
165− invsRef <- newIORef []
166− parentRef <- newIORef $ error "hold not yet initialized (parent)"
167− subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)"
168− let h = Hold
169− { holdValue = valRef
170− , holdInvalidators = invsRef
171− , holdSubscriber = subscriberRef
172− , holdParent = parentRef
245+ valRef <- liftIO $ newIORef v0
246+ invsRef <- liftIO $ newIORef []
247+ parentRef <- liftIO $ newIORef $ Left e
173248#ifdef DEBUG_NODEIDS
174− , holdNodeId = unsafeNodeId (v0, e)
249+ nodeId <- liftIO newNodeId
175250#endif
176− }
177− s <- newSubscriberHold h
178− writeIORef subscriberRef $ unsafeCoerce s
179− modifyIORef' holdInitRef (SomeHoldInit e h :)
180− return $ BehaviorHold h
181−
182−subscribeHold :: Event a -> Hold a -> EventM ()
183−subscribeHold e h = do
184− toAssignRef <- askToAssignRef
185− !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item
186− ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber"
187− subd <- subscribe e $ WeakSubscriberSimple ws
188− liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd
189− occ <- liftIO $ getEventSubscribedOcc subd
190− case occ of
191− Nothing -> return ()
192− Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)
251+ let h = Hold
252+ { holdValue = valRef
253+ , holdInvalidators = invsRef
254+ , holdParent = parentRef
255+#ifdef DEBUG_NODEIDS
256+ , holdNodeId = nodeId
257+#endif
258+ }
259+ defer $ SomeHoldInit h
260+ return h
261+
262+{-
263+mkWeakIORefKey :: IORef a -> b -> IO () -> IO (Weak b)
264+mkWeakIORefKey r@(IORef (STRef r#)) b (IO f) = IO $ \s ->
265+ case mkWeak# r# b f s of (# s1, w #) -> (# s1, Weak w #)
266+-}
267+
268+{-# INLINE getHoldEventSubscription #-}
269+getHoldEventSubscription :: forall m p a x. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeClear m, R.Patch p, HasCurrentHeight m, Defer SomeMergeInit m, Defer SomeResetCoincidence m, HasSpiderEnv x m) => Hold p a -> m (EventSubscription (p a))
270+getHoldEventSubscription h = do
271+ ep <- liftIO $ readIORef $ holdParent h
272+ case ep of
273+ Right subd -> return subd
274+ Left e -> do
275+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
276+ {-
277+ spiderEnv <- askSpiderEnv
278+ weakSubscriptionRef <- liftIO $ mkWeakIORef subscriptionRef $ return ()
279+ wh <- liftIO $ mkWeakIORefKey (holdValue h) h $ do
280+ msr <- deRefWeak weakSubscriptionRef
281+ forM_ msr $ \sr -> do
282+ subscription <- readIORef sr
283+ atomicModifyIORef (_spiderEnv_toUnsubscribe spiderEnv) $ \x -> (SomeEventSubscription subscription : x, ())
284+-- return ()
285+ {-
286+ -- What can we do? 1) Detect GCs at the SpiderEnv level, then go over the tree
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)
291+ liftIO $ writeIORef subscriptionRef subscription
292+ occ <- liftIO $ readEventSubscribed subd
293+ case occ of
294+ Nothing -> return ()
295+ Just o -> do
296+ old <- liftIO $ readIORef $ holdValue h
297+ case R.apply o old of
298+ Nothing -> return ()
299+ Just new -> do
300+ -- Need to evaluate these so that we don't retain the Hold itself
301+ v <- liftIO $ evaluate $ holdValue h
302+ i <- liftIO $ evaluate $ holdInvalidators h
303+ defer $ SomeAssignment v i new
304+ liftIO $ writeIORef (holdParent h) $ Right subscription
305+ return subscription
306+
307+type BehaviorEnv = (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]), IORef [SomeHoldInit])
193308
194309--type role BehaviorM representational
195310-- BehaviorM can sample behaviors
196−newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
311+newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT BehaviorEnv IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
312+
313+instance Monad BehaviorM where
314+ {-# INLINE (>>=) #-}
315+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
316+ {-# INLINE (>>) #-}
317+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
318+ {-# INLINE return #-}
319+ return x = BehaviorM $ return x
320+ {-# INLINE fail #-}
321+ fail s = BehaviorM $ fail s
197322
198323data BehaviorSubscribed a
199− = BehaviorSubscribedHold (Hold a)
324+ = forall p. BehaviorSubscribedHold (Hold p a)
200325 | BehaviorSubscribedPull (PullSubscribed a)
201326
202327data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)
@@ -213,16 +338,26 @@ data PullSubscribed a
213338data Pull a
214339 = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))
215340 , pullCompute :: !(BehaviorM a)
341+#ifdef DEBUG_NODEIDS
342+ , pullNodeId :: Int
343+#endif
216344 }
217345
218346data Invalidator
219347 = forall a. InvalidatorPull (Pull a)
220348 | forall a. InvalidatorSwitch (SwitchSubscribed a)
221349
222−data RootSubscribed a
223− = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
224− , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
225− }
350+data RootSubscribed a = forall k. GCompare k => RootSubscribed
351+ { rootSubscribedKey :: !(k a)
352+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k RootSubscribed)) -- From the original Root
353+ , rootSubscribedSubscribers :: !(SubscriberList a)
354+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
355+ , rootSubscribedUninit :: IO ()
356+ , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
357+#ifdef DEBUG_NODEIDS
358+ , rootSubscribedNodeId :: Int
359+#endif
360+ }
226361
227362data Root (k :: * -> *)
228363 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
@@ -230,35 +365,59 @@ data Root (k :: * -> *)
230365 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
231366 }
232367
233−data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
368+data SomeHoldInit = forall p a. R.Patch p => SomeHoldInit !(Hold p a)
369+
370+data SomeMergeUpdate = forall k. GCompare k => SomeMergeUpdate (R.PatchDMap (DMap k Event)) (MergeSubscribed k)
371+
372+data SomeMergeInit = forall k. GCompare k => SomeMergeInit !(MergeSubscribed k) !(Event (R.PatchDMap (DMap k Event)))
373+
374+data SomeEventSubscription = forall a. SomeEventSubscription (EventSubscription a)
234375
235376-- EventM can do everything BehaviorM can, plus create holds
236−newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
377+newtype EventM x a = EventM { unEventM :: ReaderT (EventEnv x) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
237378
238379data PushSubscribed a b
239− = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)
240− , pushSubscribedHeight :: !(IORef Int)
241− , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b])
242− , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die
243− , pushSubscribedParent :: !(EventSubscribed a)
380+ = PushSubscribed { pushSubscribedCachedSubscribed :: !(IORef (Maybe (PushSubscribed a b)))
381+ , pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)
382+ , pushSubscribedHeight :: !(IORef Height)
383+ , pushSubscribedSubscribers :: !(SubscriberList b)
384+ , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die --TODO: Probably unneeded now
385+ , pushSubscribedWeakSelf :: !(IORef (Weak (PushSubscribed a b)))
386+ , pushSubscribedParent :: !(EventSubscription a)
244387#ifdef DEBUG_NODEIDS
245388 , pushSubscribedNodeId :: Int
246389#endif
247390 }
248391
392+newtype ComputeM a = ComputeM { unComputeM :: ReaderT (IORef [SomeHoldInit]) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
393+
394+instance Defer SomeHoldInit ComputeM where
395+ getDeferralQueue = ComputeM ask
396+
397+{-# SPECIALIZE runComputeM :: ComputeM a -> EventM x a #-}
398+runComputeM :: Defer SomeHoldInit m => ComputeM a -> m a
399+runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
400+
249401data Push a b
250− = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed
402+ = Push { pushCompute :: !(a -> ComputeM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed --TODO: This only uses Defer SomeHoldInit EventM; perhaps only the hold init queue should be passed in (also, perhaps those hold inits can be accelerated - can there be a loop we would need to worry about?)
251403 , pushParent :: !(Event a)
252404 , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?
253405 }
254406
407+data MergeSubscribedParent k a
408+ = MergeSubscribedParent { mergeSubscribedParentSubscription :: !(EventSubscription a)
409+ , mergeSubscribedParentSubscriber :: !(Subscriber a)
410+ }
411+
255412data MergeSubscribed k
256− = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
413+ = MergeSubscribed { mergeSubscribedCachedSubscribed :: !(IORef (Maybe (MergeSubscribed k))) -- From the original merge
414+ , mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
257415 , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence
258− , mergeSubscribedHeight :: !(IORef Int)
259− , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])
260− , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory
261− , mergeSubscribedParents :: !(DMap k EventSubscribed)
416+ , mergeSubscribedHeight :: !(IORef Height)
417+ , mergeSubscribedSubscribers :: !(SubscriberList (DMap k Identity))
418+ , mergeSubscribedChange :: !(IORef (Subscriber (R.PatchDMap (DMap k Event)), EventSubscribed (R.PatchDMap (DMap k Event))))
419+ , mergeSubscribedParents :: !(IORef (DMap k (MergeSubscribedParent k)))
420+ , mergeSubscribedWeakSelf :: !(IORef (Weak (MergeSubscribed k)))
262421#ifdef DEBUG_NODEIDS
263422 , mergeSubscribedNodeId :: Int
264423#endif
@@ -266,28 +425,19 @@ data MergeSubscribed k
266425
267426--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)
268427data Merge k
269− = Merge { mergeParents :: !(DMap k Event)
270− , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?
428+ = Merge { mergeParents :: !(Dynamic R.PatchDMap (DMap k Event))
429+ , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k)))
271430 }
272431
273−data FanSubscriberKey k a where
274− FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]
275−
276−instance GEq k => GEq (FanSubscriberKey k) where
277− geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of
278− Nothing -> Nothing
279− Just Refl -> Just Refl
280−
281−instance GCompare k => GCompare (FanSubscriberKey k) where
282− gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of
283− GLT -> GLT
284− GEQ -> GEQ
285− GGT -> GGT
432+data FanSubscribedChildren k a = FanSubscribedChildren
433+ { _fanSubscribedChildren_list :: !(SubscriberList a)
434+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed k)))
435+ }
286436
287437data FanSubscribed k
288− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))
289− , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))
290− , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))
438+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed k)))
439+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren k))) -- This DMap should never be empty
440+ , fanSubscribedParent :: !(EventSubscription (DMap k Identity))
291441#ifdef DEBUG_NODEIDS
292442 , fanSubscribedNodeId :: Int
293443#endif
@@ -299,16 +449,16 @@ data Fan k
299449 }
300450
301451data SwitchSubscribed a
302− = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))
303− , switchSubscribedHeight :: !(IORef Int)
304− , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])
305− , switchSubscribedSelf :: {-# NOUNPACK #-} (Subscriber a)
306− , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))
307− , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} Invalidator
452+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))
453+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
454+ , switchSubscribedHeight :: !(IORef Height)
455+ , switchSubscribedSubscribers :: !(SubscriberList a)
456+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !Invalidator
308457 , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))
309458 , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])
310459 , switchSubscribedParent :: !(Behavior (Event a))
311− , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))
460+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription a))
461+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed a)))
312462#ifdef DEBUG_NODEIDS
313463 , switchSubscribedNodeId :: Int
314464#endif
@@ -320,12 +470,14 @@ data Switch a
320470 }
321471
322472data CoincidenceSubscribed a
323− = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
324− , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])
325− , coincidenceSubscribedHeight :: !(IORef Int)
473+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
474+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
475+ , coincidenceSubscribedSubscribers :: !(SubscriberList a)
476+ , coincidenceSubscribedHeight :: !(IORef Height)
326477 , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber (Event a))
327− , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))
478+ , coincidenceSubscribedOuterParent :: !(EventSubscription (Event a))
328479 , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))
480+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed a)))
329481#ifdef DEBUG_NODEIDS
330482 , coincidenceSubscribedNodeId :: Int
331483#endif
@@ -336,41 +488,30 @@ data Coincidence a
336488 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))
337489 }
338490
339−data Box a = Box { unBox :: a }
340−
341−--type WeakSubscriber a = Weak (Subscriber a)
342−data WeakSubscriber a
343− = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare?
344− | WeakSubscriberSimple !(Weak (Subscriber a))
345−
346−showWeakSubscriberType :: WeakSubscriber a -> String
347−showWeakSubscriberType = \case
348− WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"
349− WeakSubscriberSimple _ -> "WeakSubscriberSimple"
350−
351−deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a))
352−deRefWeakSubscriber ws = case ws of
353− WeakSubscriberSimple w -> deRefWeak w
354− WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w
355−
356491data Subscriber a
357− = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)
492+ = forall b. SubscriberPush (a -> ComputeM (Maybe b)) (PushSubscribed a b) --TODO: Why does this have the pushCompute in it?
358493 | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?
494+ | forall k. (a ~ R.PatchDMap (DMap k Event), GCompare k) => SubscriberMergeChange (MergeSubscribed k)
359495 | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)
360− | SubscriberHold !(Hold a)
496+ | forall p b. (a ~ p b, R.Patch p) => SubscriberHold !(Hold p b)
497+ | forall b. (a ~ Identity b) => SubscriberHoldIdentity !(Hold Identity b)
361498 | SubscriberSwitch (SwitchSubscribed a)
362499 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)
363500 | SubscriberCoincidenceInner (CoincidenceSubscribed a)
501+ | SubscriberHandle
364502
365503showSubscriberType :: Subscriber a -> String
366504showSubscriberType = \case
367505 SubscriberPush _ _ -> "SubscriberPush"
368506 SubscriberMerge _ _ -> "SubscriberMerge"
369507 SubscriberFan _ -> "SubscriberFan"
508+ SubscriberMergeChange _ -> "SubscriberMergeChange"
370509 SubscriberHold _ -> "SubscriberHold"
510+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
371511 SubscriberSwitch _ -> "SubscriberSwitch"
372512 SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
373513 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
514+ SubscriberHandle -> "SubscriberHandle"
374515
375516data Event a
376517 = forall k. GCompare k => EventRoot !(k a) !(Root k)
@@ -380,6 +521,10 @@ data Event a
380521 | forall k. GCompare k => EventFan !(k a) !(Fan k)
381522 | EventSwitch !(Switch a)
382523 | EventCoincidence !(Coincidence a)
524+ | forall p b. (a ~ p b, R.Patch p) => EventHold !(Hold p b)
525+ | forall p b. (a ~ p b, R.Patch p) => EventDyn !(Dyn p b)
526+ | forall b. (a ~ Identity b) => EventHoldIdentity !(Hold Identity b)
527+ | forall b. (a ~ Identity b) => EventDynIdentity !(Dyn Identity b)
383528
384529showEventType :: Event a -> String
385530showEventType = \case
@@ -390,6 +535,12 @@ showEventType = \case
390535 EventFan _ _ -> "EventFan"
391536 EventSwitch _ -> "EventSwitch"
392537 EventCoincidence _ -> "EventCoincidence"
538+ EventHold _ -> "EventHold"
539+ EventDyn _ -> "EventDyn"
540+ EventHoldIdentity _ -> "EventHoldIdentity"
541+ EventDynIdentity _ -> "EventDynIdentity"
542+
543+type EventSubscription a = (Maybe (SubscriberListTicket a), EventSubscribed a)
393544
394545data EventSubscribed a
395546 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)
@@ -400,6 +551,9 @@ data EventSubscribed a
400551 | EventSubscribedSwitch !(SwitchSubscribed a)
401552 | EventSubscribedCoincidence !(CoincidenceSubscribed a)
402553
554+unsubscribe :: EventSubscription a -> IO ()
555+unsubscribe (msln, _) = forM_ msln $ \sln -> WeakBag.remove sln
556+
403557-- These function are constructor functions that are marked NOINLINE so they are
404558-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
405559-- so any weak references that are attached to the constructors will have their
@@ -409,22 +563,30 @@ data EventSubscribed a
409563-- The result is also evaluated to WHNF, since forcing a thunk invalidates
410564-- the weak pointer to it in some cases.
411565
412−{-# NOINLINE newRootSubscribed #-}
413−newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
414−newRootSubscribed occ subs =
415− return $! RootSubscribed
416− { rootSubscribedOccurrence = occ
417− , rootSubscribedSubscribers = subs
418− }
419−
566+--TODO: I think all of these noinlines are now unnecessary
420567{-# NOINLINE newSubscriberPush #-}
421−newSubscriberPush :: (a -> EventM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
568+newSubscriberPush :: (a -> ComputeM (Maybe b)) -> PushSubscribed a b -> IO (Subscriber a)
422569newSubscriberPush compute subd = return $! SubscriberPush compute subd
423570
571+{-# RULES
572+ "newSubscriberHold/Identity" forall h. newSubscriberHold h = newSubscriberHoldIdentity h
573+ #-}
424574{-# NOINLINE newSubscriberHold #-}
425−newSubscriberHold :: Hold a -> IO (Subscriber a)
575+newSubscriberHold :: R.Patch p => Hold p a -> IO (Subscriber (p a))
426576newSubscriberHold h = return $! SubscriberHold h
427577
578+{-# NOINLINE newSubscriberHoldIdentity #-}
579+newSubscriberHoldIdentity :: Hold Identity a -> IO (Subscriber (Identity a))
580+newSubscriberHoldIdentity h = return $! SubscriberHoldIdentity h
581+
582+{-# NOINLINE newSubscriberMerge #-}
583+newSubscriberMerge :: GCompare k => k a -> MergeSubscribed k -> IO (Subscriber a)
584+newSubscriberMerge k subd = return $! SubscriberMerge k subd
585+
586+{-# NOINLINE newSubscriberMergeChange #-}
587+newSubscriberMergeChange :: GCompare k => MergeSubscribed k -> IO (Subscriber (R.PatchDMap (DMap k Event)))
588+newSubscriberMergeChange subd = return $! SubscriberMergeChange subd
589+
428590{-# NOINLINE newSubscriberFan #-}
429591newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))
430592newSubscriberFan subd = return $! SubscriberFan subd
@@ -449,15 +611,100 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
449611newInvalidatorPull :: Pull a -> IO Invalidator
450612newInvalidatorPull p = return $! InvalidatorPull p
451613
452−{-# NOINLINE newBox #-}
453−newBox :: a -> IO (Box a)
454−newBox a = return $! Box a
614+data Dynamic p a
615+ = DynamicHold !(Hold p a)
616+ | p ~ Identity => DynamicHoldIdentity !(Hold Identity a)
617+ | DynamicConst !a
618+ | DynamicDyn !(Dyn p a)
619+ | p ~ Identity => DynamicDynIdentity !(Dyn Identity a)
620+
621+{-# INLINE current #-}
622+current :: R.Patch p => Dynamic p a -> Behavior a
623+current = \case
624+ DynamicHold h -> BehaviorHold h
625+ DynamicHoldIdentity h -> BehaviorHoldIdentity h
626+ DynamicConst a -> BehaviorConst a
627+ DynamicDyn d -> BehaviorDyn d
628+ DynamicDynIdentity d -> BehaviorDynIdentity d
629+
630+--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?
631+{-# INLINE updated #-}
632+updated :: R.Patch p => Dynamic p a -> Event (p a)
633+updated = \case
634+ DynamicHold h -> EventHold h
635+ DynamicHoldIdentity h -> EventHoldIdentity h
636+ DynamicConst _ -> EventNever
637+ DynamicDyn d -> EventDyn d
638+ DynamicDynIdentity d -> EventDynIdentity d
639+
640+newMapDyn :: (a -> b) -> Dynamic Identity a -> Dynamic Identity b
641+newMapDyn f d = DynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ current d) (fmap (Identity . f . runIdentity) $ updated d)
642+
643+instance Functor (Dynamic Identity) where
644+ fmap f d = newMapDyn f d
645+
646+instance Applicative (Dynamic Identity) where
647+ pure = DynamicConst
648+ (<*>) = zipDynWith ($)
649+ _ *> b = b
650+ a <* _ = a
651+
652+instance R.FunctorMaybe Event where
653+ fmapMaybe f = push $ return . f
654+
655+instance Align Event where
656+ nil = EventNever
657+ align ea eb = R.fmapMaybe R.dmapToThese $ merge $ DynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
658+
659+--TODO: Avoid the duplication between this and R.zipDynWith
660+zipDynWith :: (a -> b -> c) -> Dynamic Identity a -> Dynamic Identity b -> Dynamic Identity c
661+zipDynWith f da db =
662+ let eab = align (updated da) (updated db)
663+ ec = flip push eab $ \o -> do
664+ (a, b) <- case o of
665+ This (Identity a) -> do
666+ b <- readBehaviorUntracked $ current db
667+ return (a, b)
668+ That (Identity b) -> do
669+ a <- readBehaviorUntracked $ current da
670+ return (a, b)
671+ These (Identity a) (Identity b) -> return (a, b)
672+ return $ Just $ Identity $ f a b
673+ in DynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (current da) <*> readBehaviorUntracked (current db)) ec
674+
675+instance Monad (Dynamic Identity) where
676+ {-# INLINE return #-}
677+ return = pure
678+ {-# INLINE (>>=) #-}
679+ x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
680+ {-# INLINE (>>) #-}
681+ _ >> y = y
682+ {-# INLINE fail #-}
683+ fail _ = error "Dynamic does not support 'fail'"
684+
685+newtype Dyn p a = Dyn { unDyn :: IORef (Either (BehaviorM a, Event (p a)) (Hold p a)) }
686+
687+unsafeDyn :: BehaviorM a -> Event (p a) -> Dyn p a
688+unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
689+ where x = (readV0, v')
690+
691+newJoinDyn :: Dynamic Identity (Dynamic Identity a) -> Dyn Identity a
692+newJoinDyn d =
693+ let readV0 = readBehaviorTracked . current =<< readBehaviorTracked (current d)
694+ eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . current . runIdentity) $ updated d
695+ eInner = switch $ fmap updated $ current d
696+ eBoth = coincidence $ fmap (updated . runIdentity) $ updated d
697+ v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
698+ in unsafeDyn readV0 v'
455699
456700--type role Behavior representational
457701data Behavior a
458− = BehaviorHold !(Hold a)
702+ = forall p. BehaviorHold !(Hold p a)
703+ | BehaviorHoldIdentity !(Hold Identity a)
459704 | BehaviorConst !a
460705 | BehaviorPull !(Pull a)
706+ | BehaviorDynIdentity !(Dyn Identity a)
707+ | forall p. R.Patch p => BehaviorDyn !(Dyn p a)
461708
462709-- ResultM can read behaviors and events
463710type ResultM = EventM
@@ -473,21 +720,23 @@ instance Functor Behavior where
473720 fmap f = pull . liftM f . readBehaviorTracked
474721
475722{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly
476−push :: (a -> EventM (Maybe b)) -> Event a -> Event b
723+push :: forall a b. (a -> ComputeM (Maybe b)) -> Event a -> Event b
477724push f e = EventPush $ Push
478725 { pushCompute = f
479726 , pushParent = e
480727 , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?
481728 }
482−{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
729+-- DISABLED: {- RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}
483730
484731{-# NOINLINE pull #-}
485732pull :: BehaviorM a -> Behavior a
486733pull a = BehaviorPull $ Pull
487734 { pullCompute = a
488735 , pullValue = unsafeNewIORef a Nothing
736+#ifdef DEBUG_NODEIDS
737+ , pullNodeId = unsafeNodeId a
738+#endif
489739 }
490−{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}
491740
492741{-# NOINLINE switch #-}
493742switch :: Behavior (Event a) -> Event a
@@ -495,7 +744,6 @@ switch a = EventSwitch $ Switch
495744 { switchParent = a
496745 , switchSubscribed = unsafeNewIORef a Nothing
497746 }
498−{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}
499747
500748coincidence :: Event (Event a) -> Event a
501749coincidence a = EventCoincidence $ Coincidence
@@ -503,32 +751,20 @@ coincidence a = EventCoincidence $ Coincidence
503751 , coincidenceSubscribed = unsafeNewIORef a Nothing
504752 }
505753
506−newRoot :: IO (Root k)
507−newRoot = do
508− occRef <- newIORef DMap.empty
509− subscribedRef <- newIORef DMap.empty
510− return $ Root
511− { rootOccurrence = occRef
512− , rootSubscribed = subscribedRef
513− , rootInit = \_ _ -> return $ return ()
514− }
515−
516−propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()
754+propagateAndUpdateSubscribersRef :: SubscriberList a -> a -> EventM x ()
517755propagateAndUpdateSubscribersRef subscribersRef a = do
518− subscribers <- liftIO $ readIORef subscribersRef
519− liftIO $ writeIORef subscribersRef []
520− stillAlive <- propagate a subscribers
521− liftIO $ modifyIORef' subscribersRef (++stillAlive)
756+ propagate a subscribersRef
522757
523758-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
524−run :: [DSum RootTrigger Identity] -> ResultM b -> IO b
759+run :: [DSum RootTrigger Identity] -> ResultM x b -> SpiderHost x b
525760run roots after = do
526− when debugPropagate $ putStrLn "Running an event frame"
527− result <- runFrame $ do
761+ tracePropagate $ "Running an event frame with " <> show (length roots) <> " events"
762+ spiderEnv <- SpiderHost ask
763+ result <- SpiderHost $ lift $ withMVar (_spiderEnv_lock spiderEnv) $ \_ -> flip runReaderT spiderEnv $ unSpiderHost $ runFrame $ do
528764 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
529765 occBefore <- liftIO $ do
530766 occBefore <- readIORef occRef
531− writeIORef occRef $ DMap.insert k a occBefore
767+ writeIORef occRef $! DMap.insert k a occBefore
532768 return occBefore
533769 if DMap.null occBefore
534770 then do scheduleRootClear occRef
@@ -541,14 +777,14 @@ run roots after = do
541777 delayed <- liftIO $ readIORef delayedRef
542778 case IntMap.minViewWithKey delayed of
543779 Nothing -> return ()
544− Just ((currentHeight, current), future) -> do
545− when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight
546− putCurrentHeight currentHeight
780+ Just ((currentHeight, cur), future) -> do
781+ tracePropagate $ "Running height " ++ show currentHeight
782+ putCurrentHeight $ Height currentHeight
547783 liftIO $ writeIORef delayedRef future
548− forM_ current $ \d -> case d of
784+ forM_ cur $ \d -> case d of
549785 DelayedMerge subscribed -> do
550786 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
551− case height `compare` currentHeight of
787+ case height `compare` Height currentHeight of
552788 LT -> error "Somehow a merge's height has been decreased after it was scheduled"
553789 GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)
554790 EQ -> do
@@ -562,14 +798,14 @@ run roots after = do
562798 go
563799 putCurrentHeight maxBound
564800 after
565− when debugPropagate $ putStrLn "Done running an event frame"
801+ tracePropagate "Done running an event frame"
566802 return result
567803
568−data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
804+data SomeClear = forall a. SomeClear (IORef (Maybe a))
569805
570−data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))
806+data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))
571807
572−data SomeAssignment = forall a. SomeAssignment (Hold a) a
808+data SomeAssignment = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak Invalidator]) a
573809
574810data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
575811
@@ -577,136 +813,231 @@ debugFinalize :: Bool
577813debugFinalize = False
578814
579815mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
580−mkWeakPtrWithDebug x debugNote = mkWeakPtr x $
581− if debugFinalize
582− then Just $ putStrLn $ "finalizing: " ++ debugNote
583− else Nothing
816+mkWeakPtrWithDebug x debugNote = do
817+ x' <- evaluate x
818+ mkWeakPtr x' $
819+ if debugFinalize
820+ then Just $ putStrLn $ "finalizing: " ++ debugNote
821+ else Nothing
584822
585823type WeakList a = [Weak a]
586824
587−--TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?
588−traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]
589−traverseAndCleanWeakList_ deRef ws f = go ws
590− where go [] = return []
591− go (h:t) = do
592− ma <- deRef h
593− case ma of
594− Just a -> do
595− f a
596− t' <- go t
597− return $ h : t'
598− Nothing -> go t
825+{-# INLINE withIncreasedDepth #-}
826+#ifdef DEBUG
827+withIncreasedDepth :: CanTrace x m => m a -> m a
828+withIncreasedDepth a = do
829+ spiderEnv <- askSpiderEnv
830+ liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) succ
831+ result <- a
832+ liftIO $ modifyIORef' (_spiderEnv_depth spiderEnv) pred
833+ return result
834+#else
835+withIncreasedDepth :: m a -> m a
836+withIncreasedDepth = id
837+#endif
838+
839+type CanTrace x m = (HasSpiderEnv x m, MonadIO m)
840+
841+{-# INLINE tracePropagate #-}
842+tracePropagate :: (CanTrace x m) => String -> m ()
843+tracePropagate = traceWhen debugPropagate
844+
845+{-# INLINE traceSubscribe #-}
846+traceSubscribe :: String -> IO ()
847+traceSubscribe = when debugSubscribe . liftIO . putStrLn
848+
849+{-# INLINE traceInvalidate #-}
850+traceInvalidate :: String -> IO ()
851+traceInvalidate = when debugInvalidate . liftIO . putStrLn
852+
853+{-# INLINE traceWhen #-}
854+traceWhen :: (CanTrace x m) => Bool -> String -> m ()
855+traceWhen b message = traceMWhen b $ return message
856+
857+{-# INLINE traceMWhen #-}
858+traceMWhen :: (CanTrace x m) => Bool -> m String -> m ()
859+traceMWhen b getMessage = when b $ do
860+ message <- getMessage
861+#ifdef DEBUG
862+ spiderEnv <- askSpiderEnv
863+ d <- liftIO $ readIORef $ _spiderEnv_depth spiderEnv
864+#else
865+ let d = 0
866+#endif
867+ liftIO $ putStrLn $ replicate d ' ' <> message
868+
869+whoCreatedIORef :: IORef a -> IO [String]
870+whoCreatedIORef (IORef a) = whoCreated $! a
871+
872+whoCreatedEventSubscribed :: EventSubscribed a -> IO [String]
873+whoCreatedEventSubscribed = \case
874+ EventSubscribedRoot _ -> return ["root"]
875+ EventSubscribedNever -> return ["never"]
876+ EventSubscribedPush subscribed -> whoCreatedIORef $ pushSubscribedCachedSubscribed subscribed
877+ EventSubscribedFan _ subscribed -> whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
878+ EventSubscribedMerge subscribed -> whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
879+ EventSubscribedSwitch subscribed -> whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
880+ EventSubscribedCoincidence subscribed -> whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
881+
882+walkInvalidHeightParents :: EventSubscribed a -> IO [Some EventSubscribed]
883+walkInvalidHeightParents s0 = do
884+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
885+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
886+ when (h == invalidHeight) $ do
887+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) invalidHeightBeingTraversed
888+ modify (Some.This s :)
889+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
890+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) invalidHeight
891+ return subscribers
892+
893+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
894+groupByHead = \case
895+ [] -> []
896+ (x :| xs) : t -> case groupByHead t of
897+ [] -> [(x, xs :| [])]
898+ l@((y, yss) : t')
899+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
900+ | otherwise -> (x, xs :| []) : l
901+
902+listsToForest :: Eq a => [[a]] -> Forest a
903+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
599904
600905-- | Propagate everything at the current height
601−propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]
602−propagate a subscribers = do
603− traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of
604− SubscriberPush compute subscribed -> do
605− when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed
606− occ <- compute a
906+propagate :: a -> SubscriberList a -> EventM x ()
907+propagate a subscribers = withIncreasedDepth $ do
908+ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
909+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
910+ WeakBag.traverse subscribers $ \s -> case s of
911+ SubscriberPush compute subscribed -> {-# SCC "traversePush" #-} do
912+ tracePropagate $ "SubscriberPush" <> showNodeId subscribed
913+ occ <- runComputeM $ compute a
607914 case occ of
608915 Nothing -> return () -- No need to write a Nothing back into the Ref
609916 Just o -> do
610917 liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ
611918 scheduleClear $ pushSubscribedOccurrence subscribed
612− liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))
613− SubscriberMerge k subscribed -> do
614− when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed
919+ propagate o $ pushSubscribedSubscribers subscribed
920+ SubscriberMerge k subscribed -> {-# SCC "traverseMerge" #-} do
921+ tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
615922 oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed
616− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM
923+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge" <> showNodeId subscribed) k (Identity a) oldM
924+ tracePropagate $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
925+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) $! newM
617926 when (DMap.null oldM) $ do -- Only schedule the firing once
618927 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed
619928 --TODO: assertions about height
620929 currentHeight <- getCurrentHeight
621− when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"
930+ when (height <= currentHeight) $ do
931+ myStack <- liftIO $ whoCreatedIORef $ mergeSubscribedCachedSubscribed subscribed
932+ if height /= invalidHeight
933+ then error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
934+ else liftIO $ do
935+ nodesInvolvedInCycle <- walkInvalidHeightParents $ EventSubscribedMerge subscribed
936+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
937+ error $ "Causality loop found:\n" <> drawForest (listsToForest stacks)
622938 scheduleMerge height subscribed
623− SubscriberFan subscribed -> do
939+ SubscriberMergeChange subscribed -> {-# SCC "traverseMergeChange" #-} do
940+ tracePropagate $ "SubscriberMerge" <> showNodeId subscribed
941+ defer $ SomeMergeUpdate a subscribed
942+ SubscriberFan subscribed -> {-# SCC "traverseFan" #-} do
624943 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
625− when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
944+ tracePropagate $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
626945 --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large
627− forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of
946+ forM_ (DMap.toList a) $ \(k :=> Identity v) -> {-# SCC "SubscriberFan" #-} case DMap.lookup k subs of
628947 Nothing -> do
629− when debugPropagate $ liftIO $ putStrLn "No subscriber for key"
948+ tracePropagate "No subscriber for key"
630949 return ()
631− Just (Identity subsubs) -> do
632− _ <- propagate v subsubs --TODO: use the value of this
950+ Just subsubs -> do
951+ propagate v $ _fanSubscribedChildren_list subsubs
633952 return ()
634− --TODO: The following is way too slow to do all the time
635− subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do
636− subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())
637− return $ if null subsubs'
638− then Nothing
639− else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))
640− liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'
641− SubscriberHold h -> do
642− invalidators <- liftIO $ readIORef $ holdInvalidators h
643− when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
644− toAssignRef <- askToAssignRef
645− liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)
646− SubscriberSwitch subscribed -> do
647− when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed
953+ SubscriberHold h -> {-# SCC "traverseHold" #-} propagateSubscriberHold h a
954+ SubscriberHoldIdentity h -> {-# SCC "traverseHoldIdentity" #-} propagateSubscriberHold h a
955+ SubscriberSwitch subscribed -> {-# SCC "traverseSwitch" #-} do
956+ tracePropagate $ "SubscriberSwitch" <> showNodeId subscribed
648957 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
649958 scheduleClear $ switchSubscribedOccurrence subscribed
650− subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed
651− liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs
652− SubscriberCoincidenceOuter subscribed -> do
653− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
959+ propagate a $ switchSubscribedSubscribers subscribed
960+ SubscriberCoincidenceOuter subscribed -> {-# SCC "traverseCoincidenceOuter" #-} do
961+ tracePropagate $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
654962 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
655− when debugPropagate $ liftIO $ putStrLn $ " outerHeight = " <> show outerHeight
963+ tracePropagate $ " outerHeight = " <> show outerHeight
656964 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
657− when debugPropagate $ liftIO $ putStrLn $ " isJust occ = " <> show (isJust occ)
658− when debugPropagate $ liftIO $ putStrLn $ " innerHeight = " <> show innerHeight
965+ tracePropagate $ " isJust occ = " <> show (isJust occ)
966+ tracePropagate $ " innerHeight = " <> show innerHeight
659967 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
660968 scheduleClear $ coincidenceSubscribedInnerParent subscribed
661969 case occ of
662970 Nothing -> do
663971 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
664972 writeIORef (coincidenceSubscribedHeight subscribed) innerHeight
665− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
666− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
973+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
974+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight
667975 Just o -> do -- Since it's already firing, no need to adjust height
668976 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
669977 scheduleClear $ coincidenceSubscribedOccurrence subscribed
670− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
671− SubscriberCoincidenceInner subscribed -> do
672− when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed
673− liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
674− scheduleClear $ coincidenceSubscribedOccurrence subscribed
675− liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))
978+ propagate o $ coincidenceSubscribedSubscribers subscribed
979+ SubscriberCoincidenceInner subscribed -> {-# SCC "traverseCoincidenceInner" #-} do
980+ tracePropagate $ "SubscriberCoincidenceInner" <> showNodeId subscribed
981+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
982+ case occ of
983+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
984+ Nothing -> do
985+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
986+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
987+ propagate a $ coincidenceSubscribedSubscribers subscribed
988+ SubscriberHandle -> {-# SCC "traverseHandle" #-} tracePropagate "SubscriberHandle"
989+
990+{-# INLINE propagateSubscriberHold #-}
991+propagateSubscriberHold :: R.Patch p => Hold p a -> p a -> EventM x ()
992+propagateSubscriberHold h a = do
993+ {-# SCC "trace" #-} traceMWhen debugPropagate $ liftIO $ do
994+ invalidators <- liftIO $ readIORef $ holdInvalidators h
995+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
996+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
997+ case {-# SCC "apply" #-} R.apply a v of
998+ Nothing -> return ()
999+ Just v' -> do
1000+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1001+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1002+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1003+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
6761004
677−data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1005+data SomeResetCoincidence = forall a. SomeResetCoincidence !(EventSubscription a) !(Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
6781006
679−subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)
1007+{-# INLINE subscribeCoincidenceInner #-}
1008+subscribeCoincidenceInner :: CanSubscribe x m => Event a -> Height -> CoincidenceSubscribed a -> m (Maybe a, Height, EventSubscribed a)
6801009subscribeCoincidenceInner o outerHeight subscribedUnsafe = do
6811010 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
682− wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"
683− innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)
684− innerOcc <- liftIO $ getEventSubscribedOcc innerSubd
1011+ subscription@(_, innerSubd) <- subscribe o subInner
1012+ innerOcc <- liftIO $ readEventSubscribed innerSubd
6851013 innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd
6861014 let height = max innerHeight outerHeight
687− emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing
1015+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
6881016 return (innerOcc, height, innerSubd)
6891017
690−readBehavior :: Behavior a -> IO a
691−readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
1018+{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> BehaviorM a #-}
1019+{-# SPECIALIZE readBehaviorUntracked :: Behavior a -> EventM x a #-}
1020+readBehaviorUntracked :: Defer SomeHoldInit m => Behavior a -> m a
1021+readBehaviorUntracked b = do
1022+ holdInits <- getDeferralQueue
1023+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
6921024
693−runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a
694−runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi
1025+runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IORef [SomeHoldInit] -> IO a
1026+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
6951027
6961028askInvalidator :: BehaviorM (Maybe (Weak Invalidator))
697−askInvalidator = liftM (fmap fst) $ BehaviorM ask
1029+askInvalidator = liftM (fmap fst . fst) $ BehaviorM ask
6981030
6991031askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))
700−askParentsRef = liftM (fmap snd) $ BehaviorM ask
1032+askParentsRef = liftM (fmap snd . fst) $ BehaviorM ask
1033+
1034+askBehaviorHoldInits :: BehaviorM (IORef [SomeHoldInit])
1035+askBehaviorHoldInits = liftM snd $ BehaviorM ask
7011036
7021037readBehaviorTracked :: Behavior a -> BehaviorM a
7031038readBehaviorTracked b = case b of
704− BehaviorHold h -> do
705− result <- liftIO $ readIORef $ holdValue h
706− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
707− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
708− liftIO $ touch $ holdSubscriber h
709− return result
1039+ BehaviorHold h -> readHoldTracked h
1040+ BehaviorHoldIdentity h -> readHoldTracked h
7101041 BehaviorConst a -> return a
7111042 BehaviorPull p -> do
7121043 val <- liftIO $ readIORef $ pullValue p
@@ -720,7 +1051,8 @@ readBehaviorTracked b = case b of
7201051 i <- liftIO $ newInvalidatorPull p
7211052 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
7221053 parentsRef <- liftIO $ newIORef []
723− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)
1054+ holdInits <- askBehaviorHoldInits
1055+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
7241056 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
7251057 parents <- liftIO $ readIORef parentsRef
7261058 let subscribed = PullSubscribed
@@ -732,183 +1064,321 @@ readBehaviorTracked b = case b of
7321064 liftIO $ writeIORef (pullValue p) $ Just subscribed
7331065 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
7341066 return a
1067+ BehaviorDyn d -> readHoldTracked =<< getDynHold d
1068+ BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
1069+
1070+{-# INLINE readHoldTracked #-}
1071+readHoldTracked :: Hold p a -> BehaviorM a
1072+readHoldTracked h = do
1073+ result <- liftIO $ readIORef $ holdValue h
1074+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
1075+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
1076+ return result
1077+
1078+{-# INLINE getDynHold #-}
1079+getDynHold :: (Defer SomeHoldInit m, R.Patch p) => Dyn p a -> m (Hold p a)
1080+getDynHold d = do
1081+ mh <- liftIO $ readIORef $ unDyn d
1082+ case mh of
1083+ Right h -> return h
1084+ Left (readV0, v') -> do
1085+ holdInits <- getDeferralQueue
1086+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1087+ h <- hold v0 v'
1088+ liftIO $ writeIORef (unDyn d) $ Right h
1089+ return h
7351090
1091+{-
7361092readEvent :: Event a -> ResultM (Maybe a)
7371093readEvent e = case e of
7381094 EventRoot k r -> liftIO . liftM (coerce . DMap.lookup k) . readIORef $ rootOccurrence r
7391095 EventNever -> return Nothing
7401096 EventPush p -> do
7411097 subscribed <- getPushSubscribed p
742− liftIO $ do
743− result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
744− touch $ pushSubscribedSelf subscribed
745− return result
1098+ liftIO $ readPushSubscribed subscribed
7461099 EventMerge m -> do
7471100 subscribed <- getMergeSubscribed m
748− liftIO $ do
749− result <- readIORef $ mergeSubscribedOccurrence subscribed
750− touch $ mergeSubscribedSelf subscribed
751− return result
1101+ liftIO $ readMergeSubscribed subscribed
7521102 EventFan k f -> do
753− parentOcc <- readEvent $ fanParent f
754− return . coerce $ DMap.lookup k =<< parentOcc
1103+ subscribed <- getFanSubscribed f
1104+ liftIO $ readFanSubscribed k subscribed
7551105 EventSwitch s -> do
7561106 subscribed <- getSwitchSubscribed s
757− liftIO $ do
758− result <- readIORef $ switchSubscribedOccurrence subscribed
759− touch $ switchSubscribedSelf subscribed
760− touch $ switchSubscribedOwnInvalidator subscribed
761− return result
1107+ liftIO $ readSwitchSubscribed subscribed
7621108 EventCoincidence c -> do
7631109 subscribed <- getCoincidenceSubscribed c
764− liftIO $ do
765− result <- readIORef $ coincidenceSubscribedOccurrence subscribed
766− touch $ coincidenceSubscribedOuter subscribed
767− --TODO: do we need to touch the inner subscriber?
768− return result
1110+ liftIO $ readCoincidenceSubscribed subscribed
1111+ EventHold h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1112+ EventDyn d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1113+ EventHoldIdentity h -> liftIO . readEventSubscribed =<< getHoldEventSubscription h
1114+ EventDynIdentity d -> liftIO . readEventSubscribed =<< getHoldEventSubscription =<< getDynHold d
1115+-}
1116+
1117+readEventSubscribed :: EventSubscribed a -> IO (Maybe a)
1118+readEventSubscribed = \case
1119+ EventSubscribedRoot rs -> readRootSubscribed rs
1120+ EventSubscribedNever -> return Nothing
1121+ EventSubscribedPush ps -> readPushSubscribed ps
1122+ EventSubscribedMerge ms -> readMergeSubscribed ms
1123+ EventSubscribedFan k fs -> readFanSubscribed k fs
1124+ EventSubscribedSwitch ss -> readSwitchSubscribed ss
1125+ EventSubscribedCoincidence cs -> readCoincidenceSubscribed cs
1126+
1127+readRootSubscribed :: RootSubscribed a -> IO (Maybe a)
1128+readRootSubscribed = rootSubscribedOccurrence
1129+
1130+readPushSubscribed :: PushSubscribed b a -> IO (Maybe a)
1131+readPushSubscribed subscribed = do
1132+ result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid
1133+ touch $ pushSubscribedSelf subscribed
1134+ return result
1135+
1136+readMergeSubscribed :: MergeSubscribed k -> IO (Maybe (DMap k Identity))
1137+readMergeSubscribed subscribed = do
1138+ result <- readIORef $ mergeSubscribedOccurrence subscribed
1139+ touch $ mergeSubscribedParents subscribed
1140+ return result
1141+
1142+readFanSubscribed :: GCompare k => k a -> FanSubscribed k -> IO (Maybe a)
1143+readFanSubscribed k fs = do
1144+ parentOcc <- readEventSubscribed $ snd $ fanSubscribedParent fs
1145+ return $ coerce $ DMap.lookup k =<< parentOcc
1146+
1147+readSwitchSubscribed :: SwitchSubscribed a -> IO (Maybe a)
1148+readSwitchSubscribed subscribed = do
1149+ result <- readIORef $ switchSubscribedOccurrence subscribed
1150+ touch $ switchSubscribedOwnInvalidator subscribed
1151+ return result
1152+
1153+readCoincidenceSubscribed :: CoincidenceSubscribed a -> IO (Maybe a)
1154+readCoincidenceSubscribed subscribed = do
1155+ result <- readIORef $ coincidenceSubscribedOccurrence subscribed
1156+ touch $ coincidenceSubscribedOuter subscribed
1157+ --TODO: do we need to touch the inner subscriber?
1158+ return result
7691159
7701160-- Always refers to 0
7711161{-# NOINLINE zeroRef #-}
772−zeroRef :: IORef Int
773−zeroRef = unsafePerformIO $ newIORef 0
774−
775−getEventSubscribed :: Event a -> EventM (EventSubscribed a)
776−getEventSubscribed e = case e of
777− EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r
778− EventNever -> return EventSubscribedNever
779− EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
780− EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
781− EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m
782− EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s
783− EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c
784−
1162+zeroRef :: IORef Height
1163+zeroRef = unsafePerformIO $ newIORef zeroHeight
1164+
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
1168+ EventRoot k r -> wrap EventSubscribedRoot $ liftIO . getRootSubscribed k r
1169+ EventNever -> return (Nothing, EventSubscribedNever)
1170+ EventPush p -> wrap EventSubscribedPush $ getPushSubscribed p
1171+ EventFan k f -> wrap (EventSubscribedFan k) $ getFanSubscribed k f
1172+ EventMerge m -> wrap EventSubscribedMerge $ getMergeSubscribed m
1173+ EventSwitch s -> wrap EventSubscribedSwitch $ getSwitchSubscribed s
1174+ EventCoincidence c -> wrap EventSubscribedCoincidence $ getCoincidenceSubscribed c
1175+ EventHold h -> subscribeHoldEvent h sub
1176+ EventDyn j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1177+ EventHoldIdentity h -> subscribeHoldEvent h sub
1178+ EventDynIdentity j -> getDynHold j >>= \h -> subscribeHoldEvent h sub
1179+ where
1180+ wrap :: (t -> EventSubscribed a) -> (Subscriber a -> m (SubscriberListTicket a, t)) -> m (EventSubscription a)
1181+ wrap tag getSpecificSubscribed = do
1182+ (sln, subd) <- getSpecificSubscribed sub
1183+ return (Just sln, tag subd)
1184+
1185+{-# INLINE subscribeHoldEvent #-}
1186+subscribeHoldEvent :: (CanSubscribe x m, R.Patch p) => Hold p a -> Subscriber (p a) -> m (EventSubscription (p a))
1187+subscribeHoldEvent h sub = do
1188+ (_, subd) <- getHoldEventSubscription h
1189+ sln <- liftIO $ subscribeEventSubscribed subd sub
1190+ return (sln, subd)
1191+
1192+{-# INLINE debugSubscribe #-}
7851193debugSubscribe :: Bool
7861194debugSubscribe = False
7871195
788−subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()
789−subscribeEventSubscribed es ws = case es of
1196+{-# INLINE subscribeEventSubscribed #-}
1197+subscribeEventSubscribed :: EventSubscribed a -> Subscriber a -> IO (Maybe (SubscriberListTicket a))
1198+subscribeEventSubscribed es sub = case es of
7901199 EventSubscribedRoot r -> do
791− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"
792− modifyIORef' (rootSubscribedSubscribers r) (ws:)
1200+ traceSubscribe $ "subscribeEventSubscribed Root"
1201+ fmap Just $ subscribeRootSubscribed r sub
7931202 EventSubscribedNever -> do
794− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"
795− return ()
1203+ traceSubscribe $ "subscribeEventSubscribed Never"
1204+ return Nothing
7961205 EventSubscribedPush subscribed -> do
797− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"
798− modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)
1206+ traceSubscribe $ "subscribeEventSubscribed Push"
1207+ fmap Just $ subscribePushSubscribed subscribed sub
7991208 EventSubscribedFan k subscribed -> do
800− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"
801− modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws])
1209+ traceSubscribe $ "subscribeEventSubscribed Fan"
1210+ fmap Just $ subscribeFanSubscribed k subscribed sub
8021211 EventSubscribedMerge subscribed -> do
803− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"
804− modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)
1212+ traceSubscribe $ "subscribeEventSubscribed Merge"
1213+ fmap Just $ subscribeMergeSubscribed subscribed sub
8051214 EventSubscribedSwitch subscribed -> do
806− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"
807− modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)
1215+ traceSubscribe $ "subscribeEventSubscribed Switch"
1216+ fmap Just $ subscribeSwitchSubscribed subscribed sub
8081217 EventSubscribedCoincidence subscribed -> do
809− when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"
810− modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)
1218+ traceSubscribe $ "subscribeEventSubscribed Coincidence"
1219+ fmap Just $ subscribeCoincidenceSubscribed subscribed sub
8111220
812−getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
813−getEventSubscribedOcc es = case es of
814− EventSubscribedRoot r -> rootSubscribedOccurrence r
815− EventSubscribedNever -> return Nothing
816− EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
817− EventSubscribedFan k subscribed -> do
818− parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed
819− let occ = coerce $ DMap.lookup k =<< parentOcc
820− return occ
821− EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed
822− EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed
823− EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed
824−
825−eventSubscribedHeightRef :: EventSubscribed a -> IORef Int
826−eventSubscribedHeightRef es = case es of
1221+{-# INLINE eventSubscribedHeightRef #-}
1222+eventSubscribedHeightRef :: EventSubscribed a -> IORef Height
1223+eventSubscribedHeightRef = \case
8271224 EventSubscribedRoot _ -> zeroRef
8281225 EventSubscribedNever -> zeroRef
8291226 EventSubscribedPush subscribed -> pushSubscribedHeight subscribed
830− EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed
1227+ EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ snd $ fanSubscribedParent subscribed
8311228 EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed
8321229 EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed
8331230 EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed
8341231
835−subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)
836−subscribe e ws = do
837− subd <- getEventSubscribed e
838− liftIO $ subscribeEventSubscribed subd ws
839− return subd
1232+{-# INLINE eventSubscribedHasOwnHeightRef #-}
1233+eventSubscribedHasOwnHeightRef :: EventSubscribed a -> Bool
1234+eventSubscribedHasOwnHeightRef = \case
1235+ EventSubscribedRoot _ -> False
1236+ EventSubscribedNever -> False
1237+ EventSubscribedPush _ -> False
1238+ EventSubscribedFan _ _ -> False
1239+ EventSubscribedMerge _ -> True
1240+ EventSubscribedSwitch _ -> True
1241+ EventSubscribedCoincidence _ -> True
1242+
1243+{-# INLINE eventSubscribedGetParents #-}
1244+eventSubscribedGetParents :: EventSubscribed a -> IO [Some EventSubscribed]
1245+eventSubscribedGetParents = \case
1246+ EventSubscribedRoot _ -> return []
1247+ EventSubscribedNever -> return []
1248+ EventSubscribedPush subscribed -> return [Some.This $ snd $ pushSubscribedParent subscribed]
1249+ EventSubscribedFan _ subscribed -> return [Some.This $ snd $ fanSubscribedParent subscribed]
1250+ EventSubscribedMerge subscribed -> do
1251+ ps <- readIORef $ mergeSubscribedParents subscribed
1252+ return $ fmap (\(_ :=> v) -> Some.This $ snd $ mergeSubscribedParentSubscription v) $ DMap.toList ps
1253+ EventSubscribedSwitch subscribed -> do
1254+ s <- readIORef $ switchSubscribedCurrentParent subscribed
1255+ return [Some.This $ snd s]
1256+ EventSubscribedCoincidence subscribed -> do
1257+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
1258+ let outerParent = Some.This $ snd $ coincidenceSubscribedOuterParent subscribed
1259+ innerParents = maybeToList $ fmap Some.This innerSubscription
1260+ return $ outerParent : innerParents
1261+
1262+type CanSubscribe x m =
1263+ ( HasSpiderEnv x m
1264+ , HasCurrentHeight m
1265+ , Defer SomeHoldInit m, Defer SomeMergeInit m -- The things we need to lazily initialize state
1266+ , Defer SomeClear m -- Wiping out event firings
1267+ , Defer SomeAssignment m -- Updating state
1268+ , Defer SomeResetCoincidence m
1269+ )
1270+
1271+{-# INLINE subscribe #-}
1272+subscribe :: CanSubscribe x m => Event a -> Subscriber a -> m (EventSubscription a)
1273+subscribe = getEventSubscribed
1274+
1275+getRootSubscribed :: GCompare k => k a -> Root k -> Subscriber a -> IO (SubscriberListTicket a, RootSubscribed a)
1276+getRootSubscribed k r sub = do
1277+ mSubscribed <- readIORef $ rootSubscribed r
1278+ case DMap.lookup k mSubscribed of
1279+ Just subscribed -> {-# SCC "hitRoot" #-} do
1280+ sln <- subscribeRootSubscribed subscribed sub
1281+ return (sln, subscribed)
1282+ Nothing -> {-# SCC "missRoot" #-} do
1283+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1284+ let !cached = rootSubscribed r
1285+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1286+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1287+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1288+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1289+ writeIORef uninitRef uninit
1290+ let subscribed = RootSubscribed
1291+ { rootSubscribedKey = k
1292+ , rootSubscribedCachedSubscribed = cached
1293+ , rootSubscribedOccurrence = liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1294+ , rootSubscribedSubscribers = subs
1295+ , rootSubscribedUninit = uninit
1296+ , rootSubscribedWeakSelf = weakSelf
1297+#ifdef DEBUG_NODEIDS
1298+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1299+#endif
1300+ }
1301+ 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
1303+ return (sln, subscribed)
8401304
841−noinlineFalse :: Bool
842−noinlineFalse = False
843−{-# NOINLINE noinlineFalse #-}
1305+cleanupRootSubscribed :: RootSubscribed a -> IO ()
1306+cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1307+ rootSubscribedUninit self
1308+ modifyIORef' cached $ DMap.delete k
8441309
845−getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
846−getRootSubscribed k r = do
847− mSubscribed <- liftIO $ readIORef $ rootSubscribed r
848− case DMap.lookup k mSubscribed of
849− Just subscribed -> return subscribed
850− Nothing -> liftIO $ do
851− subscribersRef <- newIORef []
852− subscribed <- newRootSubscribed (liftM (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
853− -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
854− uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
855− addFinalizer subscribed $ do
856− when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
857−-- putStrLn "Uninit root"
858− uninit
859− liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed
860− return subscribed
1310+{-# INLINE subscribeRootSubscribed #-}
1311+subscribeRootSubscribed :: RootSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1312+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
8611313
8621314-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
863−getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)
864−getPushSubscribed p = do
1315+{-# SPECIALIZE getPushSubscribed :: Push a b -> Subscriber b -> EventM x (SubscriberListTicket b, PushSubscribed a b) #-}
1316+getPushSubscribed :: CanSubscribe x m => Push a b -> Subscriber b -> m (SubscriberListTicket b, PushSubscribed a b)
1317+getPushSubscribed p sub = do
8651318 mSubscribed <- liftIO $ readIORef $ pushSubscribed p
8661319 case mSubscribed of
867− Just subscribed -> return subscribed
868− Nothing -> do -- Not yet subscribed
869− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p
1320+ Just subscribed -> {-# SCC "hitPush" #-} do
1321+ sln <- liftIO $ subscribePushSubscribed subscribed sub
1322+ return (sln, subscribed)
1323+ Nothing -> {-# SCC "missPush" #-} do -- Not yet subscribed
1324+ subscribedRef <- liftIO $ newIORef $ error "getPushSubscribed: subscribed not yet intialized"
1325+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
8701326 s <- liftIO $ newSubscriberPush (pushCompute p) subscribedUnsafe
871− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"
872− subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws
873− parentOcc <- liftIO $ getEventSubscribedOcc subd
874− occ <- liftM join $ mapM (pushCompute p) parentOcc
1327+ subscription@(_, subd) <- subscribe (pushParent p) s
1328+ parentOcc <- liftIO $ readEventSubscribed subd
1329+ occ <- runComputeM $ liftM join $ mapM (pushCompute p) parentOcc
8751330 occRef <- liftIO $ newIORef occ
8761331 when (isJust occ) $ scheduleClear occRef
877− subscribersRef <- liftIO $ newIORef []
1332+ weakSelf <- liftIO $ newIORef $ error "getPushSubscribed: weakSelf not initialized"
1333+ let !cached = pushSubscribed p
1334+ (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupPushSubscribed
8781335 let subscribed = PushSubscribed
879− { pushSubscribedOccurrence = occRef
1336+ { pushSubscribedCachedSubscribed = cached
1337+ , pushSubscribedOccurrence = occRef
8801338 , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref
881− , pushSubscribedSubscribers = subscribersRef
882− , pushSubscribedSelf = unsafeCoerce s
883− , pushSubscribedParent = subd
1339+ , pushSubscribedSubscribers = subs
1340+ , pushSubscribedSelf = s
1341+ , pushSubscribedWeakSelf = weakSelf
1342+ , pushSubscribedParent = subscription
8841343#ifdef DEBUG_NODEIDS
8851344 , pushSubscribedNodeId = unsafeNodeId p
8861345#endif
8871346 }
1347+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
1348+ liftIO $ writeIORef subscribedRef subscribed
8881349 liftIO $ writeIORef (pushSubscribed p) $ Just subscribed
889− return subscribed
1350+ return (sln, subscribed)
1351+
1352+cleanupPushSubscribed :: PushSubscribed a b -> IO ()
1353+cleanupPushSubscribed self = do
1354+ unsubscribe $ pushSubscribedParent self
1355+ writeIORef (pushSubscribedCachedSubscribed self) Nothing
1356+
1357+{-# INLINE subscribePushSubscribed #-}
1358+subscribePushSubscribed :: PushSubscribed a b -> Subscriber b -> IO (SubscriberListTicket b)
1359+subscribePushSubscribed subscribed sub = WeakBag.insert sub (pushSubscribedSubscribers subscribed) (pushSubscribedWeakSelf subscribed) cleanupPushSubscribed
8901360
891−getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)
892−getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
1361+{-# SPECIALIZE getMergeSubscribed :: GCompare k => Merge k -> Subscriber (DMap k Identity) -> EventM x (SubscriberListTicket (DMap k Identity), MergeSubscribed k) #-}
1362+getMergeSubscribed :: forall x k m. (CanSubscribe x m, GCompare k) => Merge k -> Subscriber (DMap k Identity) -> m (SubscriberListTicket (DMap k Identity), MergeSubscribed k)
1363+getMergeSubscribed m sub = do
8931364 mSubscribed <- liftIO $ readIORef $ mergeSubscribed m
8941365 case mSubscribed of
895− Just subscribed -> return subscribed
896− Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do
1366+ Just subscribed -> {-# SCC "hitMerge" #-} do
1367+ sln <- liftIO $ subscribeMergeSubscribed subscribed sub
1368+ return (sln, subscribed)
1369+ Nothing -> {-# SCC "missMerge" #-} do
8971370 subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"
8981371 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
899− s <- liftIO $ newBox subscribedUnsafe
900− ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"
901− subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do
902− parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws
903− parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd
904− height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
905− return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (\x -> k :=> Identity x) parentOcc, height, k :=> parentSubd)
906− let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers
907− subscriberHeights = map (\(_, _, x, _) -> x) subscribers
908− myHeight =
909− if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
910− then invalidHeight
911− else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here
1372+ initialParents <- readBehaviorUntracked $ current $ mergeParents m
1373+ subscribers :: [(Maybe (DSum k Identity), Height, DSum k (MergeSubscribedParent k))] <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1374+ s <- liftIO $ newSubscriberMerge k subscribedUnsafe
1375+ subscription@(_, parentSubd) <- subscribe e s
1376+ parentOcc <- liftIO $ readEventSubscribed parentSubd
1377+ height <- liftIO $ readIORef $ eventSubscribedHeightRef parentSubd
1378+ return $ (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> (MergeSubscribedParent subscription s))
1379+ let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(x, _, _) -> x) subscribers
1380+ subscriberHeights = map (\(_, x, _) -> x) subscribers
1381+ myHeight = succHeight $ foldr maxHeight zeroHeight subscriberHeights
9121382 currentHeight <- getCurrentHeight
9131383 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
9141384 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
@@ -919,112 +1389,162 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do
9191389 when (isJust occ) $ scheduleClear occRef
9201390 accumRef <- liftIO $ newIORef accum
9211391 heightRef <- liftIO $ newIORef myHeight
922− subsRef <- liftIO $ newIORef []
923− let subscribed = MergeSubscribed
924− { mergeSubscribedOccurrence = occRef
1392+ weakSelf <- liftIO $ newIORef $ error "getMergeSubscribed: weakSelf not yet initialized"
1393+ (subs, sln) <- liftIO $ WeakBag.singleton sub weakSelf cleanupMergeSubscribed
1394+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1395+ parentsRef <- liftIO $ newIORef $ DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1396+ let !subscribed = MergeSubscribed
1397+ { mergeSubscribedCachedSubscribed = mergeSubscribed m
1398+ , mergeSubscribedOccurrence = occRef
9251399 , mergeSubscribedAccum = accumRef
9261400 , mergeSubscribedHeight = heightRef
927− , mergeSubscribedSubscribers = subsRef
928− , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?
929− , mergeSubscribedParents = DMap.fromDistinctAscList $ map (\(_, _, _, x) -> x) subscribers
1401+ , mergeSubscribedSubscribers = subs
1402+ , mergeSubscribedChange = changeSubdRef
1403+ , mergeSubscribedParents = parentsRef
1404+ , mergeSubscribedWeakSelf = weakSelf
9301405#ifdef DEBUG_NODEIDS
9311406 , mergeSubscribedNodeId = unsafeNodeId m
9321407#endif
9331408 }
1409+ defer $ SomeMergeInit subscribed $ updated $ mergeParents m
9341410 liftIO $ writeIORef subscribedRef subscribed
935− return subscribed
936− where emptyMergeSubscribed = do --TODO: This should never happen
937− occRef <- liftIO $ newIORef Nothing
938− accumRef <- liftIO $ newIORef DMap.empty
939− subsRef <- liftIO $ newIORef []
940− return $ MergeSubscribed
941− { mergeSubscribedOccurrence = occRef
942− , mergeSubscribedAccum = accumRef
943− , mergeSubscribedHeight = zeroRef
944− , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak
945− , mergeSubscribedSelf = unsafeCoerce ()
946− , mergeSubscribedParents = DMap.empty
947−#ifdef DEBUG_NODEIDS
948− , mergeSubscribedNodeId = -1
949−#endif
950− }
951−
952−getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)
953−getFanSubscribed f = do
1411+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "MergeSubscribed"
1412+ liftIO $ writeIORef (mergeSubscribed m) $ Just subscribed
1413+ return (sln, subscribed)
1414+
1415+cleanupMergeSubscribed :: MergeSubscribed k -> IO ()
1416+cleanupMergeSubscribed subscribed = do
1417+ parents <- readIORef $ mergeSubscribedParents subscribed
1418+ forM_ (DMap.toList parents) $ \(_ :=> msp) -> unsubscribe $ mergeSubscribedParentSubscription msp
1419+ -- Not necessary, because this whole MergeSubscribed is dead: writeIORef (mergeSubscribedParents subscribed) DMap.empty
1420+ writeIORef (mergeSubscribedCachedSubscribed subscribed) Nothing -- Get rid of the cached subscribed
1421+
1422+{-# INLINE subscribeMergeSubscribed #-}
1423+subscribeMergeSubscribed :: MergeSubscribed k -> Subscriber (DMap k Identity) -> IO (SubscriberListTicket (DMap k Identity))
1424+subscribeMergeSubscribed subscribed sub = WeakBag.insert sub (mergeSubscribedSubscribers subscribed) (mergeSubscribedWeakSelf subscribed) cleanupMergeSubscribed
1425+
1426+{-# SPECIALIZE getFanSubscribed :: GCompare k => k a -> Fan k -> Subscriber a -> EventM x (SubscriberListTicket a, FanSubscribed k) #-}
1427+getFanSubscribed :: (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m, GCompare k) => k a -> Fan k -> Subscriber a -> m (SubscriberListTicket a, FanSubscribed k)
1428+getFanSubscribed k f sub = do
9541429 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
9551430 case mSubscribed of
956− Just subscribed -> return subscribed
957− Nothing -> do
958− subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f
959− sub <- liftIO $ newSubscriberFan subscribedUnsafe
960− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"
961− subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub
962− subscribersRef <- liftIO $ newIORef DMap.empty
1431+ Just subscribed -> {-# SCC "hitFan" #-} do
1432+ sln <- liftIO $ subscribeFanSubscribed k subscribed sub
1433+ return (sln, subscribed)
1434+ Nothing -> {-# SCC "missFan" #-} do
1435+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1436+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1437+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1438+ subscription <- subscribe (fanParent f) s
1439+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1440+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1441+ subscribersRef <- liftIO $ newIORef $ DMap.singleton k $ FanSubscribedChildren subsForK weakSelf
9631442 let subscribed = FanSubscribed
964− { fanSubscribedParent = subd
1443+ { fanSubscribedCachedSubscribed = fanSubscribed f
1444+ , fanSubscribedParent = subscription
9651445 , fanSubscribedSubscribers = subscribersRef
966− , fanSubscribedSelf = sub
9671446#ifdef DEBUG_NODEIDS
9681447 , fanSubscribedNodeId = unsafeNodeId f
9691448#endif
9701449 }
1450+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug (k, subscribed) "FanSubscribed"
1451+ liftIO $ writeIORef subscribedRef subscribed
9711452 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
972− return subscribed
973−
974−getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)
975−getSwitchSubscribed s = do
1453+ return (slnForSub, subscribed)
1454+
1455+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed k) -> IO ()
1456+cleanupFanSubscribed (k, subscribed) = do
1457+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1458+ let reducedSubscribers = DMap.delete k subscribers
1459+ if DMap.null reducedSubscribers
1460+ then do
1461+ unsubscribe $ fanSubscribedParent subscribed
1462+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1463+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1464+ else writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1465+
1466+{-# INLINE subscribeFanSubscribed #-}
1467+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed k -> Subscriber a -> IO (SubscriberListTicket a)
1468+subscribeFanSubscribed k subscribed sub = do
1469+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1470+ case DMap.lookup k subscribers of
1471+ Nothing -> do
1472+ weakSelf <- newIORef =<< mkWeakPtrWithDebug (k, subscribed) "FanSubscribed"
1473+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1474+ writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeEventSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list weakSelf) subscribers
1475+ return sln
1476+ Just (FanSubscribedChildren list weakSelf) -> WeakBag.insert sub list weakSelf cleanupFanSubscribed
1477+
1478+{-# SPECIALIZE getSwitchSubscribed :: Switch a -> Subscriber a -> EventM x (SubscriberListTicket a, SwitchSubscribed a) #-}
1479+getSwitchSubscribed :: (Defer SomeHoldInit m, Defer SomeAssignment m, Defer SomeMergeInit m, Defer SomeClear m, Defer SomeResetCoincidence m, HasCurrentHeight m, HasSpiderEnv x m) => Switch a -> Subscriber a -> m (SubscriberListTicket a, SwitchSubscribed a)
1480+getSwitchSubscribed s sub = do
9761481 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
9771482 case mSubscribed of
978− Just subscribed -> return subscribed
979− Nothing -> do
1483+ Just subscribed -> {-# SCC "hitSwitch" #-} do
1484+ sln <- liftIO $ subscribeSwitchSubscribed subscribed sub
1485+ return (sln, subscribed)
1486+ Nothing -> {-# SCC "missSwitch" #-} do
9801487 subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
9811488 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
9821489 i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
983− sub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1490+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
9841491 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
9851492 wiRef <- liftIO $ newIORef wi
986− wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"
987− selfWeakRef <- liftIO $ newIORef wsub
9881493 parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
989− e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)
990− subd <- subscribe e $ WeakSubscriberSimple wsub
991− subdRef <- liftIO $ newIORef subd
992− parentOcc <- liftIO $ getEventSubscribedOcc subd
1494+ holdInits <- getDeferralQueue
1495+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1496+ subscription@(_, subd) <- subscribe e mySub
1497+ subscriptionRef <- liftIO $ newIORef subscription
1498+ parentOcc <- liftIO $ readEventSubscribed subd
9931499 occRef <- liftIO $ newIORef parentOcc
9941500 when (isJust parentOcc) $ scheduleClear occRef
9951501 heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)
996− subscribersRef <- liftIO $ newIORef []
997− let subscribed = SwitchSubscribed
998− { switchSubscribedOccurrence = occRef
1502+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1503+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1504+ let !subscribed = SwitchSubscribed
1505+ { switchSubscribedCachedSubscribed = switchSubscribed s
1506+ , switchSubscribedOccurrence = occRef
9991507 , switchSubscribedHeight = heightRef
1000− , switchSubscribedSubscribers = subscribersRef
1001− , switchSubscribedSelf = sub
1002− , switchSubscribedSelfWeak = selfWeakRef
1508+ , switchSubscribedSubscribers = subs
10031509 , switchSubscribedOwnInvalidator = i
10041510 , switchSubscribedOwnWeakInvalidator = wiRef
10051511 , switchSubscribedBehaviorParents = parentsRef
10061512 , switchSubscribedParent = switchParent s
1007− , switchSubscribedCurrentParent = subdRef
1513+ , switchSubscribedCurrentParent = subscriptionRef
1514+ , switchSubscribedWeakSelf = weakSelf
10081515#ifdef DEBUG_NODEIDS
10091516 , switchSubscribedNodeId = unsafeNodeId s
10101517#endif
10111518 }
1519+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
10121520 liftIO $ writeIORef subscribedRef subscribed
10131521 liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1014− return subscribed
1522+ return (slnForSub, subscribed)
1523+
1524+cleanupSwitchSubscribed :: SwitchSubscribed a -> IO ()
1525+cleanupSwitchSubscribed subscribed = do
1526+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1527+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1528+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1529+
1530+{-# INLINE subscribeSwitchSubscribed #-}
1531+subscribeSwitchSubscribed :: SwitchSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1532+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
10151533
1016−getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)
1017−getCoincidenceSubscribed c = do
1534+{-# SPECIALIZE getCoincidenceSubscribed :: Coincidence a -> Subscriber a -> EventM x (SubscriberListTicket a, CoincidenceSubscribed a) #-}
1535+getCoincidenceSubscribed :: forall x a m. (Defer SomeAssignment m, Defer SomeHoldInit m, Defer SomeMergeInit m, Defer SomeClear m, HasCurrentHeight m, Defer SomeResetCoincidence m, HasSpiderEnv x m) => Coincidence a -> Subscriber a -> m (SubscriberListTicket a, CoincidenceSubscribed a)
1536+getCoincidenceSubscribed c sub = do
10181537 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
10191538 case mSubscribed of
1020− Just subscribed -> return subscribed
1021− Nothing -> do
1539+ Just subscribed -> {-# SCC "hitCoincidence" #-} do
1540+ sln <- liftIO $ subscribeCoincidenceSubscribed subscribed sub
1541+ return (sln, subscribed)
1542+ Nothing -> {-# SCC "missCoincidence" #-} do
10221543 subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
10231544 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
10241545 subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1025− wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"
1026− outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter
1027− outerOcc <- liftIO $ getEventSubscribedOcc outerSubd
1546+ outerSubscription@(_, outerSubd) <- subscribe (coincidenceParent c) subOuter
1547+ outerOcc <- liftIO $ readEventSubscribed outerSubd
10281548 outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd
10291549 (occ, height, mInnerSubd) <- case outerOcc of
10301550 Nothing -> return (Nothing, outerHeight, Nothing)
@@ -1036,23 +1556,37 @@ getCoincidenceSubscribed c = do
10361556 heightRef <- liftIO $ newIORef height
10371557 innerSubdRef <- liftIO $ newIORef mInnerSubd
10381558 scheduleClear innerSubdRef
1039− subscribersRef <- liftIO $ newIORef []
1559+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1560+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
10401561 let subscribed = CoincidenceSubscribed
1041− { coincidenceSubscribedOccurrence = occRef
1562+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1563+ , coincidenceSubscribedOccurrence = occRef
10421564 , coincidenceSubscribedHeight = heightRef
1043− , coincidenceSubscribedSubscribers = subscribersRef
1565+ , coincidenceSubscribedSubscribers = subs
10441566 , coincidenceSubscribedOuter = subOuter
1045− , coincidenceSubscribedOuterParent = outerSubd
1567+ , coincidenceSubscribedOuterParent = outerSubscription
10461568 , coincidenceSubscribedInnerParent = innerSubdRef
1569+ , coincidenceSubscribedWeakSelf = weakSelf
10471570#ifdef DEBUG_NODEIDS
10481571 , coincidenceSubscribedNodeId = unsafeNodeId c
10491572#endif
10501573 }
1574+ liftIO $ writeIORef weakSelf =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
10511575 liftIO $ writeIORef subscribedRef subscribed
10521576 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1053− return subscribed
1577+ return (slnForSub, subscribed)
1578+
1579+cleanupCoincidenceSubscribed :: CoincidenceSubscribed a -> IO ()
1580+cleanupCoincidenceSubscribed subscribed = do
1581+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1582+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1583+
1584+{-# INLINE subscribeCoincidenceSubscribed #-}
1585+subscribeCoincidenceSubscribed :: CoincidenceSubscribed a -> Subscriber a -> IO (SubscriberListTicket a)
1586+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
10541587
1055−merge :: GCompare k => DMap k Event -> Event (DMap k Identity)
1588+{-# INLINE merge #-}
1589+merge :: GCompare k => Dynamic R.PatchDMap (DMap k Event) -> Event (DMap k Identity)
10561590merge m = EventMerge $ Merge
10571591 { mergeParents = m
10581592 , mergeSubscribed = unsafeNewIORef m Nothing
@@ -1068,55 +1602,101 @@ fan e =
10681602 }
10691603 in EventSelector $ \k -> EventFan k f
10701604
1605+{- SPECIALIZE runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x () #-}
1606+--runHoldInits :: (CanSubscribe x m, Defer SomeMergeUpdate m) => IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> m ()
1607+runHoldInits :: IORef [SomeHoldInit] -> IORef [SomeMergeInit] -> EventM x ()
1608+runHoldInits holdInitRef mergeInitRef = do
1609+ holdInits <- liftIO $ readIORef holdInitRef
1610+ mergeInits <- liftIO $ readIORef mergeInitRef
1611+ if null holdInits && null mergeInits then return () else do
1612+ liftIO $ writeIORef holdInitRef []
1613+ liftIO $ writeIORef mergeInitRef []
1614+ mapM_ initHold holdInits
1615+ mapM_ initMerge mergeInits
1616+ runHoldInits holdInitRef mergeInitRef
1617+
1618+{- SPECIALIZE initHold :: SomeHoldInit -> EventM x () #-}
1619+--initHold :: CanSubscribe x m => SomeHoldInit -> m ()
1620+initHold :: SomeHoldInit -> EventM x ()
1621+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
1622+
1623+{- SPECIALIZE initMerge :: SomeMergeInit -> EventM x () #-}
1624+--initMerge :: (CanSubscribe x m, Defer SomeMergeUpdate m) => SomeMergeInit -> m ()
1625+initMerge :: SomeMergeInit -> EventM x ()
1626+initMerge (SomeMergeInit subscribed changed) = do
1627+ changeSub <- liftIO $ newSubscriberMergeChange subscribed
1628+ (_, changeSubd) <- subscribe changed changeSub
1629+ change <- liftIO $ readEventSubscribed changeSubd
1630+ forM_ change $ \c -> defer $ SomeMergeUpdate c subscribed
1631+ liftIO $ writeIORef (mergeSubscribedChange subscribed) (changeSub, changeSubd)
1632+
10711633-- | Run an event action outside of a frame
1072−runFrame :: EventM a -> IO a
1073−runFrame a = do
1634+runFrame :: EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
1635+runFrame a = SpiderHost $ ask >>= \spiderEnv -> lift $ do
1636+ -- Clear out pending unsubscriptions; these will need to happen eventually anyway, and might cause us a lot of extra work during the frame, so get rid of them now
1637+ pendingCleanups <- atomicModifyIORef (_spiderEnv_cleanups spiderEnv) $ \x -> ([], x)
1638+ {-# SCC "cleanups" #-} sequence_ pendingCleanups
10741639 toAssignRef <- newIORef [] -- This should only actually get used when events are firing
10751640 holdInitRef <- newIORef []
1076− heightRef <- newIORef 0
1641+ mergeUpdateRef <- newIORef []
1642+ mergeInitRef <- newIORef []
1643+ heightRef <- newIORef zeroHeight
10771644 toClearRef <- newIORef []
10781645 toClearRootRef <- newIORef []
10791646 coincidenceInfosRef <- newIORef []
10801647 delayedRef <- liftIO $ newIORef IntMap.empty
1081− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do
1082− result <- a
1083− let runHoldInits = do
1084− holdInits <- liftIO $ readIORef holdInitRef
1085− if null holdInits then return () else do
1086− liftIO $ writeIORef holdInitRef []
1087− forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h
1088− runHoldInits
1089− runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1090− return result
1648+ let env = EventEnv spiderEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef
1649+ let go = do
1650+ result <- a
1651+ runHoldInits holdInitRef mergeInitRef -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
1652+ return result
1653+ result <- runEventM go env
10911654 toClear <- readIORef toClearRef
1092− forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1655+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
10931656 toClearRoot <- readIORef toClearRootRef
1094− forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty
1657+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref DMap.empty
10951658 toAssign <- readIORef toAssignRef
10961659 toReconnectRef <- newIORef []
1097− forM_ toAssign $ \(SomeAssignment h v) -> do
1098− writeIORef (holdValue h) v
1099− writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)
11001660 coincidenceInfos <- readIORef coincidenceInfosRef
1101− forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do
1102− touch subInner
1103− finalize wsubInner
1104− mapM_ invalidateCoincidenceHeight mcs
1661+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
1662+ writeIORef vRef v
1663+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
1664+ writeIORef iRef =<< invalidate toReconnectRef =<< readIORef iRef
1665+ mergeUpdates <- readIORef mergeUpdateRef
1666+ writeIORef mergeUpdateRef []
1667+ let updateMerge :: SomeMergeUpdate -> IO [SomeEventSubscription]
1668+ updateMerge (SomeMergeUpdate (R.PatchDMap p) m) = do
1669+ oldParents <- readIORef $ mergeSubscribedParents m
1670+ let f (subscriptionsToKill, ps) (k :=> Compose me) = do
1671+ (mOldSubd, newPs) <- case me of
1672+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1673+ Just e -> do
1674+ s <- liftIO $ newSubscriberMerge k m
1675+ subscription <- subscribe e s
1676+ let newParent = MergeSubscribedParent subscription s
1677+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1678+ liftIO $ invalidateMergeHeight k m
1679+ 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
1681+ writeIORef (mergeSubscribedParents m) $! newParents
1682+ return subscriptionsToKill
1683+ mergeSubscriptionsToKill <- concat <$> mapM updateMerge mergeUpdates
11051684 toReconnect <- readIORef toReconnectRef
1106− forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1107− wsub <- readIORef $ switchSubscribedSelfWeak subscribed
1108− finalize wsub
1685+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
1686+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
11091687 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
1688+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
11101689 finalize wi
11111690 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
11121691 wi' <- mkWeakPtrWithDebug i "wi'"
1692+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) wi'
11131693 writeIORef (switchSubscribedBehaviorParents subscribed) []
1114− e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))
1694+ writeIORef holdInitRef [] --TODO: Should we reuse this?
1695+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) holdInitRef
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
11151697 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
1116− sub <- evaluate $ switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk
1117− wsub' <- mkWeakPtrWithDebug sub "wsub'"
1118− writeIORef (switchSubscribedSelfWeak subscribed) wsub'
1119− subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --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
1698+ 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
11201700 {-
11211701 stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
11221702 liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
@@ -1124,111 +1704,152 @@ runFrame a = do
11241704 EventNever -> "EventNever"
11251705 _ -> "something else"
11261706 -}
1127− writeIORef (switchSubscribedCurrentParent subscribed) subd'
1707+ writeIORef (switchSubscribedCurrentParent subscribed) subscription
11281708 parentHeight <- readIORef $ eventSubscribedHeightRef subd'
11291709 myHeight <- readIORef $ switchSubscribedHeight subscribed
1130− if parentHeight == myHeight then return () else do
1710+ when (parentHeight /= myHeight) $ do
11311711 writeIORef (switchSubscribedHeight subscribed) parentHeight
1132− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1133− forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1712+ WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1713+ return $ SomeEventSubscription oldSubscription
1714+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
1715+ unsubscribe subscription
1716+ mapM_ invalidateCoincidenceHeight mcs
1717+ forM_ mergeSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1718+ forM_ switchSubscriptionsToKill $ \(SomeEventSubscription oldSubscription) -> liftIO $ unsubscribe oldSubscription
1719+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
1720+ forM_ mergeUpdates $ \(SomeMergeUpdate _ m) -> recalculateMergeHeight m
11341721 forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
1135− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1722+ WeakBag.traverse (switchSubscribedSubscribers subscribed) recalculateSubscriberHeight
11361723 return result
11371724
1138−invalidHeight :: Int
1139−invalidHeight = -1000
1140−
1141−invalidateSubscriberHeight :: WeakSubscriber a -> IO ()
1142−invalidateSubscriberHeight ws = do
1143− ms <- deRefWeakSubscriber ws
1144− case ms of
1145− Nothing -> return () --TODO: cleanup?
1146− Just s -> case s of
1147− SubscriberPush _ subscribed -> do
1148− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1149− mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1150− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1151− SubscriberMerge _ subscribed -> do
1152− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1153− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1154− when (oldHeight /= invalidHeight) $ do
1155− writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight
1156− mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1157− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1158− SubscriberFan subscribed -> do
1159− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1160− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1161− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1162− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1163− SubscriberHold _ -> return ()
1164− SubscriberSwitch subscribed -> do
1165− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1166− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1167− when (oldHeight /= invalidHeight) $ do
1168− writeIORef (switchSubscribedHeight subscribed) $ invalidHeight
1169− mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1170− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1171− SubscriberCoincidenceOuter subscribed -> do
1172− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1173− invalidateCoincidenceHeight subscribed
1174− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1175− SubscriberCoincidenceInner subscribed -> do
1176− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1177− invalidateCoincidenceHeight subscribed
1178− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1725+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
1726+
1727+{-# INLINE zeroHeight #-}
1728+zeroHeight :: Height
1729+zeroHeight = Height 0
1730+
1731+{-# INLINE invalidHeight #-}
1732+invalidHeight :: Height
1733+invalidHeight = Height (-1000)
1734+
1735+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
1736+{-# INLINE invalidHeightBeingTraversed #-}
1737+invalidHeightBeingTraversed :: Height
1738+invalidHeightBeingTraversed = Height (-1001)
1739+
1740+{-# INLINE succHeight #-}
1741+succHeight :: Height -> Height
1742+succHeight h@(Height a) =
1743+ if h == invalidHeight
1744+ then invalidHeight
1745+ else Height $ succ a
1746+
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
1757+ SubscriberPush _ subscribed -> do
1758+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1759+ WeakBag.traverse (pushSubscribedSubscribers subscribed) invalidateSubscriberHeight
1760+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1761+ SubscriberMerge k subscribed -> do
1762+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1763+ invalidateMergeHeight k subscribed
1764+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1765+ SubscriberMergeChange _ -> return () -- Doesn't affect the height of the merge, because its changes are delayed
1766+ SubscriberFan subscribed -> do
1767+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1768+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1769+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) invalidateSubscriberHeight
1770+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1771+ SubscriberHold _ -> return ()
1772+ SubscriberHoldIdentity _ -> return ()
1773+ SubscriberSwitch subscribed -> do
1774+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1775+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
1776+ when (oldHeight /= invalidHeight) $ do
1777+ writeIORef (switchSubscribedHeight subscribed) invalidHeight
1778+ WeakBag.traverse (switchSubscribedSubscribers subscribed) invalidateSubscriberHeight
1779+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1780+ SubscriberCoincidenceOuter subscribed -> do
1781+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1782+ invalidateCoincidenceHeight subscribed
1783+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1784+ SubscriberCoincidenceInner subscribed -> do
1785+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1786+ invalidateCoincidenceHeight subscribed
1787+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1788+ SubscriberHandle -> return ()
1789+
1790+--TODO: Actually use the key
1791+invalidateMergeHeight :: k a -> MergeSubscribed k -> IO ()
1792+invalidateMergeHeight _ subscribed = do
1793+ oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1794+ when (oldHeight /= invalidHeight) $ do
1795+ 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
1803+ 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
11791807
11801808invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
11811809invalidateCoincidenceHeight subscribed = do
11821810 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
11831811 when (oldHeight /= invalidHeight) $ do
1184− writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight
1185− mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)
1812+ writeIORef (coincidenceSubscribedHeight subscribed) invalidHeight
1813+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) invalidateSubscriberHeight
11861814
11871815--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
11881816
1189−recalculateSubscriberHeight :: WeakSubscriber a -> IO ()
1190−recalculateSubscriberHeight ws = do
1191− ms <- deRefWeakSubscriber ws
1192− case ms of
1193− Nothing -> return () --TODO: cleanup?
1194− Just s -> case s of
1195− SubscriberPush _ subscribed -> do
1196− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1197− mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)
1198− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1199− SubscriberMerge _ subscribed -> do
1200− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1201− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1202− when (oldHeight == invalidHeight) $ do
1203− height <- calculateMergeHeight subscribed
1204− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1205− 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
1206− writeIORef (mergeSubscribedHeight subscribed) height
1207− mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)
1208− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1209− SubscriberFan subscribed -> do
1210− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1211− subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1212− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())
1213− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1214− SubscriberHold _ -> return ()
1215− SubscriberSwitch subscribed -> do
1216− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
1217− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1218− when (oldHeight == invalidHeight) $ do
1219− height <- calculateSwitchHeight subscribed
1220− when (height /= invalidHeight) $ do
1221− writeIORef (switchSubscribedHeight subscribed) height
1222− mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)
1223− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1224− SubscriberCoincidenceOuter subscribed -> do
1225− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1226− void $ recalculateCoincidenceHeight subscribed
1227− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1228− SubscriberCoincidenceInner subscribed -> do
1229− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1230− void $ recalculateCoincidenceHeight subscribed
1231− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1817+recalculateSubscriberHeight :: Subscriber a -> IO ()
1818+recalculateSubscriberHeight s = case s of
1819+ SubscriberPush _ subscribed -> do
1820+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed
1821+ WeakBag.traverse (pushSubscribedSubscribers subscribed) recalculateSubscriberHeight
1822+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"
1823+ SubscriberMerge _ subscribed -> do
1824+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed
1825+ recalculateMergeHeight subscribed
1826+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"
1827+ SubscriberMergeChange _ -> return ()
1828+ SubscriberFan subscribed -> do
1829+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
1830+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1831+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) recalculateSubscriberHeight
1832+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
1833+ SubscriberHold _ -> return ()
1834+ SubscriberHoldIdentity _ -> return ()
1835+ SubscriberSwitch subscribed -> do
1836+ 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
1843+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
1844+ SubscriberCoincidenceOuter subscribed -> do
1845+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
1846+ recalculateCoincidenceHeight subscribed
1847+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
1848+ SubscriberCoincidenceInner subscribed -> do
1849+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
1850+ recalculateCoincidenceHeight subscribed
1851+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
1852+ SubscriberHandle -> return ()
12321853
12331854recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()
12341855recalculateCoincidenceHeight subscribed = do
@@ -1237,49 +1858,26 @@ recalculateCoincidenceHeight subscribed = do
12371858 height <- calculateCoincidenceHeight subscribed
12381859 when (height /= invalidHeight) $ do
12391860 writeIORef (coincidenceSubscribedHeight subscribed) height
1240− mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones
1861+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) recalculateSubscriberHeight --TODO: This should probably be mandatory, just like with the merge and switch ones
12411862
1242−calculateMergeHeight :: MergeSubscribed k -> IO Int
1243−calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do
1244− heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do
1245− readIORef $ eventSubscribedHeightRef es
1246− return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'
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
12471870
1248−calculateSwitchHeight :: SwitchSubscribed a -> IO Int
1249−calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)
1871+calculateSwitchHeight :: SwitchSubscribed a -> IO Height
1872+calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef . snd =<< readIORef (switchSubscribedCurrentParent subscribed)
12501873
1251−calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int
1874+calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Height
12521875calculateCoincidenceHeight subscribed = do
1253− outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed
1254− innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
1876+ outerHeight <- readIORef $ eventSubscribedHeightRef $ snd $ coincidenceSubscribedOuterParent subscribed
1877+ innerHeight <- maybe (return zeroHeight) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)
12551878 return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
12561879
1257−{-
1258−recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int
1259−recalculateEventSubscribedHeight es = case es of
1260− EventSubscribedRoot _ -> return 0
1261− EventSubscribedNever -> return 0
1262− EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed
1263− EventSubscribedMerge subscribed -> do
1264− oldHeight <- readIORef $ mergeSubscribedHeight subscribed
1265− if oldHeight /= invalidHeight then return oldHeight else do
1266− height <- calculateMergeHeight subscribed
1267− writeIORef (mergeSubscribedHeight subscribed) height
1268− return height
1269− EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed
1270− EventSubscribedSwitch subscribed -> do
1271− oldHeight <- readIORef $ switchSubscribedHeight subscribed
1272− if oldHeight /= invalidHeight then return oldHeight else do
1273− height <- calculateSwitchHeight subscribed
1274− writeIORef (switchSubscribedHeight subscribed) height
1275− return height
1276− EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed
1277−-}
1278−
1279−data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)
1280−
1281−debugInvalidate :: Bool
1282−debugInvalidate = False
1880+data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed a)
12831881
12841882invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)
12851883invalidate toReconnectRef wis = do
@@ -1287,19 +1885,19 @@ invalidate toReconnectRef wis = do
12871885 mi <- deRefWeak wi
12881886 case mi of
12891887 Nothing -> do
1290− when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"
1888+ traceInvalidate "invalidate Dead"
12911889 return () --TODO: Should we clean this up here?
12921890 Just i -> do
12931891 finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
12941892 case i of
12951893 InvalidatorPull p -> do
1296− when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"
1894+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
12971895 mVal <- readIORef $ pullValue p
12981896 forM_ mVal $ \val -> do
12991897 writeIORef (pullValue p) Nothing
13001898 writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
13011899 InvalidatorSwitch subscribed -> do
1302− when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"
1900+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
13031901 modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
13041902 return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them
13051903
@@ -1307,83 +1905,220 @@ invalidate toReconnectRef wis = do
13071905-- Reflex integration
13081906--------------------------------------------------------------------------------
13091907
1310−data Spider
1908+type Spider = SpiderEnv Global
13111909
1312−instance R.Reflex Spider where
1313− newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1314− newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }
1315− type PullM Spider = BehaviorM
1316− type PushM Spider = EventM
1317− {-# INLINE never #-}
1318− {-# INLINE constant #-}
1319− never = SpiderEvent EventNever
1320− constant = SpiderBehavior . BehaviorConst
1321− push f = SpiderEvent. push f . unSpiderEvent
1322− pull = SpiderBehavior . pull
1323− merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event)
1324− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1325− switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior
1326− coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent
1910+data Global
1911+
1912+{-# NOINLINE globalSpiderEnv #-}
1913+globalSpiderEnv :: SpiderEnv Global
1914+globalSpiderEnv = unsafePerformIO unsafeNewSpiderEnv
13271915
1328−instance R.MonadSample Spider SpiderHost where
1329− {-# INLINE sample #-}
1330− sample = SpiderHost . readBehavior . unSpiderBehavior
1916+type role SpiderEnv nominal
1917+data SpiderEnv x = SpiderEnv
1918+ { _spiderEnv_toUnsubscribe :: !(IORef [SomeEventSubscription])
1919+ , _spiderEnv_lock :: !(MVar ())
1920+ , _spiderEnv_cleanups :: !(IORef [IO ()])
1921+#ifdef DEBUG
1922+ , _spiderEnv_depth :: !(IORef Int)
1923+#endif
1924+ }
13311925
1332−instance R.MonadHold Spider SpiderHost where
1333− hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent
1926+instance GEq SpiderEnv where
1927+ a `geq` b = if _spiderEnv_toUnsubscribe a == _spiderEnv_toUnsubscribe b
1928+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderEnv can't have two different 'x' arguments
1929+ else Nothing
13341930
1335−instance R.MonadSample Spider BehaviorM where
1336− {-# INLINE sample #-}
1337− sample = readBehaviorTracked . unSpiderBehavior
1931+unsafeNewSpiderEnv :: forall x. IO (SpiderEnv x)
1932+unsafeNewSpiderEnv = do
1933+ toUnsubscribe <- newIORef []
1934+ lock <- newMVar ()
1935+ cleanups <- newIORef []
1936+#ifdef DEBUG
1937+ depthRef <- newIORef 0
1938+#endif
1939+ return $ SpiderEnv
1940+ { _spiderEnv_toUnsubscribe = toUnsubscribe
1941+ , _spiderEnv_lock = lock
1942+ , _spiderEnv_cleanups = cleanups
1943+#ifdef DEBUG
1944+ , _spiderEnv_depth = depthRef
1945+#endif
1946+ }
13381947
1339−instance R.MonadSample Spider EventM where
1340− {-# INLINE sample #-}
1341− sample = liftIO . readBehavior . unSpiderBehavior
1948+newSpiderEnv :: IO (Some SpiderEnv)
1949+newSpiderEnv = Some.This <$> unsafeNewSpiderEnv
13421950
1343−instance R.MonadHold Spider EventM where
1344− {-# INLINE hold #-}
1345− hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
1951+newtype SpiderPullM x a = SpiderPullM { runSpiderPullM :: BehaviorM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
13461952
1347−data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a)
1348−newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
1953+newtype SpiderPushM x a = SpiderPushM { runSpiderPushM :: ComputeM a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
13491954
1350−instance R.MonadSubscribeEvent Spider SpiderHostFrame where
1955+instance R.Reflex (SpiderEnv x) where
1956+ newtype Behavior (SpiderEnv x) a = SpiderBehavior { unSpiderBehavior :: Behavior a }
1957+ newtype Event (SpiderEnv x) a = SpiderEvent { unSpiderEvent :: Event a }
1958+ newtype Dynamic (SpiderEnv x) a = SpiderDynamic { unSpiderDynamic :: Dynamic Identity a } deriving (Functor, Applicative, Monad)
1959+ newtype Incremental (SpiderEnv x) p a = SpiderIncremental { unSpiderIncremental :: Dynamic p a }
1960+ type PullM (SpiderEnv x) = SpiderPullM x
1961+ type PushM (SpiderEnv x) = SpiderPushM x
1962+ {-# INLINABLE never #-}
1963+ never = SpiderEvent EventNever
1964+ {-# INLINABLE constant #-}
1965+ constant = SpiderBehavior . BehaviorConst
1966+ {-# INLINABLE push #-}
1967+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
1968+ {-# INLINABLE pull #-}
1969+ pull = SpiderBehavior . pull . coerce
1970+ {-# INLINABLE merge #-}
1971+ merge = SpiderEvent . merge . DynamicConst . (unsafeCoerce :: DMap k (R.Event (SpiderEnv x)) -> DMap k Event)
1972+ {-# INLINABLE fan #-}
1973+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
1974+ {-# INLINABLE switch #-}
1975+ switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event (SpiderEnv x) a) -> Behavior (Event a)) . unSpiderBehavior
1976+ {-# INLINABLE coincidence #-}
1977+ coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event (SpiderEnv x) a) -> Event (Event a)) . unSpiderEvent
1978+ {-# INLINABLE current #-}
1979+ current = SpiderBehavior . current . unSpiderDynamic
1980+ {-# INLINABLE updated #-}
1981+ updated = SpiderEvent . fmap runIdentity . updated . unSpiderDynamic
1982+ {-# INLINABLE unsafeBuildDynamic #-}
1983+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (coerce readV0) $ addIdentity $ unSpiderEvent v'
1984+ {-# INLINABLE unsafeBuildIncremental #-}
1985+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ DynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv
1986+ {-# INLINABLE mergeIncremental #-}
1987+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic R.PatchDMap (DMap k (R.Event (SpiderEnv x))) -> Dynamic R.PatchDMap (DMap k Event)) . unSpiderIncremental
1988+ {-# INLINABLE currentIncremental #-}
1989+ currentIncremental = SpiderBehavior . current . unSpiderIncremental
1990+ {-# INLINABLE updatedIncremental #-}
1991+ updatedIncremental = SpiderEvent . updated . unSpiderIncremental
1992+ {-# INLINABLE incrementalToDynamic #-}
1993+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ DynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ current i) $ flip push (updated i) $ \p -> do
1994+ c <- readBehaviorUntracked $ current i
1995+ return $ fmap Identity $ R.apply p c --TODO: Avoid the redundant 'apply'
1996+
1997+instance R.MonadSample (SpiderEnv x) (EventM x) where
1998+ {-# INLINABLE sample #-}
1999+ sample (SpiderBehavior b) = readBehaviorUntracked b
2000+
2001+instance R.MonadHold (SpiderEnv x) (EventM x) where
2002+ {-# INLINABLE hold #-}
2003+ hold = holdSpiderEventM
2004+ {-# INLINABLE holdDyn #-}
2005+ holdDyn = holdDynSpiderEventM
2006+ {-# INLINABLE holdIncremental #-}
2007+ holdIncremental = holdIncrementalSpiderEventM
2008+
2009+holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)
2010+holdSpiderEventM v0 e = liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2011+
2012+holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)
2013+holdDynSpiderEventM v0 e = liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2014+
2015+holdIncrementalSpiderEventM :: R.Patch p => a -> R.Event (SpiderEnv x) (p a) -> EventM x (R.Incremental (SpiderEnv x) p a)
2016+holdIncrementalSpiderEventM v0 e = liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
2017+
2018+instance R.MonadHold (SpiderEnv x) (SpiderHost x) where
2019+ {-# INLINABLE hold #-}
2020+ hold v0 e = R.runHostFrame $ R.hold v0 e
2021+ {-# INLINABLE holdDyn #-}
2022+ holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e
2023+ {-# INLINABLE holdIncremental #-}
2024+ holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
2025+
2026+instance R.MonadSample (SpiderEnv x) (SpiderHost x) where
2027+ {-# INLINABLE sample #-}
2028+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2029+
2030+instance R.MonadSample (SpiderEnv x) (SpiderPullM x) where
2031+ {-# INLINABLE sample #-}
2032+ sample = coerce . readBehaviorTracked . unSpiderBehavior
2033+
2034+instance R.MonadSample (SpiderEnv x) (SpiderPushM x) where
2035+ {-# INLINABLE sample #-}
2036+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2037+
2038+instance R.MonadHold (SpiderEnv x) (SpiderPushM x) where
2039+ {-# INLINABLE hold #-}
2040+ hold v0 e = R.current <$> R.holdDyn v0 e
2041+ {-# INLINABLE holdDyn #-}
2042+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity e
2043+ {-# INLINABLE holdIncremental #-}
2044+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ liftM (SpiderIncremental . DynamicHold) $ hold v0 e
2045+
2046+data RootTrigger a = forall k. GCompare k => RootTrigger (SubscriberList a, IORef (DMap k Identity), k a)
2047+newtype SpiderEventHandle a = SpiderEventHandle { unSpiderEventHandle :: EventSubscription a }
2048+
2049+instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHostFrame x) where
2050+ {-# INLINABLE subscribeEvent #-}
13512051 subscribeEvent e = SpiderHostFrame $ do
1352− _ <- getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1353− return $ SpiderEventHandle (unSpiderEvent e)
1354−
1355−instance R.ReflexHost Spider where
1356− type EventTrigger Spider = RootTrigger
1357− type EventHandle Spider = SpiderEventHandle
1358− type HostFrame Spider = SpiderHostFrame
1359−
1360−instance R.MonadReadEvent Spider ReadPhase where
1361− {-# INLINE readEvent #-}
1362− readEvent = ReadPhase . liftM (fmap return) . readEvent . unEventHandle
1363−
1364−instance MonadRef EventM where
1365− type Ref EventM = Ref IO
1366− {-# INLINE newRef #-}
1367− {-# INLINE readRef #-}
1368− {-# INLINE writeRef #-}
2052+ subscription <- subscribe (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2053+ return $ SpiderEventHandle subscription
2054+
2055+instance R.ReflexHost (SpiderEnv x) where
2056+ type EventTrigger (SpiderEnv x) = RootTrigger
2057+ type EventHandle (SpiderEnv x) = SpiderEventHandle
2058+ type HostFrame (SpiderEnv x) = SpiderHostFrame x
2059+
2060+instance R.MonadReadEvent (SpiderEnv x) (ReadPhase x) where
2061+ {-# INLINABLE readEvent #-}
2062+ readEvent h = ReadPhase $ liftM (fmap return) $ liftIO $ do
2063+ let (sln, subscribed) = unSpiderEventHandle h
2064+ result <- readEventSubscribed subscribed
2065+ touch sln
2066+ return result
2067+
2068+instance MonadRef (EventM x) where
2069+ type Ref (EventM x) = Ref IO
2070+ {-# INLINABLE newRef #-}
2071+ {-# INLINABLE readRef #-}
2072+ {-# INLINABLE writeRef #-}
13692073 newRef = liftIO . newRef
13702074 readRef = liftIO . readRef
13712075 writeRef r a = liftIO $ writeRef r a
13722076
1373−instance MonadAtomicRef EventM where
1374− {-# INLINE atomicModifyRef #-}
2077+instance MonadAtomicRef (EventM x) where
2078+ {-# INLINABLE atomicModifyRef #-}
13752079 atomicModifyRef r f = liftIO $ atomicModifyRef r f
13762080
1377−newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
1378−
1379−newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
1380−
1381−instance R.MonadSample Spider SpiderHostFrame where
1382− sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can
1383−
1384−instance R.MonadHold Spider SpiderHostFrame where
1385− {-# INLINE hold #-}
1386− hold v0 e = SpiderHostFrame $ R.hold v0 e
2081+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2082+
2083+instance Monad (SpiderHost x) where
2084+ {-# INLINABLE (>>=) #-}
2085+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2086+ {-# INLINABLE (>>) #-}
2087+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2088+ {-# INLINABLE return #-}
2089+ return x = SpiderHost $ return x
2090+ {-# INLINABLE fail #-}
2091+ fail s = SpiderHost $ fail s
2092+
2093+runSpiderHost :: SpiderHost Global a -> IO a
2094+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderEnv
2095+
2096+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2097+
2098+instance Monad (SpiderHostFrame x) where
2099+ {-# INLINABLE (>>=) #-}
2100+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2101+ {-# INLINABLE (>>) #-}
2102+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2103+ {-# INLINABLE return #-}
2104+ return x = SpiderHostFrame $ return x
2105+ {-# INLINABLE fail #-}
2106+ fail s = SpiderHostFrame $ fail s
2107+
2108+instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where
2109+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2110+
2111+addIdentity :: Event a -> Event (Identity a)
2112+--addIdentity = fmap Identity
2113+addIdentity = unsafeCoerce
2114+
2115+instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where
2116+ {-# INLINABLE hold #-}
2117+ hold v0 e = SpiderHostFrame $ liftM (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2118+ {-# INLINABLE holdDyn #-}
2119+ holdDyn v0 e = SpiderHostFrame $ liftM (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ addIdentity $ unSpiderEvent e
2120+ {-# INLINABLE holdIncremental #-}
2121+ holdIncremental v0 e = SpiderHostFrame $ liftM (SpiderIncremental . DynamicHold) $ hold v0 $ unSpiderEvent e
13872122
13882123newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
13892124newEventWithTriggerIO f = do
@@ -1401,44 +2136,60 @@ newFanEventWithTriggerIO f = do
14012136 }
14022137 return $ EventSelector $ \k -> EventRoot k r
14032138
1404−instance R.MonadReflexCreateTrigger Spider SpiderHost where
1405− newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO
1406− newFanEventWithTrigger f = SpiderHost $ do
2139+instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHost x) where
2140+ newEventWithTrigger = SpiderHost . lift . liftM SpiderEvent . newEventWithTriggerIO
2141+ newFanEventWithTrigger f = SpiderHost $ lift $ do
14072142 es <- newFanEventWithTriggerIO f
14082143 return $ R.EventSelector $ SpiderEvent . select es
14092144
1410−instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
2145+instance R.MonadReflexCreateTrigger (SpiderEnv x) (SpiderHostFrame x) where
14112146 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
14122147 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
14132148 es <- newFanEventWithTriggerIO f
14142149 return $ R.EventSelector $ SpiderEvent . select es
14152150
1416−instance R.MonadSubscribeEvent Spider SpiderHost where
1417− subscribeEvent e = SpiderHost $ do
1418− _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used
1419− return $ SpiderEventHandle (unSpiderEvent e)
2151+instance R.MonadSubscribeEvent (SpiderEnv x) (SpiderHost x) where
2152+ {-# INLINABLE subscribeEvent #-}
2153+ subscribeEvent = subscribeEventSpiderHost
2154+
2155+subscribeEventSpiderHost :: R.Event (SpiderEnv x) a -> SpiderHost x (R.EventHandle (SpiderEnv x) a)
2156+subscribeEventSpiderHost e = do
2157+ subscription <- runFrame $ getEventSubscribed (unSpiderEvent e) SubscriberHandle --TODO: Unsubscribe eventually (manually and/or with weak ref)
2158+ return $ SpiderEventHandle subscription
2159+
2160+newtype ReadPhase x a = ReadPhase { runReadPhase :: ResultM x a } deriving (Functor, Applicative, Monad, MonadFix)
2161+
2162+instance R.MonadSample (SpiderEnv x) (ReadPhase x) where
2163+ {-# INLINABLE sample #-}
2164+ sample = ReadPhase . R.sample
14202165
1421−newtype ReadPhase a = ReadPhase { runReadPhase :: ResultM a } deriving (Functor, Applicative, Monad, MonadFix, R.MonadSample Spider, R.MonadHold Spider)
2166+instance R.MonadHold (SpiderEnv x) (ReadPhase x) where
2167+ {-# INLINABLE hold #-}
2168+ hold v0 e = ReadPhase $ R.hold v0 e
2169+ {-# INLINABLE holdDyn #-}
2170+ holdDyn v0 e = ReadPhase $ R.holdDyn v0 e
2171+ {-# INLINABLE holdIncremental #-}
2172+ holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
14222173
1423−instance R.MonadReflexHost Spider SpiderHost where
1424− type ReadPhase SpiderHost = ReadPhase
1425− fireEventsAndRead es (ReadPhase a) = SpiderHost $ run es a
1426− runHostFrame = SpiderHost . runFrame . runSpiderHostFrame
2174+instance R.MonadReflexHost (SpiderEnv x) (SpiderHost x) where
2175+ type ReadPhase (SpiderHost x) = ReadPhase x
2176+ fireEventsAndRead es (ReadPhase a) = run es a
2177+ runHostFrame = runFrame . runSpiderHostFrame
14272178
1428−instance MonadRef SpiderHost where
1429− type Ref SpiderHost = Ref IO
2179+instance MonadRef (SpiderHost x) where
2180+ type Ref (SpiderHost x) = Ref IO
14302181 newRef = SpiderHost . newRef
14312182 readRef = SpiderHost . readRef
14322183 writeRef r = SpiderHost . writeRef r
14332184
1434−instance MonadAtomicRef SpiderHost where
2185+instance MonadAtomicRef (SpiderHost x) where
14352186 atomicModifyRef r = SpiderHost . atomicModifyRef r
14362187
1437−instance MonadRef SpiderHostFrame where
1438− type Ref SpiderHostFrame = Ref IO
2188+instance MonadRef (SpiderHostFrame x) where
2189+ type Ref (SpiderHostFrame x) = Ref IO
14392190 newRef = SpiderHostFrame . newRef
14402191 readRef = SpiderHostFrame . readRef
14412192 writeRef r = SpiderHostFrame . writeRef r
14422193
1443−instance MonadAtomicRef SpiderHostFrame where
2194+instance MonadAtomicRef (SpiderHostFrame x) where
14442195 atomicModifyRef r = SpiderHostFrame . atomicModifyRef r