ae03249 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Some more simplifications

ae03249Ryan Trinkle9 years ago

src/Data/FastWeakBag.hs+7−25

compare with develop

unifiedsplit

@@ -12,7 +12,7 @@ module Data.FastWeakBag

12 ( FastWeakBag

13 , FastWeakBagTicket

14 , empty

15− , singleton

15+ , isEmpty

16 , insert

17 , traverse

18 , remove

@@ -28,7 +28,6 @@ import Data.Foldable (forM_, mapM_)

28import Data.IntMap.Strict (IntMap)

29import qualified Data.IntMap.Strict as IntMap

30import Data.IORef

31−import Reflex.FastWeak

32import System.Mem.Weak

31import System.Mem.Weak

34import Prelude hiding (mapM_, traverse)

33import Prelude hiding (mapM_, traverse)

@@ -54,25 +53,12 @@ data FastWeakBagTicket = forall a. FastWeakBagTicket

54{-# INLINE insert #-}

53{-# INLINE insert #-}

55insert :: a -- ^ The item

54insert :: a -- ^ The item

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

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

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

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

57 -- is retained and allows the item to be removed.

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

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

65 a' <- evaluate a

59 a' <- evaluate a

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

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

61+ let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId 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

62 wa <- mkWeakPtr a' $ Just cleanup

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

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

78 return $ FastWeakBagTicket

64 return $ FastWeakBagTicket

@@ -92,14 +78,10 @@ empty = {-# SCC "empty" #-} do

92 }

78 }

93 return bag

79 return bag

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

81+-- | Check whether a 'FastWeakBag' is empty.

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

97−{-# INLINE singleton #-}

82+{-# INLINE isEmpty #-}

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

83+isEmpty :: FastWeakBag a -> IO Bool

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

84+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)

100− bag <- empty

101− ticket <- insert a bag wb finalizer

102− return (bag, ticket)

103

104{-# INLINE traverse #-}

86{-# INLINE traverse #-}

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

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

src/Reflex/FastWeak.hs+50−8

@@ -1,4 +1,6 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

2#ifdef ghcjs_HOST_OS

4#ifdef ghcjs_HOST_OS

3{-# LANGUAGE ForeignFunctionInterface #-}

5{-# LANGUAGE ForeignFunctionInterface #-}

4{-# LANGUAGE JavaScriptFFI #-}

6{-# LANGUAGE JavaScriptFFI #-}

@@ -7,16 +9,21 @@ module Reflex.FastWeak

7 ( FastWeakTicket

9 ( FastWeakTicket

8 , FastWeak

10 , FastWeak

9 , mkFastWeakTicket

11 , mkFastWeakTicket

10− , fastWeakTicketValue

12+ , getFastWeakTicketValue

11 , getFastWeakTicketWeak

13 , getFastWeakTicketWeak

12 , getFastWeakValue

14 , getFastWeakValue

15+ , getFastWeakTicket

16+ , emptyFastWeak

13 ) where

17 ) where

19+import GHC.Exts (Any)

20+import Unsafe.Coerce

21+

15#ifdef ghcjs_HOST_OS

22#ifdef ghcjs_HOST_OS

16import GHCJS.Types

23import GHCJS.Types

17−import Unsafe.Coerce

18#else

24#else

19import Control.Exception (evaluate)

25import Control.Exception (evaluate)

26+import System.IO.Unsafe

20import System.Mem.Weak

27import System.Mem.Weak

21#endif

28#endif

@@ -37,14 +44,16 @@ data FastWeakTicket a = FastWeakTicket

37type FastWeak a = Weak a

44type FastWeak a = Weak a

38#endif

45#endif

40−-- Do we have a concern about accidentally retaining the ticket here?

47+-- This needs to be in IO so we know that we've relinquished the ticket

41−fastWeakTicketValue :: FastWeakTicket a -> a

48+getFastWeakTicketValue :: FastWeakTicket a -> IO a

42#ifdef ghcjs_HOST_OS

49#ifdef ghcjs_HOST_OS

50+getFastWeakTicketValue t = do

51+ v <- js_ticketVal t

43−fastWeakTicketValue t = unVal (unsafeCoerce (js_ticketVal t))

52+ return $ unVal (unsafeCoerce v)

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

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

46#else

55#else

47−fastWeakTicketValue = _fastWeakTicket_val

56+getFastWeakTicketValue = return . _fastWeakTicket_val

48#endif

57#endif

50getFastWeakValue :: FastWeak a -> IO (Maybe a)

59getFastWeakValue :: FastWeak a -> IO (Maybe a)

@@ -53,7 +62,7 @@ getFastWeakValue w = do

53 r <- js_weakVal w

62 r <- js_weakVal w

54 case js_isNull r of

63 case js_isNull r of

55 True -> return Nothing

64 True -> return Nothing

56− False -> return (unsafeCoerce r)

65+ False -> return $ Just $ unVal (unsafeCoerce r)

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

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

@@ -62,6 +71,25 @@ foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.v

62getFastWeakValue = deRefWeak

71getFastWeakValue = deRefWeak

63#endif

72#endif

74+getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

75+#ifdef ghcjs_HOST_OS

76+getFastWeakTicket w = do

77+ r <- js_weakTicket w

78+ case js_isNull r of

79+ True -> return Nothing

80+ False -> return $ Just $ FastWeakTicket r

81+

82+foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal

83+#else

84+getFastWeakTicket w = do

85+ deRefWeak w >>= \case

86+ Nothing -> return Nothing

87+ Just v -> return $ Just $ FastWeakTicket

88+ { _fastWeakTicket_val = v

89+ , _fastWeakTicket_weak = w

90+ }

91+#endif

92+

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

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

66mkFastWeakTicket :: a -> IO (FastWeakTicket a)

94mkFastWeakTicket :: a -> IO (FastWeakTicket a)

67#ifdef ghcjs_HOST_OS

95#ifdef ghcjs_HOST_OS

@@ -85,3 +113,17 @@ foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWe

85getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

113getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

86getFastWeakTicketWeak = return . _fastWeakTicket_weak

114getFastWeakTicketWeak = return . _fastWeakTicket_weak

87#endif

115#endif

116+

117+-- | A weak reference that is always empty

118+emptyFastWeak :: FastWeak a

119+emptyFastWeak = unsafeCoerce w

120+ where w :: FastWeak Any

121+#ifdef ghcjs_HOST_OS

122+ w = js_emptyWeak

123+foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any

124+#else

125+ w = unsafePerformIO $ do

126+ w' <- mkWeakPtr undefined Nothing

127+ finalize w'

128+ return w'

129+#endif

src/Reflex/Spider/Internal.hs+20−18

@@ -255,7 +255,6 @@ pushCheap f e = Event $ \sub -> do

255data CacheSubscribed x a

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

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

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

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

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

260 }

259 }

261

260

@@ -273,13 +272,13 @@ cacheEvent e =

273#else

272#else

274 Event $

273 Event $

275#endif

274#endif

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

275+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

277− !mSubscribedRef = unsafeNewIORef e Nothing

276+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak

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

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

279#ifdef DEBUG_TRACE_EVENTS

278#ifdef DEBUG_TRACE_EVENTS

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

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

281#endif

280#endif

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

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

283 Just subscribedTicket -> return subscribedTicket

282 Just subscribedTicket -> return subscribedTicket

284 Nothing -> do

283 Nothing -> do

285 subscribers <- liftIO FastWeakBag.empty

284 subscribers <- liftIO FastWeakBag.empty

@@ -300,27 +299,30 @@ cacheEvent e =

300 let !subscribed = CacheSubscribed

299 let !subscribed = CacheSubscribed

301 { _cacheSubscribed_subscribers = subscribers

300 { _cacheSubscribed_subscribers = subscribers

302 , _cacheSubscribed_parent = parentSub

301 , _cacheSubscribed_parent = parentSub

303− , _cacheSubscribed_cached = mSubscribedRef

304 , _cacheSubscribed_occurrence = occRef

302 , _cacheSubscribed_occurrence = occRef

305 }

303 }

306 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

304 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

307− liftIO $ writeIORef mSubscribedRef $ Just subscribedTicket

305+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

308 return subscribedTicket

306 return subscribedTicket

309 liftIO $ do

307 liftIO $ do

310− let subscribed = fastWeakTicketValue subscribedTicket

308+ subscribed <- getFastWeakTicketValue subscribedTicket

311− subscribedWeak <- getFastWeakTicketWeak subscribedTicket

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

309+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

313 occ <- readIORef $ _cacheSubscribed_occurrence subscribed

310 occ <- readIORef $ _cacheSubscribed_occurrence subscribed

311+ let es = EventSubscription

312+ { _eventSubscription_unsubscribe = do

313+ FastWeakBag.remove ticket

314+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

315+ when isEmpty $ do

316+ writeIORef mSubscribedRef emptyFastWeak

317+ unsubscribe $ _cacheSubscribed_parent subscribed

318+ touch ticket

319+ touch subscribedTicket

314− let es = EventSubscribed

320+ , _eventSubscription_subscribed = EventSubscribed

315− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

321+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

316− , eventSubscribedRetained = toAny subscribed

322+ , eventSubscribedRetained = toAny subscribedTicket

323+ }

317 }

324 }

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

325+ return (es, occ)

319−

320−cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

321−cleanupCacheSubscribed self = do

322− unsubscribe $ _cacheSubscribed_parent self

323− writeIORef (_cacheSubscribed_cached self) Nothing

324

326

325subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

327subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

326subscribe e s = fst <$> subscribeAndRead e s

328subscribe e s = fst <$> subscribeAndRead e s