@@ -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
@@ -19,6 +22,7 @@ module Language.Javascript.JSaddle.Run (
1922 , syncAfter
2023 , waitForAnimationFrame
2124 , nextAnimationFrame
25+ , enableLogging
2226#ifndef ghcjs_HOST_OS
2327 -- * Functions used to implement JSaddle using JSON messaging
2428 , runJavaScript
@@ -33,59 +37,67 @@ module Language.Javascript.JSaddle.Run (
3337) where
3438
3539#ifdef ghcjs_HOST_OS
36−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
3741import qualified JavaScript.Web.AnimationFrame as GHCJS
3842 (waitForAnimationFrame)
3943#else
40−import Control.Exception (throwIO)
41−import Control.Monad (void, when, forever, zipWithM_)
44+import Control.Exception (throwIO, evaluate)
45+import Control.Monad (void, when, zipWithM_)
4246import Control.Monad.IO.Class (MonadIO(..))
4347import Control.Monad.Trans.Reader (ask, runReaderT)
4448import Control.Monad.STM (atomically)
45−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
4650import Control.Concurrent.STM.TChan
4751 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
4852import Control.Concurrent.STM.TVar
49− (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)
53+ (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5054import Control.Concurrent.MVar
51− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
5256
5357import System.IO.Unsafe (unsafeInterleaveIO)
5458import System.Mem.Weak (addFinalizer)
59+import System.Random
5560
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
5663import Data.Monoid ((<>))
57−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
5865import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import qualified Data.Set as S (empty, member, insert, delete)
5967import Data.Time.Clock (getCurrentTime,diffUTCTime)
68+import Data.IORef
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
6070
6171import Language.Javascript.JSaddle.Types
62− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
63− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
72+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
6474import Language.Javascript.JSaddle.Exception (JSException(..))
65−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
66−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
6779import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
6880#endif
81+import Data.Foldable (forM_)
82+#endif
6983
70−-- | Forces execution of pending asyncronous code
71−syncPoint :: JSM ()
72−#ifdef ghcjs_HOST_OS
73−syncPoint = return ()
84+#ifndef ghcjs_HOST_OS
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
7487#else
75−syncPoint = do
76− SyncResult <- sendCommand Sync
77− return ()
88+getRTSStatsEnabled = getGCStatsEnabled
89+getRTSStats = getGCStats
90+#endif
7891#endif
7992
80−-- | Forces execution of pending asyncronous code after performing `f`
81−syncAfter :: JSM a -> JSM a
93+-- | Enable (or disable) JSaddle logging
94+enableLogging :: Bool -> JSM ()
8295#ifdef ghcjs_HOST_OS
83−syncAfter = id
96+enableLogging _ = return ()
8497#else
85−syncAfter f = do
86− result <- f
87− syncPoint
88− return result
98+enableLogging v = do
99+ f <- doEnableLogging <$> JSM ask
100+ liftIO $ f v
89101#endif
90102
91103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -113,17 +125,12 @@ nextAnimationFrame f = do
113125 syncAfter (f t)
114126
115127#ifndef ghcjs_HOST_OS
116−sendCommand :: Command -> JSM Result
117−sendCommand cmd = do
118− s <- doSendCommand <$> JSM ask
119− liftIO $ s cmd
120−
121128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
122129sendLazyCommand cmd = do
123130 nextRefTVar <- nextRef <$> JSM ask
124131 n <- liftIO . atomically $ do
125132 n <- subtract 1 <$> readTVar nextRefTVar
126− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
127134 return n
128135 s <- doSendAsyncCommand <$> JSM ask
129136 liftIO $ s (cmd $ JSValueForSend n)
@@ -134,61 +141,112 @@ sendAsyncCommand cmd = do
134141 s <- doSendAsyncCommand <$> JSM ask
135142 liftIO $ s cmd
136143
137−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
138145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
139147 startTime' <- getCurrentTime
140148 recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
141150 commandChan <- newTChanIO
142151 callbacks <- newTVarIO M.empty
143152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
155+ loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
144157 let ctx = JSContextRef {
145− startTime = startTime'
146− , doSendCommand = \cmd -> cmd `deepseq` do
147− result <- newEmptyMVar
148− atomically $ writeTChan commandChan (Right (cmd, result))
149− unsafeInterleaveIO $
150− takeMVar result >>= \case
151− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
152− r -> return r
153− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
154− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
155− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
156− , nextRef = nextRef'
157− }
158− 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
159181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
160− (Callback f this a) -> do
161− logInfo ("Call " <>)
162− 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
163185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
164186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
165188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
166189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
167− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
168− m -> putMVar recvMVar m
169− logInfo s = do
170− stats <- getGCStatsEnabled
171− when stats $ do
172− current <- currentBytesUsed <$> getGCStats
173− cbCount <- M.size <$> readTVarIO callbacks
174− putStrLn . s $ show (current, cbCount)
175− _ <- forkIO . forever $ readBatch commandChan >>= \case
176− (batch@(Batch cmds _), resultMVars) -> do
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
206+ logInfo s =
207+ readIORef loggingEnabled >>= \case
208+ True -> do
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210+ True -> show . currentBytesUsed <$> getRTSStats
211+ False -> return "??"
212+ cbCount <- M.size <$> readTVarIO callbacks
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
214+ False -> return ()
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216+ readBatch nBatch commandChan >>= \case
217+ (batch@(Batch cmds _ _), resultMVars) -> do
177218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219+ _ <- tryTakeMVar lastAsyncBatch
220+ putMVar lastAsyncBatch batch
178221 sendBatch batch
179− takeMVar recvMVar >>= \case
180− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
181− | otherwise -> zipWithM_ putMVar resultMVars results
182− 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
183231 -- The exception will only be rethrown in Haskell if/when one of the
184232 -- missing results (if any) is evaluated.
185233 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234+ putStrLn err
186235 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
187− _ -> error "Unexpected jsaddle results"
188− 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)
189239 where
190− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
191− 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
192250 first <- atomically $ readTChan chan -- We want at least one command to send
193251 loop first ([], [])
194252 where
@@ -199,28 +257,55 @@ runJavaScript sendBatch entryPoint = do
199257 let cmds = Right syncCmd:cmds'
200258 resultMVars = resultMVar:resultMVars'
201259 atomically (tryReadTChan chan) >>= \case
202− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
260+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
203261 Just cmd -> loop cmd (cmds, resultMVars)
204262 loop (Left asyncCmd) (cmds', resultMVars) = do
205263 let cmds = Left asyncCmd:cmds'
206264 atomically (tryReadTChan chan) >>= \case
207− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
265+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
208266 Just cmd -> loop cmd (cmds, resultMVars)
209267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
210268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
211269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
212− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
270+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
213271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
214272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
215273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
216274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
217275
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+
218281wrapJSVal :: JSValueReceived -> JSM JSVal
219−wrapJSVal (JSValueReceived ref) = do
220− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
221− let result = JSVal ref
222− when (ref >= 5) $ do
223− ctx <- JSM ask
224− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
225− 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)
226311#endif