diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.9.2.0 +version: 0.9.2.1 cabal-version: >=1.10 build-type: Simple license: MIT diff --git a/src/Language/Javascript/JSaddle/Native/Internal.hs b/src/Language/Javascript/JSaddle/Native/Internal.hs --- a/src/Language/Javascript/JSaddle/Native/Internal.hs +++ b/src/Language/Javascript/JSaddle/Native/Internal.hs @@ -62,9 +62,9 @@ wrapJSString (JSStringReceived ref) = return $ JSString ref withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a -withJSVal v@(JSVal ref) f = - do result <- f (JSValueForSend ref) - liftIO $ touch v +withJSVal (JSVal ref) f = do + result <- f (JSValueForSend ref) + liftIO $ touch ref return result withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a diff --git a/src/Language/Javascript/JSaddle/Run.hs b/src/Language/Javascript/JSaddle/Run.hs --- a/src/Language/Javascript/JSaddle/Run.hs +++ b/src/Language/Javascript/JSaddle/Run.hs @@ -2,6 +2,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Run @@ -39,25 +41,28 @@ import qualified JavaScript.Web.AnimationFrame as GHCJS (waitForAnimationFrame) #else -import Control.Exception (throwIO) +import Control.Exception (throwIO, evaluate) import Control.Monad (void, when, zipWithM_) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask, runReaderT) import Control.Monad.STM (atomically) -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO, myThreadId) import Control.Concurrent.STM.TChan (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO) import Control.Concurrent.STM.TVar (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO) import Control.Concurrent.MVar - (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar) + (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar) import System.IO.Unsafe (unsafeInterleaveIO) import System.Mem.Weak (addFinalizer) +import GHC.Base (IO(..), mkWeak#) +import GHC.Conc (ThreadId(..)) import Data.Monoid ((<>)) -import qualified Data.Text as T (unpack) +import qualified Data.Text as T (unpack, pack) import qualified Data.Map as M (lookup, delete, insert, empty, size) +import qualified Data.Set as S (empty, member, insert, delete) import Data.UUID.V4 (nextRandom) import Data.Time.Clock (getCurrentTime,diffUTCTime) import Data.IORef (newIORef, atomicWriteIORef, readIORef) @@ -66,7 +71,6 @@ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..), Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..)) import Language.Javascript.JSaddle.Exception (JSException(..)) --- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal) import Control.DeepSeq (deepseq) import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..)) #endif @@ -137,7 +141,7 @@ nextRefTVar <- nextRef <$> JSM ask n <- liftIO . atomically $ do n <- subtract 1 <$> readTVar nextRefTVar - writeTVar nextRefTVar n + writeTVar nextRefTVar $! n return n s <- doSendAsyncCommand <$> JSM ask liftIO $ s (cmd $ JSValueForSend n) @@ -157,6 +161,7 @@ commandChan <- newTChanIO callbacks <- newTVarIO M.empty nextRef' <- newTVarIO 0 + finalizerThreads' <- newMVar S.empty loggingEnabled <- newIORef False let ctx = JSContextRef { contextId = contextId' @@ -173,13 +178,14 @@ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val) , nextRef = nextRef' , doEnableLogging = atomicWriteIORef loggingEnabled + , finalizerThreads = finalizerThreads' } let processResults :: Bool -> Results -> IO () processResults syncCallbacks = \case (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err - (Callback n br f this a) -> do + (Callback n br (JSValueReceived fNumber) f this a) -> do putMVar recvMVar (n, br) - f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx + f' <- runReaderT (unJSM $ wrapJSVal f) ctx this' <- runReaderT (unJSM $ wrapJSVal this) ctx args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx logInfo (("Call " <> show fNumber <> " ") <>) @@ -208,7 +214,7 @@ True -> show . currentBytesUsed <$> getGCStats False -> return "??" cbCount <- M.size <$> readTVarIO callbacks - putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount + putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " " False -> return () _ <- forkIO . numberForeverFromM_ 1 $ \nBatch -> readBatch nBatch commandChan >>= \case @@ -230,7 +236,7 @@ where numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m () numberForeverFromM_ !n f = do - f n + _ <- f n numberForeverFromM_ (succ n) f takeResult recvMVar nBatch = takeMVar recvMVar >>= \case @@ -264,12 +270,27 @@ loopAnimation (Left asyncCmd) (cmds, resultMVars) = atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars) +addThreadFinalizer :: ThreadId -> IO () -> IO () +addThreadFinalizer t@(ThreadId t#) (IO finalizer) = + IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) } + wrapJSVal :: JSValueReceived -> JSM JSVal wrapJSVal (JSValueReceived ref) = do -- TODO make sure this ref has not already been wrapped (perhaps only in debug version) let result = JSVal ref - when (ref >= 5) $ do + when (ref >= 5 || ref < 0) $ do ctx <- JSM ask - liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref + liftIO . addFinalizer ref $ do + ft <- takeMVar $ finalizerThreads ctx + t <- myThreadId + let tname = T.pack $ show t + doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref + if tname `S.member` ft + then putMVar (finalizerThreads ctx) ft + else do + addThreadFinalizer t $ do + modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ()) + doSendAsyncCommand ctx $ FreeRefs tname + putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft) return result #endif diff --git a/src/Language/Javascript/JSaddle/Run/Files.hs b/src/Language/Javascript/JSaddle/Run/Files.hs --- a/src/Language/Javascript/JSaddle/Run/Files.hs +++ b/src/Language/Javascript/JSaddle/Run/Files.hs @@ -37,6 +37,7 @@ initState :: ByteString initState = "\ \ var jsaddle_values = new Map();\n\ + \ var jsaddle_free = new Map();\n\ \ jsaddle_values.set(0, null);\n\ \ jsaddle_values.set(1, undefined);\n\ \ jsaddle_values.set(2, false);\n\ @@ -67,8 +68,16 @@ \ var d = cmd.Left;\n\ \ switch (d.tag) {\n\ \ case \"FreeRef\":\n\ - \ jsaddle_values.delete(d.contents);\n\ + \ var refsToFree = jsaddle_free.get(d.contents[0]) || [];\n\ + \ refsToFree.push(d.contents[1]);\n\ + \ jsaddle_free.set(d.contents[0], refsToFree);\n\ \ break;\n\ + \ case \"FreeRefs\":\n\ + \ var refsToFree = jsaddle_free.get(d.contents) || [];\n\ + \ for(var nRef = 0; nRef != refsToFree.length; nRef++)\n\ + \ jsaddle_values.delete(refsToFree[nRef]);\n\ + \ jsaddle_free.delete(d.contents);\n\ + \ break;\n\ \ case \"SetPropertyByName\":\n\ \ jsaddle_values.get(d.contents[0])[d.contents[1]]=jsaddle_values.get(d.contents[2]);\n\ \ break;\n\ @@ -102,7 +111,9 @@ \ case \"NewAsyncCallback\":\n\ \ (function() {\n\ \ var nFunction = d.contents;\n\ - \ jsaddle_values.set(nFunction, function() {\n\ + \ var func = function() {\n\ + \ var nFunctionInFunc = ++jsaddle_index;\n\ + \ jsaddle_values.set(nFunctionInFunc, func);\n\ \ var nThis = ++jsaddle_index;\n\ \ jsaddle_values.set(nThis, this);\n\ \ var args = [];\n\ @@ -111,13 +122,17 @@ \ jsaddle_values.set(nArg, arguments[i]);\n\ \ args[i] = nArg;\n\ \ }\n\ - \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\ - \ })})();\n\ + \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\ + \ };\n\ + \ jsaddle_values.set(nFunction, func);\n\ + \ })();\n\ \ break;\n\ \ case \"NewSyncCallback\":\n\ \ (function() {\n\ \ var nFunction = d.contents;\n\ - \ jsaddle_values.set(nFunction, function() {\n\ + \ var func = function() {\n\ + \ var nFunctionInFunc = ++jsaddle_index;\n\ + \ jsaddle_values.set(nFunctionInFunc, func);\n\ \ var nThis = ++jsaddle_index;\n\ \ jsaddle_values.set(nThis, this);\n\ \ var args = [];\n\ @@ -129,14 +144,16 @@ case sendSync of Just s -> " if(inCallback > 0) {\n\ - \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\ + \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\ \ } else {\n\ - \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\ + \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\ \ }\n" Nothing -> - " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n" + " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n" ) <> - " })})();\n\ + " };\n\ + \ jsaddle_values.set(nFunction, func);\n\ + \ })();\n\ \ break;\n\ \ case \"CallAsFunction\":\n\ \ var n = d.contents[3];\n\ @@ -179,7 +196,7 @@ \ jsaddle_values.set(n, d.contents[0].map(function(v){return jsaddle_values.get(v);}));\n\ \ break;\n\ \ case \"SyncWithAnimationFrame\":\n\ - \ var n = d.contents[0];\n\ + \ var n = d.contents;\n\ \ jsaddle_values.set(n, timestamp);\n\ \ break;\n\ \ case \"StartSyncBlock\":\n\ diff --git a/src/Language/Javascript/JSaddle/Types.hs b/src/Language/Javascript/JSaddle/Types.hs --- a/src/Language/Javascript/JSaddle/Types.hs +++ b/src/Language/Javascript/JSaddle/Types.hs @@ -106,6 +106,8 @@ import Control.Monad.Fix (MonadFix) import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..)) import Control.Concurrent.STM.TVar (TVar) +import Control.Concurrent.MVar (MVar) +import Data.Set (Set) import Data.Text (Text) import Data.UUID (UUID) import Data.Time.Clock (UTCTime(..)) @@ -138,6 +140,7 @@ , freeCallback :: Object -> IO () , nextRef :: TVar JSValueRef , doEnableLogging :: Bool -> IO () + , finalizerThreads :: MVar (Set Text) } #endif @@ -360,7 +363,8 @@ instance NFData JSStringForSend -- | Command sent to a JavaScript context for execution asynchronously -data AsyncCommand = FreeRef JSValueForSend +data AsyncCommand = FreeRef Text JSValueForSend + | FreeRefs Text | SetPropertyByName JSObjectForSend JSStringForSend JSValueForSend | SetPropertyAtIndex JSObjectForSend Int JSValueForSend | StringToValue JSStringForSend JSValueForSend @@ -452,7 +456,7 @@ data Results = BatchResults Int BatchResults | Duplicate Int Int - | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived] + | Callback Int BatchResults JSValueReceived JSValueReceived JSValueReceived [JSValueReceived] | ProtocolError Text deriving (Show, Generic)