d3a3059 · reflex · git.iko.soy

git.iko.soy/reflex

A bit of messing around that seems to help performance

commitd3a3059d31b3493b2c24737d69319a1f0fe1f4dd authorRyan Trinkle <ryan@trinkle.org> dateFri 27 Sep 2019, 09:02 (7 years ago) parentb511a57

2 files changed+22−25

compare with develop

unifiedsplit

src/Reflex/PerformEvent/Base.hs+4 src/Reflex/Requester/Base/Internal.hs+18−25

src/Reflex/PerformEvent/Base.hs+4

@@ -90,6 +90,7 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

9090 performEvent = PerformEventT . requestingIdentity

9191

9292instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where

93+ {-# INLINE runWithReplace #-}

9394 runWithReplace a0 a' = PerformEventT $ RequesterT $ do

9495 env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask

9596 let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))

@@ -100,6 +101,7 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT

100101 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

101102 RequesterInternalT $ tellEvent requests

102103 pure (result0, fmapCheap fst newA)

104+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

103105 traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do

104106 env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask

105107 let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))

@@ -114,6 +116,7 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT

114116 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

115117 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe

116118 pure (results0, results')

119+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

117120 traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do

118121 env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask

119122 let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)

@@ -129,6 +132,7 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT

129132 --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

130133 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

131134 pure (results0, results')

135+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

132136 traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do

133137 env@(_, _ :: TagGen (PrimState (HostFrame t)) FakeRequesterStatePhantom) <- RequesterInternalT ask

134138 let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom (HostFrame t))))) v' a)

src/Reflex/Requester/Base/Internal.hs+18−25

@@ -87,9 +87,9 @@ runRequesterT :: forall t request response m a

8787 => RequesterT t request response m a

8888 -> Event t (ResponseData (PrimState m) response)

8989 -> m (a, Event t (RequestData (PrimState m) request))

90−runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (NonEmptyDeferred (RequestEnvelope s request))) -> do

90+runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \requests -> do

9191 (_, tg) <- RequesterInternalT ask

92− result <- (unsafeCoerce :: RequesterInternalT FakeRequesterStatePhantom t request response m a -> RequesterInternalT s t request response m a) a

92+ result <- a

9393 let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of

9494 Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow

9595 Just Refl -> Just m

@@ -106,14 +106,18 @@ instance MonadTrans (RequesterT t request response) where

106106-- The 'Tag' keys will be used to return the responses to the same place the

107107-- requests were issued.

108108withRequesterInternalT

109− :: ( Reflex t

109+ :: forall t m request response a.

110+ ( Reflex t

110111 , PrimMonad m

111112 , MonadFix m

112113 )

113− => (forall s. Event t (NonEmptyDeferred (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))

114+ => (Event t (NonEmptyDeferred (RequestEnvelope FakeRequesterStatePhantom request)) -> RequesterInternalT FakeRequesterStatePhantom t request response m (Event t (TagMap FakeRequesterStatePhantom response), a))

114115 -> m a

115−withRequesterInternalT f = withTagGen $ \tg -> do

116− rec let RequesterInternalT a = f requests

116+withRequesterInternalT f = do

117+ stg <- newTagGen

118+ let tg = case stg of

119+ Some tg' -> (unsafeCoerce :: TagGen (PrimState m) s -> TagGen (PrimState m) FakeRequesterStatePhantom) tg'

120+ rec let RequesterInternalT a = (unsafeCoerce :: RequesterInternalT s t request response m (Event t (TagMap FakeRequesterStatePhantom response), a) -> RequesterInternalT FakeRequesterStatePhantom t request response m (Event t (TagMap FakeRequesterStatePhantom response), a)) $ f requests

117121 ((responses, result), requests) <- runEventWriterT $ runReaderT a (fanTag responses, tg)

118122 pure result

119123

@@ -199,36 +203,25 @@ instance (Reflex t, PrimMonad m) => Requester t (RequesterInternalT s t request

199203 tellEvent $ fmapCheap (NonEmptyDeferred.singleton . RequestEnvelope Nothing) e

200204

201205instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterInternalT s t request response m) where

202− {-# INLINABLE runWithReplace #-}

206+ {-# INLINE runWithReplace #-}

203207 runWithReplace (RequesterInternalT a0) a' = RequesterInternalT $ runWithReplace a0 (coerceEvent a')

204− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

208+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

205209 traverseIntMapWithKeyWithAdjust f dm0 dm' = RequesterInternalT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

206− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

210+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

207211 traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterInternalT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

208− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

212+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

209213 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterInternalT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

210214

211215instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterT t request response m) where

212− {-# INLINABLE runWithReplace #-}

216+ {-# INLINE runWithReplace #-}

213217 runWithReplace (RequesterT a0) a' = RequesterT $ runWithReplace a0 (fmapCheap unRequesterT a')

214− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

218+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

215219 traverseIntMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseIntMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'

216− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

220+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

217221 traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'

218− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

222+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

219223 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'

220224

221−{-# INLINABLE runWithReplaceRequesterTWith #-}

222−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

223− , MonadFix m

224− )

225− => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

226− -> RequesterT t request response m a

227− -> Event t (RequesterT t request response m b)

228− -> RequesterT t request response m (a, Event t b)

229−runWithReplaceRequesterTWith f (RequesterT a0) a' = RequesterT $ do

230− pure undefined

231−

232225{-

233226import GHC.Exts (Any)

234227import Unsafe.Coerce