@@ -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,58 +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)
58−import qualified Data.Map as M (lookup, delete, insert, empty)
65+import 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)
79+import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
81+import Data.Foldable (forM_)
69−-- | Forces execution of pending asyncronous code
71−#ifdef ghcjs_HOST_OS
84+#ifndef ghcjs_HOST_OS
72−syncPoint = return ()
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
74−syncPoint = do
88+getRTSStatsEnabled = getGCStatsEnabled
75− SyncResult <- sendCommand Sync
89+getRTSStats = getGCStats
79−-- | Forces execution of pending asyncronous code after performing `f`
93+-- | Enable (or disable) JSaddle logging
80−syncAfter :: JSM a -> JSM a
94+enableLogging :: Bool -> JSM ()
81#ifdef ghcjs_HOST_OS
95#ifdef ghcjs_HOST_OS
82−syncAfter = id
96+enableLogging _ = return ()
84−syncAfter f = do
98+enableLogging v = do
85− result <- f
99+ f <- doEnableLogging <$> JSM ask
86− syncPoint
100+ liftIO $ f v
90-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -112,17 +125,12 @@ nextAnimationFrame f = do
112 syncAfter (f t)
125 syncAfter (f t)
114#ifndef ghcjs_HOST_OS
127#ifndef ghcjs_HOST_OS
115−sendCommand :: Command -> JSM Result
117− s <- doSendCommand <$> JSM ask
120sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
121sendLazyCommand cmd = do
129sendLazyCommand cmd = do
122 nextRefTVar <- nextRef <$> JSM ask
130 nextRefTVar <- nextRef <$> JSM ask
123 n <- liftIO . atomically $ do
131 n <- liftIO . atomically $ do
124 n <- subtract 1 <$> readTVar nextRefTVar
132 n <- subtract 1 <$> readTVar nextRefTVar
125− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
127 s <- doSendAsyncCommand <$> JSM ask
135 s <- doSendAsyncCommand <$> JSM ask
128 liftIO $ s (cmd $ JSValueForSend n)
136 liftIO $ s (cmd $ JSValueForSend n)
@@ -133,52 +141,112 @@ sendAsyncCommand cmd = do
133 s <- doSendAsyncCommand <$> JSM ask
141 s <- doSendAsyncCommand <$> JSM ask
134 liftIO $ s cmd
142 liftIO $ s cmd
136−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
137runJavaScript sendBatch entryPoint = do
145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
138 startTime' <- getCurrentTime
147 startTime' <- getCurrentTime
139− recvChan <- newTChanIO
148+ recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
140 commandChan <- newTChanIO
150 commandChan <- newTChanIO
141 callbacks <- newTVarIO M.empty
151 callbacks <- newTVarIO M.empty
142 nextRef' <- newTVarIO 0
152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
155+ loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
143 let ctx = JSContextRef {
157 let ctx = JSContextRef {
158+ contextId = contextId'
144− startTime = startTime'
159+ , startTime = startTime'
145− , doSendCommand = \cmd -> cmd `deepseq` do
160+ , doSendCommand = \cmd -> cmd `deepseq` do
146− result <- newEmptyMVar
161+ result <- newEmptyMVar
147− atomically $ writeTChan commandChan (Right (cmd, result))
162+ atomically $ writeTChan commandChan (Right (cmd, result))
148− unsafeInterleaveIO $
163+ unsafeInterleaveIO $
149− takeMVar result >>= \case
164+ takeMVar result >>= \case
165+ (ThrowJSValue v) -> do
166+ jsval <- wrapJSVal' ctx v
150− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
167+ throwIO $ JSException jsval
151− r -> return r
168+ r -> return r
152− , 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
153− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
172+ atomically $ modifyTVar' callbacks (M.insert val cb)
154− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
173+ , nextRef = nextRef'
155− , nextRef = nextRef'
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ , finalizerThreads = finalizerThreads'
176+ , animationFrameHandlers = animationFrameHandlers'
177+ , liveRefs = liveRefs'
179+ processResults :: Bool -> Results -> IO ()
157− let processResults = \case
180+ processResults syncCallbacks = \case
158 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
159− (Callback f this a) -> do
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
183+ putMVar recvMVar (n, br)
160− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
161 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
162 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
163 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
164 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
165− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
191+ runReaderT (unJSM $ cb f' this' args) ctx
166− m -> atomically $ writeTChan recvChan m
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
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
207+ readIORef loggingEnabled >>= \case
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210+ True -> show . currentBytesUsed <$> getRTSStats
211+ False -> return "??"
212+ cbCount <- M.size <$> readTVarIO callbacks
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
167− _ <- forkIO . forever $ readBatch commandChan >>= \case
216+ readBatch nBatch commandChan >>= \case
168− (batch, resultMVars) -> do
217+ (batch@(Batch cmds _ _), resultMVars) -> do
218+ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219+ _ <- tryTakeMVar lastAsyncBatch
220+ putMVar lastAsyncBatch batch
169 sendBatch batch
221 sendBatch batch
170− atomically (readTChan recvChan) >>= \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)
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
171− Success results -> zipWithM_ putMVar resultMVars results
227+ zipWithM_ putMVar resultMVars results
228+ forM_ callbacksToFree $ \(JSValueReceived val) ->
229+ atomically (modifyTVar' callbacks (M.delete val))
172− Failure results exception -> do
230+ (_, Failure callbacksToFree results exception err) -> do
173 -- 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
174 -- missing results (if any) is evaluated.
232 -- missing results (if any) is evaluated.
175 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
233 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
176 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
235 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
177− _ -> error "Unexpected jsaddle results"
236+ forM_ callbacksToFree $ \(JSValueReceived val) ->
237+ atomically (modifyTVar' callbacks (M.delete val))
178− 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
180− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
248+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
181− readBatch chan = do
249+ readBatch nBatch chan = do
182 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
183 loop first ([], [])
251 loop first ([], [])
@@ -189,28 +257,55 @@ runJavaScript sendBatch entryPoint = do
189 let cmds = Right syncCmd:cmds'
257 let cmds = Right syncCmd:cmds'
190 resultMVars = resultMVar:resultMVars'
258 resultMVars = resultMVar:resultMVars'
191 atomically (tryReadTChan chan) >>= \case
259 atomically (tryReadTChan chan) >>= \case
192− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
260+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
193 Just cmd -> loop cmd (cmds, resultMVars)
261 Just cmd -> loop cmd (cmds, resultMVars)
194 loop (Left asyncCmd) (cmds', resultMVars) = do
262 loop (Left asyncCmd) (cmds', resultMVars) = do
195 let cmds = Left asyncCmd:cmds'
263 let cmds = Left asyncCmd:cmds'
196 atomically (tryReadTChan chan) >>= \case
264 atomically (tryReadTChan chan) >>= \case
197− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
265+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
198 Just cmd -> loop cmd (cmds, resultMVars)
266 Just cmd -> loop cmd (cmds, resultMVars)
199 -- 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
200 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])
201 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
202− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
270+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
203 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
204 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
205 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
206 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, () #) }
208wrapJSVal :: JSValueReceived -> JSM JSVal
281wrapJSVal :: JSValueReceived -> JSM JSVal
284+ liftIO $ wrapJSVal' ctx v
286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
209−wrapJSVal (JSValueReceived ref) = do
287+wrapJSVal' ctx (JSValueReceived n) = do
210− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
288+ ref <- liftIO $ newIORef n
211− let result = JSVal ref
289+ when (n >= 5 || n < 0) $
212− when (ref >= 5) $ do
290+#ifdef JSADDLE_CHECK_WRAPJSVAL
213− 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
214− 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)
215− return result
310+ return (JSVal ref)