a4ff79c · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Fix memory leaks

a4ff79cHamish Mackenzie9 years ago

jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+3−3

compare with master

unifiedsplit

@@ -62,9 +62,9 @@ wrapJSString :: MonadIO m => JSStringReceived -> m JSString

62wrapJSString (JSStringReceived ref) = return $ JSString ref

64withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a

65−withJSVal v@(JSVal ref) f =

65+withJSVal v@(JSVal ref) f = do

66− do result <- f (JSValueForSend ref)

66+ result <- f (JSValueForSend ref)

67− liftIO $ touch v

67+ liftIO $ touch ref

68 return result

70withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a

jsaddle/src/Language/Javascript/JSaddle/Run.hs+35−12

@@ -2,6 +2,8 @@

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE MagicHash #-}

6+{-# LANGUAGE UnboxedTuples #-}

5-----------------------------------------------------------------------------

7-----------------------------------------------------------------------------

6--

8--

7-- Module : Language.Javascript.JSaddle.Run

9-- Module : Language.Javascript.JSaddle.Run

@@ -39,25 +41,30 @@ import Language.Javascript.JSaddle.Types (JSM)

39import qualified JavaScript.Web.AnimationFrame as GHCJS

41import qualified JavaScript.Web.AnimationFrame as GHCJS

40 (waitForAnimationFrame)

42 (waitForAnimationFrame)

41#else

43#else

42−import Control.Exception (throwIO)

44+import Control.Exception (throwIO, evaluate)

43import Control.Monad (void, when, zipWithM_)

45import Control.Monad (void, when, zipWithM_)

44import Control.Monad.IO.Class (MonadIO(..))

46import Control.Monad.IO.Class (MonadIO(..))

45import Control.Monad.Trans.Reader (ask, runReaderT)

47import Control.Monad.Trans.Reader (ask, runReaderT)

46import Control.Monad.STM (atomically)

48import Control.Monad.STM (atomically)

47−import Control.Concurrent (forkIO)

49+import Control.Concurrent (forkIO, myThreadId)

48import Control.Concurrent.STM.TChan

50import Control.Concurrent.STM.TChan

49 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

50import Control.Concurrent.STM.TVar

52import Control.Concurrent.STM.TVar

51 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

53 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

52import Control.Concurrent.MVar

54import Control.Concurrent.MVar

53− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)

55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)

55import System.IO.Unsafe (unsafeInterleaveIO)

57import System.IO.Unsafe (unsafeInterleaveIO)

56−import System.Mem.Weak (addFinalizer)

58+import System.Mem.Weak (addFinalizer, mkWeak)

60+import GHC.Int (Int64(..))

