be50627 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

WIP: probably has a race condition

be50627Ryan Trinkle9 years ago

src/Data/FastWeakBag.hs+56−4

compare with develop

unifiedsplit

@@ -4,6 +4,10 @@

4#ifdef USE_REFLEX_OPTIMIZER

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

6#endif

7+#ifdef ghcjs_HOST_OS

8+{-# LANGUAGE ForeignFunctionInterface #-}

9+{-# LANGUAGE JavaScriptFFI #-}

10+#endif

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

11-- | 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.

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

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

@@ -18,7 +22,9 @@ module Data.FastWeakBag

18 , remove

22 , remove

19 -- * Internal functions

23 -- * Internal functions

20 -- These will not always be available.

24 -- These will not always be available.

25+#ifndef ghcjs_HOST_OS

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

26 , _weakBag_children --TODO: Don't export this

27+#endif

22 ) where

28 ) where

24import Control.Exception

30import Control.Exception

@@ -30,31 +36,48 @@ import qualified Data.IntMap.Strict as IntMap

30import Data.IORef

36import Data.IORef

31import System.Mem.Weak

37import System.Mem.Weak

39+#ifdef ghcjs_HOST_OS

40+import GHCJS.Types

41+import Reflex.FastWeak (unsafeFromRawJSVal, unsafeToRawJSVal, js_isNull)

42+#endif

43+

33import Prelude hiding (mapM_, traverse)

44import Prelude hiding (mapM_, traverse)

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

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

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

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

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

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

49+#ifdef ghcjs_HOST_OS

50+newtype FastWeakBag a = FastWeakBag JSVal

51+#else

38data FastWeakBag a = FastWeakBag

52data FastWeakBag a = FastWeakBag

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

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

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

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

41 }

55 }

56+#endif

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

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

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

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

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

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

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

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

62+#ifdef ghcjs_HOST_OS

63+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal

64+#else

47−data FastWeakBagTicket = forall a. FastWeakBagTicket

65+data FastWeakBagTicket a = forall FastWeakBagTicket

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

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

49 , _weakBagTicket_item :: {-# NOUNPACK #-} !a

67 , _weakBagTicket_item :: {-# NOUNPACK #-} !a

50 }

68 }

69+#endif

52-- | Insert an item into a 'FastWeakBag'.

71-- | Insert an item into a 'FastWeakBag'.

