@@ -1,6 +1,9 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE CPP #-}
23{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnboxedTuples #-}
47-----------------------------------------------------------------------------
58--
69-- Module : Language.Javascript.JSaddle.Run
@@ -34,40 +37,58 @@ module Language.Javascript.JSaddle.Run (
3437) where
3538
3639#ifdef ghcjs_HOST_OS
37−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
3841import qualified JavaScript.Web.AnimationFrame as GHCJS
3942 (waitForAnimationFrame)
4043#else
41−import Control.Exception (throwIO)
42−import Control.Monad (void, when, forever, zipWithM_)
44+import Control.Exception (throwIO, evaluate)
45+import Control.Monad (void, when, zipWithM_)
4346import Control.Monad.IO.Class (MonadIO(..))
4447import Control.Monad.Trans.Reader (ask, runReaderT)
4548import Control.Monad.STM (atomically)
46−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
4750import Control.Concurrent.STM.TChan
4851 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
4952import Control.Concurrent.STM.TVar
5053 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5154import Control.Concurrent.MVar
52− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
5356
5457import System.IO.Unsafe (unsafeInterleaveIO)
5558import System.Mem.Weak (addFinalizer)
59+import System.Random
5660
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
5763import Data.Monoid ((<>))
58−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
5965import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import qualified Data.Set as S (empty, member, insert, delete)
6067import Data.Time.Clock (getCurrentTime,diffUTCTime)
61−import Data.IORef (newIORef, atomicWriteIORef, readIORef)
68+import Data.IORef
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
6270
6371import Language.Javascript.JSaddle.Types
64− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
65− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
72+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
6674import 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)
78+#else
6979import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
7080#endif
81+import Data.Foldable (forM_)
82+#endif
83+
84+#ifndef ghcjs_HOST_OS
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
87+#else
88+getRTSStatsEnabled = getGCStatsEnabled
89+getRTSStats = getGCStats
90+#endif
91+#endif
7192
7293-- | Enable (or disable) JSaddle logging
7394enableLogging :: Bool -> JSM ()
@@ -79,27 +100,6 @@ enableLogging v = do
79100 liftIO $ f v
80101#endif
81102
82−-- | Forces execution of pending asyncronous code
83−syncPoint :: JSM ()
84−#ifdef ghcjs_HOST_OS
85−syncPoint = return ()
86−#else
87−syncPoint = do
88− SyncResult <- sendCommand Sync
89− return ()
90−#endif
91−
92−-- | Forces execution of pending asyncronous code after performing `f`
93−syncAfter :: JSM a -> JSM a
94−#ifdef ghcjs_HOST_OS
95−syncAfter = id
96−#else
97−syncAfter f = do
98− result <- f
99− syncPoint
100− return result
101−#endif
102−
103103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
104104-- On GHC it will delay the execution of the current batch of asynchronous
105105-- command when they are sent to JavaScript. It will not delay the Haskell
@@ -125,17 +125,12 @@ nextAnimationFrame f = do
125125 syncAfter (f t)
126126
127127#ifndef ghcjs_HOST_OS
128−sendCommand :: Command -> JSM Result
129−sendCommand cmd = do
130− s <- doSendCommand <$> JSM ask
131− liftIO $ s cmd
132−
133128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
134129sendLazyCommand cmd = do
135130 nextRefTVar <- nextRef <$> JSM ask
136131 n <- liftIO . atomically $ do
137132 n <- subtract 1 <$> readTVar nextRefTVar
138− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
139134 return n
140135 s <- doSendAsyncCommand <$> JSM ask
141136 liftIO $ s (cmd $ JSValueForSend n)
@@ -146,66 +141,112 @@ sendAsyncCommand cmd = do
146141 s <- doSendAsyncCommand <$> JSM ask
147142 liftIO $ s cmd
148143
149−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
150145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
151147 startTime' <- getCurrentTime
152148 recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
153150 commandChan <- newTChanIO
154151 callbacks <- newTVarIO M.empty
155152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
156155 loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
157157 let ctx = JSContextRef {
158− startTime = startTime'
159− , doSendCommand = \cmd -> cmd `deepseq` do
160− result <- newEmptyMVar
161− atomically $ writeTChan commandChan (Right (cmd, result))
162− unsafeInterleaveIO $
163− takeMVar result >>= \case
164− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
165− r -> return r
166− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
167− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
168− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
169− , nextRef = nextRef'
170− , doEnableLogging = atomicWriteIORef loggingEnabled
171− }
172− let processResults = \case
158+ contextId = contextId'
159+ , startTime = startTime'
160+ , doSendCommand = \cmd -> cmd `deepseq` do
161+ result <- newEmptyMVar
162+ atomically $ writeTChan commandChan (Right (cmd, result))
163+ unsafeInterleaveIO $
164+ takeMVar result >>= \case
165+ (ThrowJSValue v) -> do
166+ jsval <- wrapJSVal' ctx v
167+ throwIO $ JSException jsval
168+ r -> return r
169+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
170+ , addCallback = \(Object (JSVal ioref)) cb -> do
171+ val <- readIORef ioref
172+ atomically $ modifyTVar' callbacks (M.insert val cb)
173+ , nextRef = nextRef'
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ , finalizerThreads = finalizerThreads'
176+ , animationFrameHandlers = animationFrameHandlers'
177+ , liveRefs = liveRefs'
178+ }
179+ processResults :: Bool -> Results -> IO ()
180+ processResults syncCallbacks = \case
173181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
174− (Callback f this a) -> do
175− logInfo ("Call " <>)
176− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
183+ putMVar recvMVar (n, br)
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
177185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
178186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
179188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
180189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
181− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
182− m -> putMVar recvMVar m
190+ Just cb -> void . forkIO $ do
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
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
183206 logInfo s =
184207 readIORef loggingEnabled >>= \case
185208 True -> do
186− currentBytesUsedStr <- getGCStatsEnabled >>= \case
187− True -> show . currentBytesUsed <$> getGCStats
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210+ True -> show . currentBytesUsed <$> getRTSStats
188211 False -> return "??"
189212 cbCount <- M.size <$> readTVarIO callbacks
190− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
191214 False -> return ()
192− _ <- forkIO . forever $ readBatch commandChan >>= \case
193− (batch@(Batch cmds _), resultMVars) -> do
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216+ readBatch nBatch commandChan >>= \case
217+ (batch@(Batch cmds _ _), resultMVars) -> do
194218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219+ _ <- tryTakeMVar lastAsyncBatch
220+ putMVar lastAsyncBatch batch
195221 sendBatch batch
196− takeMVar recvMVar >>= \case
197− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
198− | otherwise -> zipWithM_ putMVar resultMVars results
199− Failure results exception -> do
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)
225+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
226+ | otherwise -> do
227+ zipWithM_ putMVar resultMVars results
228+ forM_ callbacksToFree $ \(JSValueReceived val) ->
229+ atomically (modifyTVar' callbacks (M.delete val))
230+ (_, Failure callbacksToFree results exception err) -> do
200231 -- The exception will only be rethrown in Haskell if/when one of the
201232 -- missing results (if any) is evaluated.
202233 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234+ putStrLn err
203235 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
204− _ -> error "Unexpected jsaddle results"
205− return (processResults, runReaderT (unJSM entryPoint) ctx)
236+ forM_ callbacksToFree $ \(JSValueReceived val) ->
237+ atomically (modifyTVar' callbacks (M.delete val))
238+ return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
206239 where
207− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
208− readBatch chan = do
240+ numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
241+ numberForeverFromM_ !n f = do
242+ _ <- f n
243+ numberForeverFromM_ (succ n) f
244+ takeResult recvMVar nBatch =
245+ takeMVar recvMVar >>= \case
246+ (n, _) | n < nBatch -> takeResult recvMVar nBatch
247+ r -> return r
248+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
249+ readBatch nBatch chan = do
209250 first <- atomically $ readTChan chan -- We want at least one command to send
210251 loop first ([], [])
211252 where
@@ -216,28 +257,55 @@ runJavaScript sendBatch entryPoint = do
216257 let cmds = Right syncCmd:cmds'
217258 resultMVars = resultMVar:resultMVars'
218259 atomically (tryReadTChan chan) >>= \case
219− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
260+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
220261 Just cmd -> loop cmd (cmds, resultMVars)
221262 loop (Left asyncCmd) (cmds', resultMVars) = do
222263 let cmds = Left asyncCmd:cmds'
223264 atomically (tryReadTChan chan) >>= \case
224− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
265+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
225266 Just cmd -> loop cmd (cmds, resultMVars)
226267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
227268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
228269 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))
230271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
231272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
232273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
233274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
234275
276+addThreadFinalizer :: ThreadId -> IO () -> IO ()
277+addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
278+ IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
279+
280+
235281wrapJSVal :: JSValueReceived -> JSM JSVal
236−wrapJSVal (JSValueReceived ref) = do
237− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
238− let result = JSVal ref
239− when (ref >= 5) $ do
240− ctx <- JSM ask
241− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
242− return result
282+wrapJSVal v = do
283+ ctx <- JSM ask
284+ liftIO $ wrapJSVal' ctx v
285+
286+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
287+wrapJSVal' ctx (JSValueReceived n) = do
288+ ref <- liftIO $ newIORef n
289+ when (n >= 5 || n < 0) $
290+#ifdef JSADDLE_CHECK_WRAPJSVAL
291+ do lr <- takeMVar $ liveRefs ctx
292+ if n `S.member` lr
293+ then do
294+ putStrLn $ "JS Value Ref " <> show n <> " already wrapped"
295+ putMVar (liveRefs ctx) lr
296+ else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)
297+#endif
298+ void . mkWeakIORef ref $ do
299+ ft <- takeMVar $ finalizerThreads ctx
300+ t <- myThreadId
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
305+ else do
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)
310+ return (JSVal ref)
243311#endif