@@ -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)
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(..), 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− syncSendBatch <- 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 f this a) -> do
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
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 <> " ") <>)
@@ -185,58 +189,62 @@ runJavaScript sendBatch entryPoint = do
185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
186 Just cb -> void . forkIO $ do
190 Just cb -> void . forkIO $ do
187 runReaderT (unJSM $ cb f' this' args) ctx
191 runReaderT (unJSM $ cb f' this' args) ctx
188− when syncCallbacks $ do
192+ when syncCallbacks $
189 doSendAsyncCommand ctx EndSyncBlock
193 doSendAsyncCommand ctx EndSyncBlock
194+ Duplicate nBatch nExpected -> do
195+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>
196+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected
190− void $ doSendCommand ctx Sync
197+ void $ doSendCommand ctx Sync
191− Duplicate -> error "Error : Unexpected Duplicate"
192− m -> putMVar recvMVar m
198+ BatchResults n br -> putMVar recvMVar (n, br)
193 asyncResults :: Results -> IO ()
199 asyncResults :: Results -> IO ()
200+ asyncResults results =
194− asyncResults = processResults False
201+ void . forkIO $ processResults False results
195 syncResults :: Results -> IO Batch
202 syncResults :: Results -> IO Batch
196 syncResults results = do
203 syncResults results = do
197− existing <- tryTakeMVar syncSendBatch
204+ void . forkIO $ processResults True results
198− when (isJust existing) $ error "Error : Unexpected Sync Results"
199− tryTakeMVar lastAsyncBatch >>= \case
205+ readMVar lastAsyncBatch
200− Just lastAsync -> processResults True results >> return lastAsync
202− nextBatch <- newEmptyMVar
203− putMVar syncSendBatch (\batch -> do
204− existing <- tryTakeMVar nextBatch
205− when (isJust existing) $ error "Error : Unexpected Sync Results"
206− putMVar nextBatch batch)
207− processResults True results
209 logInfo s =
206 logInfo s =
210 readIORef loggingEnabled >>= \case
207 readIORef loggingEnabled >>= \case
211 True -> do
208 True -> do
212− currentBytesUsedStr <- getGCStatsEnabled >>= \case
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
213− True -> show . currentBytesUsed <$> getGCStats
210+ True -> show . currentBytesUsed <$> getRTSStats
214 False -> return "??"
211 False -> return "??"
215 cbCount <- M.size <$> readTVarIO callbacks
212 cbCount <- M.size <$> readTVarIO callbacks
216− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
217 False -> return ()
214 False -> return ()
218− _ <- forkIO . forM_ [1..] $ \nBatch ->
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
219 readBatch nBatch commandChan >>= \case
216 readBatch nBatch commandChan >>= \case
220 (batch@(Batch cmds _ _), resultMVars) -> do
217 (batch@(Batch cmds _ _), resultMVars) -> do
221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
222− tryTakeMVar syncSendBatch >>= \case
219+ _ <- tryTakeMVar lastAsyncBatch
223− Just send -> send batch
225− putMVar lastAsyncBatch batch
220+ putMVar lastAsyncBatch batch
226− sendBatch batch
221+ sendBatch batch
227− takeMVar recvMVar >>= \r -> do
222+ takeResult recvMVar nBatch >>= \case
228− _ <- tryTakeMVar lastAsyncBatch
223+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
229− case r of
224+ (_, Success callbacksToFree results)
230− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
231− | otherwise -> zipWithM_ putMVar resultMVars results
227+ zipWithM_ putMVar resultMVars results
228+ forM_ callbacksToFree $ \(JSValueReceived val) ->
229+ atomically (modifyTVar' callbacks (M.delete val))
232− Failure results exception -> do
230+ (_, Failure callbacksToFree results exception err) -> do
233− -- 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
234− -- missing results (if any) is evaluated.
232+ -- missing results (if any) is evaluated.
235− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
233+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
236− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
235+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
237− _ -> error "Unexpected jsaddle results"
236+ forM_ callbacksToFree $ \(JSValueReceived val) ->
237+ atomically (modifyTVar' callbacks (M.delete val))
238 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
244+ takeResult recvMVar nBatch =
245+ takeMVar recvMVar >>= \case
246+ (n, _) | n < nBatch -> takeResult recvMVar nBatch
240 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
248 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
241 readBatch nBatch chan = do
249 readBatch nBatch chan = do
242 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
@@ -265,12 +273,39 @@ runJavaScript sendBatch entryPoint = do
265 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
266 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, () #) }
268wrapJSVal :: JSValueReceived -> JSM JSVal
281wrapJSVal :: JSValueReceived -> JSM JSVal
284+ liftIO $ wrapJSVal' ctx v
286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
269−wrapJSVal (JSValueReceived ref) = do
287+wrapJSVal' ctx (JSValueReceived n) = do
270− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
288+ ref <- liftIO $ newIORef n
271− let result = JSVal ref
289+ when (n >= 5 || n < 0) $
272− when (ref >= 5) $ do
290+#ifdef JSADDLE_CHECK_WRAPJSVAL
273− 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
274− 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)
275− return result
310+ return (JSVal ref)