61+import GHC.Base (IO(..), mkWeak#)

62+import GHC.Conc (ThreadId(..))

58import Data.Monoid ((<>))

63import Data.Monoid ((<>))

59−import qualified Data.Text as T (unpack)

64+import qualified Data.Text as T (unpack, pack)

60import qualified Data.Map as M (lookup, delete, insert, empty, size)

65import qualified Data.Map as M (lookup, delete, insert, empty, size)

66+import Data.Set (Set)

67+import qualified Data.Set as S (empty, member, insert, delete)

61import Data.UUID.V4 (nextRandom)

68import Data.UUID.V4 (nextRandom)

62import Data.Time.Clock (getCurrentTime,diffUTCTime)

69import Data.Time.Clock (getCurrentTime,diffUTCTime)

63import Data.IORef (newIORef, atomicWriteIORef, readIORef)

70import Data.IORef (newIORef, atomicWriteIORef, readIORef)

@@ -66,7 +73,6 @@ import Language.Javascript.JSaddle.Types

66 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

73 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

67 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

74 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

68import Language.Javascript.JSaddle.Exception (JSException(..))

75import Language.Javascript.JSaddle.Exception (JSException(..))

69−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

70import Control.DeepSeq (deepseq)

76import Control.DeepSeq (deepseq)

71import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

77import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

72#endif

78#endif

@@ -137,7 +143,7 @@ sendLazyCommand cmd = do

137 nextRefTVar <- nextRef <$> JSM ask

143 nextRefTVar <- nextRef <$> JSM ask

138 n <- liftIO . atomically $ do

144 n <- liftIO . atomically $ do

139 n <- subtract 1 <$> readTVar nextRefTVar

145 n <- subtract 1 <$> readTVar nextRefTVar

140− writeTVar nextRefTVar n

146+ writeTVar nextRefTVar $! n

141 return n

147 return n

142 s <- doSendAsyncCommand <$> JSM ask

148 s <- doSendAsyncCommand <$> JSM ask

143 liftIO $ s (cmd $ JSValueForSend n)

149 liftIO $ s (cmd $ JSValueForSend n)

@@ -157,6 +163,7 @@ runJavaScript sendBatch entryPoint = do

157 commandChan <- newTChanIO

163 commandChan <- newTChanIO

158 callbacks <- newTVarIO M.empty

164 callbacks <- newTVarIO M.empty

159 nextRef' <- newTVarIO 0

165 nextRef' <- newTVarIO 0

166+ finalizerThreads <- newMVar S.empty

160 loggingEnabled <- newIORef False

167 loggingEnabled <- newIORef False

161 let ctx = JSContextRef {

168 let ctx = JSContextRef {

162 contextId = contextId'

169 contextId = contextId'

@@ -173,13 +180,14 @@ runJavaScript sendBatch entryPoint = do

173 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)

180 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)

174 , nextRef = nextRef'

181 , nextRef = nextRef'

175 , doEnableLogging = atomicWriteIORef loggingEnabled

182 , doEnableLogging = atomicWriteIORef loggingEnabled

183+ , finalizerThreads = finalizerThreads

176 }

184 }

177 let processResults :: Bool -> Results -> IO ()

185 let processResults :: Bool -> Results -> IO ()

178 processResults syncCallbacks = \case

186 processResults syncCallbacks = \case

179 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

187 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

180− (Callback n br f this a) -> do

188+ (Callback n br (JSValueReceived fNumber) f this a) -> do

181 putMVar recvMVar (n, br)

189 putMVar recvMVar (n, br)

182− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

190+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx

183 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

191 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

184 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

192 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

185 logInfo (("Call " <> show fNumber <> " ") <>)

193 logInfo (("Call " <> show fNumber <> " ") <>)

@@ -208,7 +216,7 @@ runJavaScript sendBatch entryPoint = do

208 True -> show . currentBytesUsed <$> getGCStats

216 True -> show . currentBytesUsed <$> getGCStats

209 False -> return "??"

217 False -> return "??"

210 cbCount <- M.size <$> readTVarIO callbacks

218 cbCount <- M.size <$> readTVarIO callbacks

211− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount

219+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "

212 False -> return ()

220 False -> return ()

213 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

221 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->

214 readBatch nBatch commandChan >>= \case

222 readBatch nBatch commandChan >>= \case

@@ -264,12 +272,27 @@ runJavaScript sendBatch entryPoint = do

264 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

272 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

265 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)

273 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)

266

274

275+addThreadFinalizer :: ThreadId -> IO () -> IO ()

276+addThreadFinalizer t@(ThreadId t#) (IO finalizer) =

277+ IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }

278+

267wrapJSVal :: JSValueReceived -> JSM JSVal

279wrapJSVal :: JSValueReceived -> JSM JSVal

268wrapJSVal (JSValueReceived ref) = do

280wrapJSVal (JSValueReceived ref) = do

269 -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

281 -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)

270 let result = JSVal ref

282 let result = JSVal ref

271− when (ref >= 5) $ do

283+ when (ref >= 5 || ref < 0) $ do

272 ctx <- JSM ask

284 ctx <- JSM ask

285+ liftIO . addFinalizer ref $ do

286+ ft <- takeMVar $ finalizerThreads ctx

