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