@@ -1,6 +1,9 @@
1+{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnboxedTuples #-}
4-----------------------------------------------------------------------------
7-----------------------------------------------------------------------------
6-- Module : Language.Javascript.JSaddle.Run
9-- Module : Language.Javascript.JSaddle.Run
@@ -19,6 +22,7 @@ module Language.Javascript.JSaddle.Run (
19 , syncAfter
22 , syncAfter
20 , waitForAnimationFrame
23 , waitForAnimationFrame
21 , nextAnimationFrame
24 , nextAnimationFrame
22#ifndef ghcjs_HOST_OS
26#ifndef ghcjs_HOST_OS
23 -- * Functions used to implement JSaddle using JSON messaging
27 -- * Functions used to implement JSaddle using JSON messaging
24 , runJavaScript
28 , runJavaScript
@@ -33,59 +37,67 @@ module Language.Javascript.JSaddle.Run (
35#ifdef ghcjs_HOST_OS
39#ifdef ghcjs_HOST_OS
36−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
37import qualified JavaScript.Web.AnimationFrame as GHCJS
41import qualified JavaScript.Web.AnimationFrame as GHCJS
38 (waitForAnimationFrame)
42 (waitForAnimationFrame)
40−import Control.Exception (throwIO)
44+import Control.Exception (throwIO, evaluate)
41−import Control.Monad (void, when, forever, zipWithM_)
45+import Control.Monad (void, when, zipWithM_)
42import Control.Monad.IO.Class (MonadIO(..))
46import Control.Monad.IO.Class (MonadIO(..))
43import Control.Monad.Trans.Reader (ask, runReaderT)
47import Control.Monad.Trans.Reader (ask, runReaderT)
44import Control.Monad.STM (atomically)
48import Control.Monad.STM (atomically)
45−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
46import Control.Concurrent.STM.TChan
50import Control.Concurrent.STM.TChan
47 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
48import Control.Concurrent.STM.TVar
52import Control.Concurrent.STM.TVar
49− (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)
53+ (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
50import Control.Concurrent.MVar
54import Control.Concurrent.MVar
51− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
53import System.IO.Unsafe (unsafeInterleaveIO)
57import System.IO.Unsafe (unsafeInterleaveIO)
54import System.Mem.Weak (addFinalizer)
58import System.Mem.Weak (addFinalizer)
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
56import Data.Monoid ((<>))
63import Data.Monoid ((<>))
57−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
58import qualified Data.Map as M (lookup, delete, insert, empty, size)
65import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import qualified Data.Set as S (empty, member, insert, delete)
59import Data.Time.Clock (getCurrentTime,diffUTCTime)
67import Data.Time.Clock (getCurrentTime,diffUTCTime)
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
61import Language.Javascript.JSaddle.Types
71import Language.Javascript.JSaddle.Types
62− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
72+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
63− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
64import Language.Javascript.JSaddle.Exception (JSException(..))
74import Language.Javascript.JSaddle.Exception (JSException(..))
65−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
66−import Control.DeepSeq (deepseq)
75+import Control.DeepSeq (force, deepseq)
76+#if MIN_VERSION_base(4,11,0)
77+import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)
67import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
79import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
81+import Data.Foldable (forM_)
70−-- | Forces execution of pending asyncronous code
72−#ifdef ghcjs_HOST_OS
84+#ifndef ghcjs_HOST_OS
73−syncPoint = return ()
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
75−syncPoint = do
88+getRTSStatsEnabled = getGCStatsEnabled
76− SyncResult <- sendCommand Sync
89+getRTSStats = getGCStats
80−-- | Forces execution of pending asyncronous code after performing `f`
93+-- | Enable (or disable) JSaddle logging
81−syncAfter :: JSM a -> JSM a
94+enableLogging :: Bool -> JSM ()
82#ifdef ghcjs_HOST_OS
95#ifdef ghcjs_HOST_OS
83−syncAfter = id
96+enableLogging _ = return ()
85−syncAfter f = do
98+enableLogging v = do
86− result <- f
99+ f <- doEnableLogging <$> JSM ask
87− syncPoint
100+ liftIO $ f v
91-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -113,17 +125,12 @@ nextAnimationFrame f = do
113 syncAfter (f t)
125 syncAfter (f t)
115#ifndef ghcjs_HOST_OS
127#ifndef ghcjs_HOST_OS
116−sendCommand :: Command -> JSM Result
118− s <- doSendCommand <$> JSM ask
121sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
122sendLazyCommand cmd = do
129sendLazyCommand cmd = do
123 nextRefTVar <- nextRef <$> JSM ask
130 nextRefTVar <- nextRef <$> JSM ask
124 n <- liftIO . atomically $ do
131 n <- liftIO . atomically $ do
125 n <- subtract 1 <$> readTVar nextRefTVar
132 n <- subtract 1 <$> readTVar nextRefTVar
126− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
128 s <- doSendAsyncCommand <$> JSM ask
135 s <- doSendAsyncCommand <$> JSM ask
129 liftIO $ s (cmd $ JSValueForSend n)
136 liftIO $ s (cmd $ JSValueForSend n)
@@ -134,61 +141,112 @@ sendAsyncCommand cmd = do
134 s <- doSendAsyncCommand <$> JSM ask
141 s <- doSendAsyncCommand <$> JSM ask
135 liftIO $ s cmd
142 liftIO $ s cmd
137−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
138runJavaScript sendBatch entryPoint = do
145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
139 startTime' <- getCurrentTime
147 startTime' <- getCurrentTime
140 recvMVar <- newEmptyMVar
148 recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
141 commandChan <- newTChanIO
150 commandChan <- newTChanIO
142 callbacks <- newTVarIO M.empty
151 callbacks <- newTVarIO M.empty
143 nextRef' <- newTVarIO 0
152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
155+ loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
144 let ctx = JSContextRef {
157 let ctx = JSContextRef {
158+ contextId = contextId'
145− startTime = startTime'
159+ , startTime = startTime'
146− , doSendCommand = \cmd -> cmd `deepseq` do
160+ , doSendCommand = \cmd -> cmd `deepseq` do
147− result <- newEmptyMVar
161+ result <- newEmptyMVar
148− atomically $ writeTChan commandChan (Right (cmd, result))
162+ atomically $ writeTChan commandChan (Right (cmd, result))
149− unsafeInterleaveIO $
163+ unsafeInterleaveIO $
150− takeMVar result >>= \case
164+ takeMVar result >>= \case
165+ (ThrowJSValue v) -> do
166+ jsval <- wrapJSVal' ctx v
151− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
167+ throwIO $ JSException jsval
152− r -> return r
168+ r -> return r
153− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
169+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
170+ , addCallback = \(Object (JSVal ioref)) cb -> do
171+ val <- readIORef ioref
154− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
172+ atomically $ modifyTVar' callbacks (M.insert val cb)
155− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
173+ , nextRef = nextRef'
156− , nextRef = nextRef'
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ , finalizerThreads = finalizerThreads'
176+ , animationFrameHandlers = animationFrameHandlers'
177+ , liveRefs = liveRefs'
179+ processResults :: Bool -> Results -> IO ()
158− let processResults = \case
180+ processResults syncCallbacks = \case
159 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
160− (Callback f this a) -> do
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
161− logInfo ("Call " <>)
183+ putMVar recvMVar (n, br)
162− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
163 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
164 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
165 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
166 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
190+ Just cb -> void . forkIO $ do
167− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
191+ runReaderT (unJSM $ cb f' this' args) ctx
192+ when syncCallbacks $
193+ doSendAsyncCommand ctx EndSyncBlock
194+ Duplicate nBatch nExpected -> do
195+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>
196+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected
197+ void $ doSendCommand ctx Sync
168− m -> putMVar recvMVar m
198+ BatchResults n br -> putMVar recvMVar (n, br)
199+ asyncResults :: Results -> IO ()
200+ asyncResults results =
201+ void . forkIO $ processResults False results
202+ syncResults :: Results -> IO Batch
203+ syncResults results = do
204+ void . forkIO $ processResults True results
205+ readMVar lastAsyncBatch
169− logInfo s = do
206+ logInfo s =
170− stats <- getGCStatsEnabled
207+ readIORef loggingEnabled >>= \case
171− when stats $ do
208+ True -> do
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
172− current <- currentBytesUsed <$> getGCStats
210+ True -> show . currentBytesUsed <$> getRTSStats
211+ False -> return "??"
173− cbCount <- M.size <$> readTVarIO callbacks
212+ cbCount <- M.size <$> readTVarIO callbacks
174− putStrLn . s $ show (current, cbCount)
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
175− _ <- forkIO . forever $ readBatch commandChan >>= \case
216+ readBatch nBatch commandChan >>= \case
176− (batch@(Batch cmds _), resultMVars) -> do
217+ (batch@(Batch cmds _ _), resultMVars) -> do
177 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219+ _ <- tryTakeMVar lastAsyncBatch
220+ putMVar lastAsyncBatch batch
178 sendBatch batch
221 sendBatch batch
179− takeMVar recvMVar >>= \case
222+ takeResult recvMVar nBatch >>= \case
223+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
224+ (_, Success callbacksToFree results)
180− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
181− | otherwise -> zipWithM_ putMVar resultMVars results
227+ zipWithM_ putMVar resultMVars results
228+ forM_ callbacksToFree $ \(JSValueReceived val) ->
229+ atomically (modifyTVar' callbacks (M.delete val))
182− Failure results exception -> do
230+ (_, Failure callbacksToFree results exception err) -> do
183 -- The exception will only be rethrown in Haskell if/when one of the
231 -- The exception will only be rethrown in Haskell if/when one of the
184 -- missing results (if any) is evaluated.
232 -- missing results (if any) is evaluated.
185 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
233 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
186 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
235 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
187− _ -> error "Unexpected jsaddle results"
236+ forM_ callbacksToFree $ \(JSValueReceived val) ->
237+ atomically (modifyTVar' callbacks (M.delete val))
188− return (processResults, runReaderT (unJSM entryPoint) ctx)
238+ return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
240+ numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
241+ numberForeverFromM_ !n f = do
243+ numberForeverFromM_ (succ n) f
244+ takeResult recvMVar nBatch =
245+ takeMVar recvMVar >>= \case
246+ (n, _) | n < nBatch -> takeResult recvMVar nBatch
190− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
248+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
191− readBatch chan = do
249+ readBatch nBatch chan = do
192 first <- atomically $ readTChan chan -- We want at least one command to send
250 first <- atomically $ readTChan chan -- We want at least one command to send
193 loop first ([], [])
251 loop first ([], [])
@@ -199,28 +257,55 @@ runJavaScript sendBatch entryPoint = do
199 let cmds = Right syncCmd:cmds'
257 let cmds = Right syncCmd:cmds'
200 resultMVars = resultMVar:resultMVars'
258 resultMVars = resultMVar:resultMVars'
201 atomically (tryReadTChan chan) >>= \case
259 atomically (tryReadTChan chan) >>= \case
202− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
260+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
203 Just cmd -> loop cmd (cmds, resultMVars)
261 Just cmd -> loop cmd (cmds, resultMVars)
204 loop (Left asyncCmd) (cmds', resultMVars) = do
262 loop (Left asyncCmd) (cmds', resultMVars) = do
205 let cmds = Left asyncCmd:cmds'
263 let cmds = Left asyncCmd:cmds'
206 atomically (tryReadTChan chan) >>= \case
264 atomically (tryReadTChan chan) >>= \case
207− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
265+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
208 Just cmd -> loop cmd (cmds, resultMVars)
266 Just cmd -> loop cmd (cmds, resultMVars)
209 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
210 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
211 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
212− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
270+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
213 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
214 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
215 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
216 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
276+addThreadFinalizer :: ThreadId -> IO () -> IO ()
277+addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
278+ IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
218wrapJSVal :: JSValueReceived -> JSM JSVal
281wrapJSVal :: JSValueReceived -> JSM JSVal
284+ liftIO $ wrapJSVal' ctx v
286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
219−wrapJSVal (JSValueReceived ref) = do
287+wrapJSVal' ctx (JSValueReceived n) = do
220− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
288+ ref <- liftIO $ newIORef n
221− let result = JSVal ref
289+ when (n >= 5 || n < 0) $
222− when (ref >= 5) $ do
290+#ifdef JSADDLE_CHECK_WRAPJSVAL
223− ctx <- JSM ask
291+ do lr <- takeMVar $ liveRefs ctx
294+ putStrLn $ "JS Value Ref " <> show n <> " already wrapped"
295+ putMVar (liveRefs ctx) lr
296+ else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)
298+ void . mkWeakIORef ref $ do
299+ ft <- takeMVar $ finalizerThreads ctx
301+ let tname = T.pack $ show t
224− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
302+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n
303+ if tname `S.member` ft
304+ then putMVar (finalizerThreads ctx) ft
306+ addThreadFinalizer t $ do
307+ modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())
308+ doSendAsyncCommand ctx $ FreeRefs tname
309+ putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)
225− return result
310+ return (JSVal ref)