@@ -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)
68+import Data.IORef
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)
75+import Control.DeepSeq (force, deepseq)
68−import Control.DeepSeq (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 {
161− startTime = startTime'
158+ contextId = contextId'
162− , doSendCommand = \cmd -> cmd `deepseq` do
159+ , startTime = startTime'
163− result <- newEmptyMVar
160+ , doSendCommand = \cmd -> cmd `deepseq` do
164− atomically $ writeTChan commandChan (Right (cmd, result))
161+ result <- newEmptyMVar
165− unsafeInterleaveIO $
162+ atomically $ writeTChan commandChan (Right (cmd, result))
166− takeMVar result >>= \case
163+ unsafeInterleaveIO $
167− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
164+ takeMVar result >>= \case
168− r -> return r
165+ (ThrowJSValue v) -> do
169− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
166+ jsval <- wrapJSVal' ctx v
170− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
167+ throwIO $ JSException jsval
171− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
168+ r -> return r
172− , nextRef = nextRef'
169+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
173− , doEnableLogging = atomicWriteIORef loggingEnabled
170+ , addCallback = \(Object (JSVal ioref)) cb -> do
174− }
171+ val <- readIORef ioref
175− let processResults :: Bool -> Results -> IO ()
172+ atomically $ modifyTVar' callbacks (M.insert val cb)
173+ , nextRef = nextRef'
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ , finalizerThreads = finalizerThreads'
176+ , animationFrameHandlers = animationFrameHandlers'
177+ , liveRefs = liveRefs'
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 <> ")"
220− (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
224+ (_, Success callbacksToFree results)
221− | otherwise -> zipWithM_ putMVar resultMVars results
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
222− (_, Failure results exception) -> do
226+ | otherwise -> do
223− -- The exception will only be rethrown in Haskell if/when one of the
227+ zipWithM_ putMVar resultMVars results
224− -- missing results (if any) is evaluated.
228+ forM_ callbacksToFree $ \(JSValueReceived val) ->
225− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
229+ atomically (modifyTVar' callbacks (M.delete val))
226− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
230+ (_, Failure callbacksToFree results exception err) -> do
231+ -- The exception will only be rethrown in Haskell if/when one of the
232+ -- missing results (if any) is evaluated.
233+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
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
262−wrapJSVal (JSValueReceived ref) = do
282+wrapJSVal v = do
263− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
283+ ctx <- JSM ask
264− let result = JSVal ref
284+ liftIO $ wrapJSVal' ctx v
265− when (ref >= 5) $ do
285+
266− ctx <- JSM ask
286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
267− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
287+wrapJSVal' ctx (JSValueReceived n) = do
268− return result
288+ ref <- liftIO $ newIORef n
289+ when (n >= 5 || n < 0) $
290+#ifdef JSADDLE_CHECK_WRAPJSVAL
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
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)