53{-# INLINE insert #-}

72{-# INLINE insert #-}

54insert :: a -- ^ The item

73insert :: a -- ^ The item

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

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

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

75+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item

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

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

77+#ifdef ghcjs_HOST_OS

78+insert a wb = js_insert (unsafeToRawJSVal a) wb

79+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)

80+#else

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

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

59 a' <- evaluate a

82 a' <- evaluate a

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

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

@@ -65,10 +88,15 @@ insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do

65 { _weakBagTicket_weakItem = wa

88 { _weakBagTicket_weakItem = wa

66 , _weakBagTicket_item = a'

89 , _weakBagTicket_item = a'

67 }

90 }

91+#endif

69-- | Create an empty 'FastWeakBag'.

93-- | Create an empty 'FastWeakBag'.

70{-# INLINE empty #-}

94{-# INLINE empty #-}

71empty :: IO (FastWeakBag a)

95empty :: IO (FastWeakBag a)

96+#ifdef ghcjs_HOST_OS

97+empty = js_empty

98+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)

99+#else

72empty = {-# SCC "empty" #-} do

100empty = {-# SCC "empty" #-} do

73 nextId <- newIORef 1

101 nextId <- newIORef 1

74 children <- newIORef IntMap.empty

102 children <- newIORef IntMap.empty

@@ -77,29 +105,53 @@ empty = {-# SCC "empty" #-} do

77 , _weakBag_children = children

105 , _weakBag_children = children

78 }

106 }

79 return bag

107 return bag

108+#endif

109

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

110-- | Check whether a 'FastWeakBag' is empty.

82{-# INLINE isEmpty #-}

111{-# INLINE isEmpty #-}

83isEmpty :: FastWeakBag a -> IO Bool

112isEmpty :: FastWeakBag a -> IO Bool

113+#ifdef ghcjs_HOST_OS

114+isEmpty = js_isEmpty

115+foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time

116+#else

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

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

118+#endif

119

86{-# INLINE traverse #-}

120{-# INLINE traverse #-}

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

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

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

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

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

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

90-- is made about the order of the traversal.

124-- is made about the order of the traversal.

91−traverse :: MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

126+#ifdef ghcjs_HOST_OS

127+traverse wb f = do

128+ let go cursor = when (not $ js_isNull cursor) $ do

129+ val <- liftIO $ js_getTicketValue cursor

130+ f $ unsafeFromRawJSVal val

131+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))

132+ go =<< liftIO (js_getInitial wb)

133+foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a

134+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal

135+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag

136+foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a

137+#else

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

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

93 cs <- liftIO $ readIORef children

139 cs <- liftIO $ readIORef children

94 forM_ cs $ \c -> do

140 forM_ cs $ \c -> do

95 ma <- liftIO $ deRefWeak c

141 ma <- liftIO $ deRefWeak c

96 mapM_ f ma

142 mapM_ f ma

143+#endif

144

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

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

99-- on the same 'FastWeakBagTicket'.

146-- on the same 'FastWeakBagTicket'.

100{-# INLINE remove #-}

147{-# INLINE remove #-}

101−remove :: FastWeakBagTicket -> IO ()

148+remove :: FastWeakBagTicket a -> IO ()

149+#ifdef ghcjs_HOST_OS

150+remove = js_remove

151+foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here

152+#else

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

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

154+#endif

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

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

104

156

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

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

src/Reflex/FastWeak.hs+16−3

@@ -14,6 +14,12 @@ module Reflex.FastWeak

14 , getFastWeakValue

15 , getFastWeakTicket

16 , emptyFastWeak

17+#ifdef ghcjs_HOST_OS

18+ --TODO: Move these elsewhere

19+ , unsafeFromRawJSVal

20+ , unsafeToRawJSVal

21+ , js_isNull

22+#endif

17 ) where

23 ) where

19import GHC.Exts (Any)

25import GHC.Exts (Any)

@@ -35,6 +41,13 @@ newtype FastWeak a = FastWeak JSVal

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

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

37data Val a = Val { unVal :: a }

43data Val a = Val { unVal :: a }

44+

45+-- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a'

46+unsafeFromRawJSVal :: JSVal -> a

47+unsafeFromRawJSVal v = unVal (unsafeCoerce v)

48+

49+unsafeToRawJSVal :: a -> JSVal

50+unsafeToRawJSVal v = unsafeCoerce (Val v)

38#else

51#else

39data FastWeakTicket a = FastWeakTicket

52data FastWeakTicket a = FastWeakTicket

40 { _fastWeakTicket_val :: !a

53 { _fastWeakTicket_val :: !a

@@ -49,7 +62,7 @@ getFastWeakTicketValue :: FastWeakTicket a -> IO a

49#ifdef ghcjs_HOST_OS

62#ifdef ghcjs_HOST_OS

50getFastWeakTicketValue t = do

63getFastWeakTicketValue t = do

51 v <- js_ticketVal t

64 v <- js_ticketVal t

52− return $ unVal (unsafeCoerce v)

65+ return $ unsafeFromRawJSVal v

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

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

55#else

68#else

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

62 r <- js_weakVal w

75 r <- js_weakVal w

63 case js_isNull r of

76 case js_isNull r of

64 True -> return Nothing

77 True -> return Nothing

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

78+ False -> return $ Just $ unsafeFromRawJSVal r

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

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

@@ -93,7 +106,7 @@ getFastWeakTicket w = do

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

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

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

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

95#ifdef ghcjs_HOST_OS

108#ifdef ghcjs_HOST_OS

96−mkFastWeakTicket v = js_fastWeakTicket (unsafeCoerce (Val v))

109+mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)

110

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

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

99#else

112#else