011edf2 · reflex · git.iko.soy

git.iko.soy/reflex

Switch cacheEvent's weakSelf to a FastWeak

commit011edf2ae4fb4930217ae4582ef55ea85b5ace95 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 10 Jun 2017, 17:20 (9 years ago) parent13e71e8

4 files changed+241−30

compare with develop

unifiedsplit

reflex.cabal+4 src/Data/FastWeakBag.hs+123 src/Reflex/FastWeak.hs+75 src/Reflex/Spider/Internal.hs+39−30

reflex.cabal+4

@@ -78,6 +78,7 @@ library

7878 Reflex.Dynamic,

7979 Reflex.Dynamic.Uniq,

8080 Reflex.DynamicWriter,

81+ Reflex.FastWeak,

8182 Reflex.FunctorMaybe,

8283 Reflex.Host.Class,

8384 Reflex.Patch,

@@ -136,6 +137,9 @@ library

136137 if flag(experimental-dependent-sum-instances)

137138 ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES

138139

140+ if impl(ghcjs)

141+ build-depends: ghcjs-base

142+

139143test-suite semantics

140144 type: exitcode-stdio-1.0

141145 main-is: semantics.hs

src/Data/FastWeakBag.hsnew file+123

@@ -0,0 +1,123 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+#ifdef USE_REFLEX_OPTIMIZER

5+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

6+#endif

7+-- | This module defines the 'FastWeakBag' type, which represents a mutable

8+-- collection of items that does not cause the items to be retained in memory.

9+-- This is useful for situations where a value needs to be inspected or modified

10+-- if it is still alive, but can be ignored if it is dead.

11+module Data.FastWeakBag

12+ ( FastWeakBag

13+ , FastWeakBagTicket

14+ , empty

15+ , singleton

16+ , insert

17+ , traverse

18+ , remove

19+ -- * Internal functions

20+ -- These will not always be available.

21+ , _weakBag_children --TODO: Don't export this

22+ ) where

23+

24+import Control.Exception

25+import Control.Monad hiding (forM_, mapM_)

26+import Control.Monad.IO.Class

27+import Data.Foldable (forM_, mapM_)

28+import Data.IntMap.Strict (IntMap)

29+import qualified Data.IntMap.Strict as IntMap

30+import Data.IORef

31+import Reflex.FastWeak

32+import System.Mem.Weak

33+

34+import Prelude hiding (mapM_, traverse)

35+

36+-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -

37+-- that is, they can still be garbage-collected. As long as the @a@s remain

38+-- alive, the 'FastWeakBag' will continue to refer to them.

39+data FastWeakBag a = FastWeakBag

40+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?

41+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))

42+ }

43+

44+-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If

45+-- the caller retains the ticket, the item is guranteed to stay in memory (and

46+-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from

47+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.

48+data FastWeakBagTicket = forall a. FastWeakBagTicket

49+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)

50+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a

51+ }

52+

53+-- | Insert an item into a 'FastWeakBag'.

