diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.9.2.1 +version: 0.9.3.0 cabal-version: >=1.10 build-type: Simple license: MIT @@ -42,13 +42,12 @@ ghc-prim, http-types >=0.8.6 && <0.10, process >=1.2.3.0 && <1.5, + random >= 1.1 && < 1.2, ref-tf >=0.4.0.1 && <0.5, scientific >=0.3 && <0.4, stm >=2.4.4 && <2.5, time >=1.5.0.1 && <1.8, unordered-containers >=0.2 && <0.3, - uuid >=1.3.13 && <1.4, - uuid-types >=1.0.3 && <1.1, vector >=0.10 && <0.13 exposed-modules: Data.JSString @@ -63,6 +62,7 @@ GHCJS.Prim GHCJS.Prim.Internal GHCJS.Types + GHCJS.Concurrent GHCJS.Foreign GHCJS.Foreign.Internal GHCJS.Internal.Types diff --git a/src-ghc/GHCJS/Concurrent.hs b/src-ghc/GHCJS/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src-ghc/GHCJS/Concurrent.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module GHCJS.Concurrent ( OnBlocked(..) + , WouldBlockException(..) + ) where + +import GHCJS.Prim + +import Data.Data + +{- | + The runtime tries to run synchronous threads to completion. Sometimes it's + not possible to continue running a thread, for example when the thread + tries to take an empty 'MVar'. The runtime can then either throw a + 'WouldBlockException', aborting the blocking action, or continue the + thread asynchronously. + -} + +data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked + | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked + deriving (Data, Typeable, Enum, Show, Eq, Ord) + diff --git a/src/Language/Javascript/JSaddle/Debug.hs b/src/Language/Javascript/JSaddle/Debug.hs --- a/src/Language/Javascript/JSaddle/Debug.hs +++ b/src/Language/Javascript/JSaddle/Debug.hs @@ -26,7 +26,7 @@ import System.IO.Unsafe (unsafePerformIO) import Data.Monoid ((<>)) import Control.Monad.IO.Class (MonadIO(..)) -import Data.UUID (UUID) +import Data.Int (Int64) contexts :: IORef [JSContextRef] contexts = unsafePerformIO $ newIORef [] @@ -37,9 +37,9 @@ ctx <- askJSM liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ()) -removeContext :: MonadIO m => UUID -> m () -removeContext uuid = - liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= uuid) . contextId) c, ()) +removeContext :: MonadIO m => Int64 -> m () +removeContext cid = + liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ()) runOnAll :: MonadIO m => JSM a -> m [a] runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f) diff --git a/src/Language/Javascript/JSaddle/Null.hs b/src/Language/Javascript/JSaddle/Null.hs --- a/src/Language/Javascript/JSaddle/Null.hs +++ b/src/Language/Javascript/JSaddle/Null.hs @@ -37,7 +37,7 @@ _ <- forkIO $ forever $ readChan batches >>= \case Batch commands _ batchNumber -> - processResult $ BatchResults batchNumber . Success $ mapMaybe (\case + processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case Left _ -> Nothing Right command -> Just $ case command of diff --git a/src/Language/Javascript/JSaddle/Object.hs b/src/Language/Javascript/JSaddle/Object.hs --- a/src/Language/Javascript/JSaddle/Object.hs +++ b/src/Language/Javascript/JSaddle/Object.hs @@ -119,9 +119,10 @@ (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor) import Language.Javascript.JSaddle.Monad (askJSM, JSM) import Language.Javascript.JSaddle.Types - (JSString, Object(..), SomeJSArray(..), - JSVal(..), JSCallAsFunction, JSContextRef(..)) + (JSValueForSend(..), AsyncCommand(..), JSString, Object(..), + SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..)) import JavaScript.Object.Internal (create, listProps) +import Language.Javascript.JSaddle.Run (sendAsyncCommand) #endif import JavaScript.Array.Internal (fromListIO) import Language.Javascript.JSaddle.Value (valToObject) @@ -481,9 +482,8 @@ freeFunction (Function callback _) = liftIO $ releaseCallback callback #else -freeFunction (Function object) = do - free <- freeCallback <$> askJSM - liftIO $ free object +freeFunction (Function (Object (JSVal objectRef))) = + sendAsyncCommand (FreeCallback (JSValueForSend objectRef)) #endif instance ToJSVal Function where 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 @@ -56,6 +56,7 @@ import System.IO.Unsafe (unsafeInterleaveIO) import System.Mem.Weak (addFinalizer) +import System.Random import GHC.Base (IO(..), mkWeak#) import GHC.Conc (ThreadId(..)) @@ -63,7 +64,6 @@ 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) @@ -73,6 +73,7 @@ import Language.Javascript.JSaddle.Exception (JSException(..)) import Control.DeepSeq (deepseq) import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..)) +import Data.Foldable (forM_) #endif -- | Enable (or disable) JSaddle logging @@ -154,7 +155,7 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()) runJavaScript sendBatch entryPoint = do - contextId' <- nextRandom + contextId' <- randomIO startTime' <- getCurrentTime recvMVar <- newEmptyMVar lastAsyncBatch <- newEmptyMVar @@ -162,25 +163,26 @@ callbacks <- newTVarIO M.empty nextRef' <- newTVarIO 0 finalizerThreads' <- newMVar S.empty + animationFrameHandlers' <- newMVar [] loggingEnabled <- newIORef False let ctx = JSContextRef { - contextId = contextId' - , startTime = startTime' - , doSendCommand = \cmd -> cmd `deepseq` do - result <- newEmptyMVar - atomically $ writeTChan commandChan (Right (cmd, result)) - unsafeInterleaveIO $ - takeMVar result >>= \case - (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v) - r -> return r - , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd) - , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb) - , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val) - , nextRef = nextRef' - , doEnableLogging = atomicWriteIORef loggingEnabled - , finalizerThreads = finalizerThreads' - } - let processResults :: Bool -> Results -> IO () + contextId = contextId' + , startTime = startTime' + , doSendCommand = \cmd -> cmd `deepseq` do + result <- newEmptyMVar + atomically $ writeTChan commandChan (Right (cmd, result)) + unsafeInterleaveIO $ + takeMVar result >>= \case + (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v) + r -> return r + , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd) + , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb) + , nextRef = nextRef' + , doEnableLogging = atomicWriteIORef loggingEnabled + , finalizerThreads = finalizerThreads' + , animationFrameHandlers = animationFrameHandlers' + } + processResults :: Bool -> Results -> IO () processResults syncCallbacks = \case (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err (Callback n br (JSValueReceived fNumber) f this a) -> do @@ -224,14 +226,20 @@ putMVar lastAsyncBatch batch sendBatch batch takeResult recvMVar nBatch >>= \case - (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")" - (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results" - | otherwise -> zipWithM_ putMVar resultMVars results - (_, Failure results exception) -> do - -- The exception will only be rethrown in Haskell if/when one of the - -- missing results (if any) is evaluated. - putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)" - zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception) + (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")" + (_, Success callbacksToFree results) + | length results /= length resultMVars -> error "Unexpected number of jsaddle results" + | otherwise -> do + zipWithM_ putMVar resultMVars results + forM_ callbacksToFree $ \(JSValueReceived val) -> + atomically (modifyTVar' callbacks (M.delete val)) + (_, Failure callbacksToFree results exception) -> do + -- The exception will only be rethrown in Haskell if/when one of the + -- missing results (if any) is evaluated. + putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)" + zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception) + forM_ callbacksToFree $ \(JSValueReceived val) -> + atomically (modifyTVar' callbacks (M.delete val)) return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx) where numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m () 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 @@ -47,6 +47,7 @@ \ var expectedBatch = 1;\n\ \ var lastResults = [0, {}];\n\ \ var inCallback = 0;\n\ + \ var asyncBatch = null;\n\ \" runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString @@ -54,6 +55,7 @@ \ var runBatch = function(firstBatch, initialSyncDepth) {\n\ \ var processBatch = function(timestamp) {\n\ \ var batch = firstBatch;\n\ + \ var callbacksToFree = [];\n\ \ var results = [];\n\ \ inCallback++;\n\ \ try {\n\ @@ -155,6 +157,9 @@ \ jsaddle_values.set(nFunction, func);\n\ \ })();\n\ \ break;\n\ + \ case \"FreeCallback\":\n\ + \ callbacksToFree.push(d.contents);\n\ + \ break;\n\ \ case \"CallAsFunction\":\n\ \ var n = d.contents[3];\n\ \ jsaddle_values.set(n,\n\ @@ -268,17 +273,18 @@ \ }\n\ \ }\n\ \ if(syncDepth <= 0) {\n\ - \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\ + \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\ \ break;\n\ \ } else {\n" <> ( case sendSync of Just s -> - " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\ + " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\ - \ results = [];\n" + \ results = [];\n\ + \ callbacksToFree = [];\n" Nothing -> - " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\ + " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}]}" <> "\n\ \ break;\n" ) <> " }\n\ @@ -293,7 +299,8 @@ \ } else {\n\ \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\ \ }\n\ - \ results = [];\n" + \ results = [];\n\ + \ callbacksToFree = [];\n" Nothing -> " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\ \ break;\n" @@ -305,7 +312,14 @@ \ catch (err) {\n\ \ var n = ++jsaddle_index;\n\ \ jsaddle_values.set(n, err);\n\ - \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\ + \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n]}]}" <> "\n\ + \ }\n\ + \ if(inCallback == 1) {\n\ + \ while(asyncBatch !== null) {\n\ + \ var b = asyncBatch;\n\ + \ asyncBatch = null;\n\ + \ if(b[2] == expectedBatch) runBatch(b);\n\ + \ }\n\ \ }\n\ \ inCallback--;\n\ \ };\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 @@ -107,9 +107,9 @@ import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..)) import Control.Concurrent.STM.TVar (TVar) import Control.Concurrent.MVar (MVar) +import Data.Int (Int64) import Data.Set (Set) import Data.Text (Text) -import Data.UUID (UUID) import Data.Time.Clock (UTCTime(..)) import Data.Typeable (Typeable) import Data.Coerce (coerce, Coercible) @@ -132,15 +132,15 @@ type JSContextRef = () #else data JSContextRef = JSContextRef { - contextId :: UUID - , startTime :: UTCTime - , doSendCommand :: Command -> IO Result - , doSendAsyncCommand :: AsyncCommand -> IO () - , addCallback :: Object -> JSCallAsFunction -> IO () - , freeCallback :: Object -> IO () - , nextRef :: TVar JSValueRef - , doEnableLogging :: Bool -> IO () - , finalizerThreads :: MVar (Set Text) + contextId :: Int64 + , startTime :: UTCTime + , doSendCommand :: Command -> IO Result + , doSendAsyncCommand :: AsyncCommand -> IO () + , addCallback :: Object -> JSCallAsFunction -> IO () + , nextRef :: TVar JSValueRef + , doEnableLogging :: Bool -> IO () + , finalizerThreads :: MVar (Set Text) + , animationFrameHandlers :: MVar [Double -> JSM ()] } #endif @@ -377,6 +377,7 @@ | NewEmptyObject JSValueForSend | NewAsyncCallback JSValueForSend | NewSyncCallback JSValueForSend + | FreeCallback JSValueForSend | NewArray [JSValueForSend] JSValueForSend | EvaluateScript JSStringForSend JSValueForSend | SyncWithAnimationFrame JSValueForSend @@ -445,8 +446,8 @@ instance FromJSON Result -data BatchResults = Success [Result] - | Failure [Result] JSValueReceived +data BatchResults = Success [JSValueReceived] [Result] + | Failure [JSValueReceived] [Result] JSValueReceived deriving (Show, Generic) instance ToJSON BatchResults where