From dc3ce150b6a88fc29f2ee0bb60a5bc686d2d0cc8 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Sun, 21 Jul 2019 03:30:58 -0400 Subject: [PATCH] Use unsafePerformIO better (#325) The previous code was struggling to create artificial dependencies to prevent `unsafePerformIO` calls from being floated out of their proper context. Push the context into each `unsafePerformIO` call so the dependency is real. Reading a bit of the resulting Core, I don't expect to see many (if any) performance regressions. Performance will hopefully improve a bit if/when [GHC issue 15127](https://gitlab.haskell.org/ghc/ghc/issues/15127) is fixed. --- src/Reflex/Spider/Internal.hs | 97 ++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 46 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index ee7c7a0a..f130a635 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -198,12 +198,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1 newNodeId :: IO Int newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n) - -{-# NOINLINE unsafeNodeId #-} -unsafeNodeId :: a -> Int -unsafeNodeId a = unsafePerformIO $ do - touch a - newNodeId #endif -------------------------------------------------------------------------------- @@ -307,9 +301,10 @@ cacheEvent e = #else Event $ #endif - let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a)) - !mSubscribedRef = unsafeNewIORef e emptyFastWeak - in \sub -> {-# SCC "cacheEvent" #-} do + unsafePerformIO $ do + mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a)) + <- newIORef emptyFastWeak + pure $ \sub -> {-# SCC "cacheEvent" #-} do #ifdef DEBUG_TRACE_EVENTS unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite #endif @@ -1177,18 +1172,12 @@ buildDynamic readV0 v' = do return d unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p -unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x - where x = (readV0, v') +unsafeBuildDynamic readV0 v' = + Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v') -- ResultM can read behaviors and events type ResultM = EventM -{-# NOINLINE unsafeNewIORef #-} -unsafeNewIORef :: a -> b -> IORef b -unsafeNewIORef a b = unsafePerformIO $ do - touch a - newIORef b - instance HasSpiderTimeline x => Functor (Event x) where fmap f = push $ return . Just . f @@ -1201,26 +1190,35 @@ push f e = cacheEvent (pushCheap f e) {-# INLINABLE pull #-} pull :: BehaviorM x a -> Behavior x a -pull a = behaviorPull $ Pull - { pullCompute = a - , pullValue = unsafeNewIORef a Nothing +pull a = unsafePerformIO $ do + ref <- newIORef Nothing #ifdef DEBUG_NODEIDS - , pullNodeId = unsafeNodeId a + nid <- newNodeId #endif - } + pure $ behaviorPull $ Pull + { pullCompute = a + , pullValue = ref +#ifdef DEBUG_NODEIDS + , pullNodeId = nid +#endif + } {-# INLINABLE switch #-} switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a -switch a = eventSwitch $ Switch - { switchParent = a - , switchSubscribed = unsafeNewIORef a Nothing - } +switch a = unsafePerformIO $ do + ref <- newIORef Nothing + pure $ eventSwitch $ Switch + { switchParent = a + , switchSubscribed = ref + } coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a -coincidence a = eventCoincidence $ Coincidence - { coincidenceParent = a - , coincidenceSubscribed = unsafeNewIORef a Nothing - } +coincidence a = unsafePerformIO $ do + ref <- newIORef Nothing + pure $ eventCoincidence $ Coincidence + { coincidenceParent = a + , coincidenceSubscribed = ref + } -- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b @@ -1424,6 +1422,9 @@ getRootSubscribed k r sub = do when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit" uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k) writeIORef uninitRef $! uninit +#ifdef DEBUG_NODEIDS + nid <- newNodeId +#endif let !subscribed = RootSubscribed { rootSubscribedKey = k , rootSubscribedCachedSubscribed = cached @@ -1432,7 +1433,7 @@ getRootSubscribed k r sub = do , rootSubscribedUninit = uninit , rootSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS - , rootSubscribedNodeId = unsafeNodeId (k, r, subs) + , rootSubscribedNodeId = nid #endif } -- If we die at the same moment that all our children die, they will @@ -1481,16 +1482,10 @@ newFanInt = do , _fanInt_occRef = occRef } -{-# NOINLINE unsafeNewFanInt #-} -unsafeNewFanInt :: b -> FanInt x a -unsafeNewFanInt b = unsafePerformIO $ do - touch b - newFanInt - fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a -fanInt p = - let self = unsafeNewFanInt p - in EventSelectorInt $ \k -> Event $ \sub -> do +fanInt p = unsafePerformIO $ do + self <- newFanInt + pure $ EventSelectorInt $ \k -> Event $ \sub -> do isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self) when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input (subscription, parentOcc) <- subscribeAndRead p $ Subscriber @@ -1544,13 +1539,16 @@ getFanSubscribed k f sub = do subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized" occRef <- liftIO $ newIORef parentOcc when (isJust parentOcc) $ scheduleClear occRef +#ifdef DEBUG_NODEIDS + nid <- liftIO newNodeId +#endif let subscribed = FanSubscribed { fanSubscribedCachedSubscribed = fanSubscribed f , fanSubscribedOccurrence = occRef , fanSubscribedParent = subscription , fanSubscribedSubscribers = subscribersRef #ifdef DEBUG_NODEIDS - , fanSubscribedNodeId = unsafeNodeId f + , fanSubscribedNodeId = nid #endif } let !self = (k, subscribed) @@ -1610,6 +1608,9 @@ getSwitchSubscribed s sub = do when (isJust parentOcc) $ scheduleClear occRef weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized" (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed +#ifdef DEBUG_NODEIDS + nid <- liftIO newNodeId +#endif let !subscribed = SwitchSubscribed { switchSubscribedCachedSubscribed = switchSubscribed s , switchSubscribedOccurrence = occRef @@ -1622,7 +1623,7 @@ getSwitchSubscribed s sub = do , switchSubscribedCurrentParent = subscriptionRef , switchSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS - , switchSubscribedNodeId = unsafeNodeId s + , switchSubscribedNodeId = nid #endif } liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf" @@ -1667,6 +1668,9 @@ getCoincidenceSubscribed c sub = do scheduleClear innerSubdRef weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented" (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed +#ifdef DEBUG_NODEIDS + nid <- liftIO newNodeId +#endif let subscribed = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c , coincidenceSubscribedOccurrence = occRef @@ -1677,7 +1681,7 @@ getCoincidenceSubscribed c sub = do , coincidenceSubscribedInnerParent = innerSubdRef , coincidenceSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS - , coincidenceSubscribedNodeId = unsafeNodeId c + , coincidenceSubscribedNodeId = nid #endif } liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed" @@ -2051,12 +2055,13 @@ newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) } fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v -fanG e = +fanG e = unsafePerformIO $ do + ref <- newIORef Nothing let f = Fan { fanParent = e - , fanSubscribed = unsafeNewIORef e Nothing + , fanSubscribed = ref } - in EventSelectorG $ \k -> eventFan k f + pure $ EventSelectorG $ \k -> eventFan k f runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x () runHoldInits holdInitRef dynInitRef mergeInitRef = do