287+ t@(ThreadId t#) <- myThreadId

288+ let tname = T.pack $ show t

273− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref

289+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref

290+ if tname `S.member` ft

291+ then putMVar (finalizerThreads ctx) ft

292+ else do

293+ addThreadFinalizer t $ do

294+ modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())

295+ doSendAsyncCommand ctx $ FreeRefs tname

296+ putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)

274 return result

297 return result

275#endif

298#endif

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+27−10

@@ -37,6 +37,7 @@ indexHtml =

37initState :: ByteString

38initState = "\

39 \ var jsaddle_values = new Map();\n\

40+ \ var jsaddle_free = new Map();\n\

40 \ jsaddle_values.set(0, null);\n\

41 \ jsaddle_values.set(0, null);\n\

41 \ jsaddle_values.set(1, undefined);\n\

42 \ jsaddle_values.set(1, undefined);\n\

42 \ jsaddle_values.set(2, false);\n\

43 \ jsaddle_values.set(2, false);\n\

@@ -67,7 +68,15 @@ runBatch send sendSync = "\

67 \ var d = cmd.Left;\n\

68 \ var d = cmd.Left;\n\

68 \ switch (d.tag) {\n\

69 \ switch (d.tag) {\n\

69 \ case \"FreeRef\":\n\

70 \ case \"FreeRef\":\n\

71+ \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\

72+ \ refsToFree.push(d.contents[1]);\n\

73+ \ jsaddle_free.set(d.contents[0], refsToFree);\n\

74+ \ break;\n\

75+ \ case \"FreeRefs\":\n\

76+ \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\

77+ \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\

70− \ jsaddle_values.delete(d.contents);\n\

78+ \ jsaddle_values.delete(refsToFree[nRef]);\n\

79+ \ jsaddle_free.delete(d.contents);\n\

71 \ break;\n\

80 \ break;\n\

72 \ case \"SetPropertyByName\":\n\

81 \ case \"SetPropertyByName\":\n\

73 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\

82 \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\

@@ -102,7 +111,9 @@ runBatch send sendSync = "\

102 \ case \"NewAsyncCallback\":\n\

111 \ case \"NewAsyncCallback\":\n\

103 \ (function() {\n\

112 \ (function() {\n\

104 \ var nFunction = d.contents;\n\

113 \ var nFunction = d.contents;\n\

114+ \ var func = function() {\n\

115+ \ var nFunctionInFunc = ++jsaddle_index;\n\

105− \ jsaddle_values.set(nFunction, function() {\n\

116+ \ jsaddle_values.set(nFunctionInFunc, func);\n\

106 \ var nThis = ++jsaddle_index;\n\

117 \ var nThis = ++jsaddle_index;\n\

107 \ jsaddle_values.set(nThis, this);\n\

118 \ jsaddle_values.set(nThis, this);\n\

108 \ var args = [];\n\

119 \ var args = [];\n\

@@ -111,13 +122,17 @@ runBatch send sendSync = "\

111 \ jsaddle_values.set(nArg, arguments[i]);\n\

122 \ jsaddle_values.set(nArg, arguments[i]);\n\

112 \ args[i] = nArg;\n\

123 \ args[i] = nArg;\n\

113 \ }\n\

124 \ }\n\

114− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

125+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\

126+ \ };\n\

127+ \ jsaddle_values.set(nFunction, func);\n\

115− \ })})();\n\

128+ \ })();\n\

116 \ break;\n\

129 \ break;\n\

117 \ case \"NewSyncCallback\":\n\

130 \ case \"NewSyncCallback\":\n\

