d3a3059 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

A bit of messing around that seems to help performance

d3a3059Ryan Trinkle7 years ago

src/Reflex/PerformEvent/Base.hs+4

compare with develop

unifiedsplit

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

90 performEvent = PerformEventT . requestingIdentity

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

93+ {-# INLINE runWithReplace #-}

93 runWithReplace a0 a' = PerformEventT $ RequesterT $ do

94 runWithReplace a0 a' = PerformEventT $ RequesterT $ do

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

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

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

96 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

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

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

101 RequesterInternalT $ tellEvent requests

102 RequesterInternalT $ tellEvent requests

102 pure (result0, fmapCheap fst newA)

103 pure (result0, fmapCheap fst newA)

104+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

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

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

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

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

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

107 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

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

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

115 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe

117 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatIntMapMaybe

116 pure (results0, results')

118 pure (results0, results')

119+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

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

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

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

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

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

122 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

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

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

130 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

133 RequesterInternalT $ tellEvent $ fforMaybeCheap requests concatMapMaybe

131 pure (results0, results')

134 pure (results0, results')

135+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

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

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

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

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

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

138 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

87 => RequesterT t request response m a

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

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

91 (_, tg) <- RequesterInternalT ask

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

92+ result <- a

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

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

95 Just Refl -> Just m

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

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

107-- requests were issued.

108withRequesterInternalT

109+ :: forall t m request response a.

109− :: ( Reflex t

110+ ( Reflex t

110 , PrimMonad m

111 , PrimMonad m

111 , MonadFix m

112 , MonadFix m

112 )

113 )

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

114 -> m a

115 -> m a

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

116+withRequesterInternalT f = do

116− rec let RequesterInternalT a = f requests

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

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

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

118 pure result

122 pure result

119

123

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

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

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

200

204

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

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

202− {-# INLINABLE runWithReplace #-}

206+ {-# INLINE runWithReplace #-}

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

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

204− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

208+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

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

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

206− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

210+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

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

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

208− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

212+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

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

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

210

214

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

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

212− {-# INLINABLE runWithReplace #-}

216+ {-# INLINE runWithReplace #-}

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

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

214− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

218+ {-# INLINE traverseIntMapWithKeyWithAdjust #-}

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

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

216− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

220+ {-# INLINE traverseDMapWithKeyWithAdjust #-}

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

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

218− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

222+ {-# INLINE traverseDMapWithKeyWithAdjustWithMove #-}

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

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

220

224

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−

232{-

225{-

233import GHC.Exts (Any)

226import GHC.Exts (Any)

234import Unsafe.Coerce

227import Unsafe.Coerce