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