118 \ (function() {\n\

131 \ (function() {\n\

119 \ var nFunction = d.contents;\n\

132 \ var nFunction = d.contents;\n\

133+ \ var func = function() {\n\

134+ \ var nFunctionInFunc = ++jsaddle_index;\n\

120− \ jsaddle_values.set(nFunction, function() {\n\

135+ \ jsaddle_values.set(nFunctionInFunc, func);\n\

121 \ var nThis = ++jsaddle_index;\n\

136 \ var nThis = ++jsaddle_index;\n\

122 \ jsaddle_values.set(nThis, this);\n\

137 \ jsaddle_values.set(nThis, this);\n\

123 \ var args = [];\n\

138 \ var args = [];\n\

@@ -129,14 +144,16 @@ runBatch send sendSync = "\

129 case sendSync of

144 case sendSync of

130 Just s ->

145 Just s ->

131 " if(inCallback > 0) {\n\

146 " if(inCallback > 0) {\n\

132− \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

147+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\

133 \ } else {\n\

148 \ } else {\n\

134− \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\

149+ \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\

135 \ }\n"

150 \ }\n"

136 Nothing ->

151 Nothing ->

137− " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n"

152+ " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n"

138 ) <>

153 ) <>

154+ " };\n\

155+ \ jsaddle_values.set(nFunction, func);\n\

139− " })})();\n\

156+ \ })();\n\

140 \ break;\n\

157 \ break;\n\

141 \ case \"CallAsFunction\":\n\

158 \ case \"CallAsFunction\":\n\

142 \ var n = d.contents[3];\n\

159 \ var n = d.contents[3];\n\

@@ -179,7 +196,7 @@ runBatch send sendSync = "\

179 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\

196 \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\

180 \ break;\n\

197 \ break;\n\

181 \ case \"SyncWithAnimationFrame\":\n\

198 \ case \"SyncWithAnimationFrame\":\n\

182− \ var n = d.contents[0];\n\

199+ \ var n = d.contents;\n\

183 \ jsaddle_values.set(n, timestamp);\n\

200 \ jsaddle_values.set(n, timestamp);\n\

184 \ break;\n\

201 \ break;\n\

185 \ case \"StartSyncBlock\":\n\

202 \ case \"StartSyncBlock\":\n\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+6−2

@@ -106,6 +106,8 @@ import Control.Monad.Trans.Class (MonadTrans(..))

106import Control.Monad.Fix (MonadFix)

107import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..))

108import Control.Concurrent.STM.TVar (TVar)

109+import Control.Concurrent.MVar (MVar)

110+import Data.Set (Set)

109import Data.Text (Text)

111import Data.Text (Text)

110import Data.UUID (UUID)

112import Data.UUID (UUID)

111import Data.Time.Clock (UTCTime(..))

113import Data.Time.Clock (UTCTime(..))

@@ -138,6 +140,7 @@ data JSContextRef = JSContextRef {

138 , freeCallback :: Object -> IO ()

140 , freeCallback :: Object -> IO ()

139 , nextRef :: TVar JSValueRef

141 , nextRef :: TVar JSValueRef

140 , doEnableLogging :: Bool -> IO ()

142 , doEnableLogging :: Bool -> IO ()

143+ , finalizerThreads :: MVar (Set Text)

141}

144}

142#endif

145#endif

143

146

@@ -360,7 +363,8 @@ newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON,

360instance NFData JSStringForSend

363instance NFData JSStringForSend

361

364

362-- | Command sent to a JavaScript context for execution asynchronously

365-- | Command sent to a JavaScript context for execution asynchronously

363−data AsyncCommand = FreeRef JSValueForSend

366+data AsyncCommand = FreeRef Text JSValueForSend

367+ | FreeRefs Text

364 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

368 | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend

365 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

369 | SetPropertyAtIndex JSObjectForSend Int JSValueForSend

366 | StringToValue JSStringForSend JSValueForSend

370 | StringToValue JSStringForSend JSValueForSend

@@ -452,7 +456,7 @@ instance FromJSON BatchResults

452

456

453data Results = BatchResults Int BatchResults

457data Results = BatchResults Int BatchResults

454 | Duplicate Int Int

458 | Duplicate Int Int

455− | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived]

459+ | Callback Int BatchResults JSValueReceived JSValueReceived JSValueReceived [JSValueReceived]

456 | ProtocolError Text

460 | ProtocolError Text

457 deriving (Show, Generic)

461 deriving (Show, Generic)

458

462