@@ -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
@@ -34,43 +37,59 @@ module Language.Javascript.JSaddle.Run (
36#ifdef ghcjs_HOST_OS
39#ifdef ghcjs_HOST_OS
37−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
38import qualified JavaScript.Web.AnimationFrame as GHCJS
41import qualified JavaScript.Web.AnimationFrame as GHCJS
39 (waitForAnimationFrame)
42 (waitForAnimationFrame)
41−import Control.Exception (throwIO)
44+import Control.Exception (throwIO, evaluate)
42−import Control.Monad (void, when, forever, zipWithM_)
45+import Control.Monad (void, when, zipWithM_)
43import Control.Monad.IO.Class (MonadIO(..))
46import Control.Monad.IO.Class (MonadIO(..))
44import Control.Monad.Trans.Reader (ask, runReaderT)
47import Control.Monad.Trans.Reader (ask, runReaderT)
45import Control.Monad.STM (atomically)
48import Control.Monad.STM (atomically)
46−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
47import Control.Concurrent.STM.TChan
50import Control.Concurrent.STM.TChan
48 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
49import Control.Concurrent.STM.TVar
52import Control.Concurrent.STM.TVar
50 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
53 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
51import Control.Concurrent.MVar
54import Control.Concurrent.MVar
52− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
54import System.IO.Unsafe (unsafeInterleaveIO)
57import System.IO.Unsafe (unsafeInterleaveIO)
55import System.Mem.Weak (addFinalizer)
58import System.Mem.Weak (addFinalizer)
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
57import Data.Monoid ((<>))
63import Data.Monoid ((<>))
58−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
59import 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)
60import Data.Time.Clock (getCurrentTime,diffUTCTime)
67import Data.Time.Clock (getCurrentTime,diffUTCTime)
61−import Data.IORef (newIORef, atomicWriteIORef, readIORef)
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
63import Language.Javascript.JSaddle.Types
71import Language.Javascript.JSaddle.Types
64 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
72 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
65− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
66import Language.Javascript.JSaddle.Exception (JSException(..))
74import Language.Javascript.JSaddle.Exception (JSException(..))
67−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
68−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)
69import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
79import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
70−import Data.Maybe (isJust)
80+#endif
71import Data.Foldable (forM_)
81import Data.Foldable (forM_)
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
88+getRTSStatsEnabled = getGCStatsEnabled
89+getRTSStats = getGCStats
74-- | Enable (or disable) JSaddle logging
93-- | Enable (or disable) JSaddle logging
75enableLogging :: Bool -> JSM ()
94enableLogging :: Bool -> JSM ()
76#ifdef ghcjs_HOST_OS
95#ifdef ghcjs_HOST_OS
@@ -81,27 +100,6 @@ enableLogging v = do
81 liftIO $ f v
100 liftIO $ f v
84−-- | Forces execution of pending asyncronous code
90− SyncResult <- sendCommand Sync
94−-- | Forces execution of pending asyncronous code after performing `f`
95−syncAfter :: JSM a -> JSM a
105-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
106-- On GHC it will delay the execution of the current batch of asynchronous
104-- On GHC it will delay the execution of the current batch of asynchronous
107-- command when they are sent to JavaScript. It will not delay the Haskell
105-- command when they are sent to JavaScript. It will not delay the Haskell
@@ -127,17 +125,12 @@ nextAnimationFrame f = do
127 syncAfter (f t)
125 syncAfter (f t)
129#ifndef ghcjs_HOST_OS
127#ifndef ghcjs_HOST_OS
130−sendCommand :: Command -> JSM Result
132− s <- doSendCommand <$> JSM ask
135sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
136sendLazyCommand cmd = do
129sendLazyCommand cmd = do
137 nextRefTVar <- nextRef <$> JSM ask
130 nextRefTVar <- nextRef <$> JSM ask
138 n <- liftIO . atomically $ do
131 n <- liftIO . atomically $ do
139 n <- subtract 1 <$> readTVar nextRefTVar
132 n <- subtract 1 <$> readTVar nextRefTVar
140− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
142 s <- doSendAsyncCommand <$> JSM ask
135 s <- doSendAsyncCommand <$> JSM ask
143 liftIO $ s (cmd $ JSValueForSend n)
136 liftIO $ s (cmd $ JSValueForSend n)
@@ -150,34 +143,45 @@ sendAsyncCommand cmd = do
151runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
144runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
152runJavaScript sendBatch entryPoint = do
145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
153 startTime' <- getCurrentTime
147 startTime' <- getCurrentTime
154 recvMVar <- newEmptyMVar
148 recvMVar <- newEmptyMVar
155 lastAsyncBatch <- newEmptyMVar
149 lastAsyncBatch <- newEmptyMVar
156 commandChan <- newTChanIO
150 commandChan <- newTChanIO
157 callbacks <- newTVarIO M.empty
151 callbacks <- newTVarIO M.empty
158 nextRef' <- newTVarIO 0
152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
159 loggingEnabled <- newIORef False
155 loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
160 let ctx = JSContextRef {
157 let ctx = JSContextRef {
158+ contextId = contextId'
161− startTime = startTime'
159+ , startTime = startTime'
162− , doSendCommand = \cmd -> cmd `deepseq` do
160+ , doSendCommand = \cmd -> cmd `deepseq` do
163− result <- newEmptyMVar
161+ result <- newEmptyMVar
164− atomically $ writeTChan commandChan (Right (cmd, result))
162+ atomically $ writeTChan commandChan (Right (cmd, result))
165− unsafeInterleaveIO $
163+ unsafeInterleaveIO $
166− takeMVar result >>= \case
164+ takeMVar result >>= \case
165+ (ThrowJSValue v) -> do
166+ jsval <- wrapJSVal' ctx v
167− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
167+ throwIO $ JSException jsval
168− r -> return r
168+ r -> return r
169− , 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
170− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
172+ atomically $ modifyTVar' callbacks (M.insert val cb)
171− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
172− , nextRef = nextRef'
173+ , nextRef = nextRef'
173− , doEnableLogging = atomicWriteIORef loggingEnabled
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ , finalizerThreads = finalizerThreads'
176+ , animationFrameHandlers = animationFrameHandlers'
177+ , liveRefs = liveRefs'
175− let processResults :: Bool -> Results -> IO ()
179+ processResults :: Bool -> Results -> IO ()
176 processResults syncCallbacks = \case
180 processResults syncCallbacks = \case
177 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
178− (Callback n br f this a) -> do
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
179 putMVar recvMVar (n, br)
183 putMVar recvMVar (n, br)
180− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
183 logInfo (("Call " <> show fNumber <> " ") <>)
187 logInfo (("Call " <> show fNumber <> " ") <>)
@@ -202,13 +206,13 @@ runJavaScript sendBatch entryPoint = do
202 logInfo s =
206 logInfo s =
203 readIORef loggingEnabled >>= \case
207 readIORef loggingEnabled >>= \case
204 True -> do
208 True -> do
205− currentBytesUsedStr <- getGCStatsEnabled >>= \case
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
206− True -> show . currentBytesUsed <$> getGCStats
210+ True -> show . currentBytesUsed <$> getRTSStats
207 False -> return "??"
211 False -> return "??"
208 cbCount <- M.size <$> readTVarIO callbacks
212 cbCount <- M.size <$> readTVarIO callbacks
209− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
210 False -> return ()
214 False -> return ()
211− _ <- forkIO . forM_ [1..] $ \nBatch ->
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
212 readBatch nBatch commandChan >>= \case
216 readBatch nBatch commandChan >>= \case
213 (batch@(Batch cmds _ _), resultMVars) -> do
217 (batch@(Batch cmds _ _), resultMVars) -> do
214 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
@@ -216,16 +220,27 @@ runJavaScript sendBatch entryPoint = do
216 putMVar lastAsyncBatch batch
220 putMVar lastAsyncBatch batch
217 sendBatch batch
221 sendBatch batch
218 takeResult recvMVar nBatch >>= \case
222 takeResult recvMVar nBatch >>= \case
219− (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
223+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
224+ (_, Success callbacksToFree results)
220− (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
221− | otherwise -> zipWithM_ putMVar resultMVars results
227+ zipWithM_ putMVar resultMVars results
228+ forM_ callbacksToFree $ \(JSValueReceived val) ->
229+ atomically (modifyTVar' callbacks (M.delete val))
222− (_, Failure results exception) -> do
230+ (_, Failure callbacksToFree results exception err) -> do
223− -- 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
224− -- missing results (if any) is evaluated.
232+ -- missing results (if any) is evaluated.
225− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
233+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
226− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
235+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236+ forM_ callbacksToFree $ \(JSValueReceived val) ->
237+ atomically (modifyTVar' callbacks (M.delete val))
227 return (asyncResults, syncResults, 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
229 takeResult recvMVar nBatch =
244 takeResult recvMVar nBatch =
230 takeMVar recvMVar >>= \case
245 takeMVar recvMVar >>= \case
231 (n, _) | n < nBatch -> takeResult recvMVar nBatch
246 (n, _) | n < nBatch -> takeResult recvMVar nBatch
@@ -258,12 +273,39 @@ runJavaScript sendBatch entryPoint = do
258 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
259 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, () #) }
261wrapJSVal :: JSValueReceived -> JSM JSVal
281wrapJSVal :: JSValueReceived -> JSM JSVal
284+ liftIO $ wrapJSVal' ctx v
286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
262−wrapJSVal (JSValueReceived ref) = do
287+wrapJSVal' ctx (JSValueReceived n) = do
263− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
288+ ref <- liftIO $ newIORef n
264− let result = JSVal ref
289+ when (n >= 5 || n < 0) $
265− when (ref >= 5) $ do
290+#ifdef JSADDLE_CHECK_WRAPJSVAL
266− 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
267− 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)
268− return result
310+ return (JSVal ref)