jsaddle 0.9.2.0 → 0.9.2.1

raw patch · 5 files changed

+70/−28 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• jsaddle.cabal +1/−1
• src/Language/Javascript/JSaddle/Native/Internal.hs +3/−3
• src/Language/Javascript/JSaddle/Run.hs +33/−12
• src/Language/Javascript/JSaddle/Run/Files.hs +27/−10
• src/Language/Javascript/JSaddle/Types.hs +6/−2

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

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

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

@@ -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\

@@ -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)