54+{-# INLINE insert #-}

55+insert :: a -- ^ The item

56+ -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into

57+ -> FastWeak b -- ^ An arbitrary value to be used in the following

58+ -- callback

59+ -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed

60+ -- (whether automatically by the item being garbage

61+ -- collected or manually via 'remove')

62+ -> IO FastWeakBagTicket -- ^ Returns a 'FastWeakBagTicket' that ensures the item

63+ -- is retained and allows the item to be removed.

64+insert a (FastWeakBag nextId children) wb finalizer = {-# SCC "insert" #-} do

65+ a' <- evaluate a

66+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)

67+ let cleanup = do

68+ mb <- getFastWeakValue wb

69+ forM_ mb $ \b -> do

70+ csWithoutMe <- atomicModifyIORef children $ \cs ->

71+ let !csWithoutMe = IntMap.delete myId cs

72+ in (csWithoutMe, csWithoutMe)

73+ when (IntMap.null csWithoutMe) $ finalizer b

74+ return ()

75+ return ()

76+ wa <- mkWeakPtr a' $ Just cleanup

77+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

78+ return $ FastWeakBagTicket

79+ { _weakBagTicket_weakItem = wa

80+ , _weakBagTicket_item = a'

81+ }

82+

83+-- | Create an empty 'FastWeakBag'.

84+{-# INLINE empty #-}

85+empty :: IO (FastWeakBag a)

86+empty = {-# SCC "empty" #-} do

87+ nextId <- newIORef 1

88+ children <- newIORef IntMap.empty

89+ let bag = FastWeakBag

90+ { _weakBag_nextId = nextId

91+ , _weakBag_children = children

92+ }

93+ return bag

94+

95+-- | Create a 'FastWeakBag' with one item; equivalent to creating the 'FastWeakBag' with

96+-- 'empty', then using 'insert'.

97+{-# INLINE singleton #-}

98+singleton :: a -> FastWeak b -> (b -> IO ()) -> IO (FastWeakBag a, FastWeakBagTicket)

99+singleton a wb finalizer = {-# SCC "singleton" #-} do

100+ bag <- empty

101+ ticket <- insert a bag wb finalizer

102+ return (bag, ticket)

103+

104+{-# INLINE traverse #-}

105+-- | Visit every node in the given list. If new nodes are appended during the

106+-- traversal, they will not be visited. Every live node that was in the list

107+-- when the traversal began will be visited exactly once; however, no guarantee

108+-- is made about the order of the traversal.

109+traverse :: MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

110+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do

111+ cs <- liftIO $ readIORef children

112+ forM_ cs $ \c -> do

113+ ma <- liftIO $ deRefWeak c

114+ mapM_ f ma

115+

116+-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times

117+-- on the same 'FastWeakBagTicket'.

118+{-# INLINE remove #-}

119+remove :: FastWeakBagTicket -> IO ()

120+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w

121+--TODO: Should 'remove' also drop the reference to the item?

122+

123+--TODO: can/should we provide a null FastWeakBagTicket?

src/Reflex/FastWeak.hsnew file+75

@@ -0,0 +1,75 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+{-# LANGUAGE JavaScriptFFI #-}

4+{-# LANGUAGE MagicHash #-}

5+module Reflex.FastWeak

6+ ( FastWeakTicket

7+ , FastWeak

8+ , fastWeakTicket

9+ , fastWeakTicketValue

10+ , getFastWeakTicketWeak

11+ , getFastWeakValue

12+ ) where

13+

14+#ifdef ghcjs_HOST_OS

15+import GHCJS.Types

16+import Unsafe.Coerce

17+#else

18+#endif

19+

20+

21+#ifdef ghcjs_HOST_OS

22+type Ref = JSVal

23+#else

24+type Ref = ()

25+#endif

26+

27+newtype FastWeakTicket a = FastWeakTicket Ref

28+

29+newtype FastWeak a = FastWeak Ref

30+

31+-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

32+data Val a = Val { unVal :: a }

33+

34+-- Do we have a concern about accidentally retaining the ticket here?

35+fastWeakTicketValue :: FastWeakTicket a -> a

36+#ifdef ghcjs_HOST_OS

37+fastWeakTicketValue t = unVal (unsafeCoerce (js_ticketVal t))

38+

39+foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> JSVal

40+#else

41+fastWeakTicketValue = error "fastWeakTicketValue not implemented"

42+#endif

43+

44+getFastWeakValue :: FastWeak a -> IO (Maybe a)

45+#ifdef ghcjs_HOST_OS

46+getFastWeakValue w = do

47+ r <- js_weakVal w

48+ case js_isNull r of

49+ True -> return Nothing

50+ False -> return (unsafeCoerce r)

51+

52+foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool

53+

54+foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal

55+#else

56+getFastWeakValue = error "getFastWeakValue not implemented"

57+#endif

58+

59+-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the associated FastWeak to actually be weak

60+fastWeakTicket :: a -> FastWeakTicket a

61+#ifdef ghcjs_HOST_OS

62+fastWeakTicket v = js_fastWeakTicket (unsafeCoerce (Val v))

63+

64+foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> FastWeakTicket a

65+#else

66+fastWeakTicket = error "fastWeakTicket not implemented"

67+#endif

68+

69+-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value

70+#ifdef ghcjs_HOST_OS

71+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

72+#else

73+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

74+getFastWeakTicketWeak = error "fastWeakTicketWeak not implemented"

75+#endif

src/Reflex/Spider/Internal.hs+39−30

@@ -8,9 +8,7 @@

88{-# LANGUAGE FunctionalDependencies #-}

99{-# LANGUAGE GADTs #-}

1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11−#if defined(DEBUG) || defined(DEBUG_CYCLES)

1211{-# LANGUAGE LambdaCase #-}

13−#endif

1412{-# LANGUAGE MagicHash #-}

1513{-# LANGUAGE MultiParamTypeClasses #-}

1614{-# LANGUAGE MultiWayIf #-}

@@ -62,6 +60,7 @@ import Data.Word

6260import GHC.Exts

6361import GHC.IORef (IORef (..))

6462import GHC.Stack

63+import Reflex.FastWeak

6564import Reflex.FunctorMaybe

6665import System.IO.Unsafe

6766import System.Mem.Weak

@@ -75,6 +74,8 @@ import Data.Monoid (mempty)

7574import Data.Tree (Forest, Tree (..), drawForest)

7675#endif

7776

77+import Data.FastWeakBag (FastWeakBag)

78+import qualified Data.FastWeakBag as FastWeakBag

7879import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

7980import qualified Data.WeakBag as WeakBag

8081#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

@@ -252,10 +253,9 @@ pushCheap f e = Event $ \sub -> do

252253 return (subscription, occ')

253254

254255data CacheSubscribed x a

255− = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))

256− , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))

256+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

257257 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

258− , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))

258+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (FastWeakTicket (CacheSubscribed x a))))

259259 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

260260 }

261261

@@ -263,57 +263,59 @@ data CacheSubscribed x a

263263-- repeatedly

264264--

265265--TODO: Try a caching strategy where we subscribe directly to the parent when

266−--there's only one subscriber, and then build our own WeakBag only when a second

266+--there's only one subscriber, and then build our own FastWeakBag only when a second

267267--subscriber joins

268268{-# NOINLINE cacheEvent #-}

269−cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

269+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a

270270cacheEvent e =

271271#ifdef DEBUG_TRACE_EVENTS

272272 withStackOneLine $ \callSite -> Event $

273273#else

274274 Event $

275275#endif

276− let !mSubscribedRef = unsafeNewIORef e Nothing

276+ let mSubscribedRef :: IORef (Maybe (FastWeakTicket (CacheSubscribed x a)))

277+ !mSubscribedRef = unsafeNewIORef e Nothing

277278 in \sub -> {-# SCC "cacheEvent" #-} do

278279#ifdef DEBUG_TRACE_EVENTS

279280 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

280281#endif

281− mSubscribed <- liftIO $ readIORef mSubscribedRef

282− case mSubscribed of

283− Just subscribed -> liftIO $ do

284− ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed

285− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

286− let es = EventSubscribed

287− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

288− , eventSubscribedRetained = toAny subscribed

289− }

290− return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)

282+ subscribedTicket <- liftIO (readIORef mSubscribedRef) >>= \case

283+ Just subscribedTicket -> return subscribedTicket

291284 Nothing -> do

292− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"

293− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed

294− occRef <- liftIO $ newIORef undefined

285+ subscribers <- liftIO FastWeakBag.empty

286+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

295287 (parentSub, occ) <- subscribeAndRead e $ Subscriber

296288 { subscriberPropagate = \a -> do

297289 liftIO $ writeIORef occRef $ Just a

298290 scheduleClear occRef

299− propagate a subscribers

291+ propagateFast a subscribers

300292 , subscriberInvalidateHeight = \old -> do

301− WeakBag.traverse subscribers $ invalidateSubscriberHeight old

293+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

302294 , subscriberRecalculateHeight = \new -> do

303− WeakBag.traverse subscribers $ recalculateSubscriberHeight new

295+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

304296 }

305− liftIO $ writeIORef occRef occ

306− when (isJust occ) $ scheduleClear occRef

297+ when (isJust occ) $ do

298+ liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

299+ scheduleClear occRef

307300 let !subscribed = CacheSubscribed

308301 { _cacheSubscribed_subscribers = subscribers

309− , _cacheSubscribed_weakSelf = weakSelf

310302 , _cacheSubscribed_parent = parentSub

311303 , _cacheSubscribed_cached = mSubscribedRef

312304 , _cacheSubscribed_occurrence = occRef

313305 }

314− liftIO $ writeIORef mSubscribedRef $ Just subscribed

315− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

316− return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)

306+ !subscribedTicket = fastWeakTicket subscribed

307+ liftIO $ writeIORef mSubscribedRef $ Just subscribedTicket

308+ return subscribedTicket

309+ liftIO $ do

310+ let subscribed = fastWeakTicketValue subscribedTicket

311+ subscribedWeak <- getFastWeakTicketWeak subscribedTicket

312+ ticket <- FastWeakBag.insert sub (_cacheSubscribed_subscribers subscribed) subscribedWeak cleanupCacheSubscribed

313+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

314+ let es = EventSubscribed

315+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

316+ , eventSubscribedRetained = toAny subscribed

317+ }

318+ return (EventSubscription (FastWeakBag.remove ticket >> touch ticket) es, occ)

317319

318320cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

319321cleanupCacheSubscribed self = do

@@ -497,6 +499,13 @@ propagate a subscribers = withIncreasedDepth $ do

497499 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

498500 WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

499501

502+-- | Propagate everything at the current height

503+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

504+propagateFast a subscribers = withIncreasedDepth $ do

505+ -- 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

506+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

507+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a

508+

500509--------------------------------------------------------------------------------

501510-- EventSubscribed

502511--------------------------------------------------------------------------------