@@ -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,58 +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)
58−import qualified Data.Map as M (lookup, delete, insert, empty)
64+import qualified Data.Text as T (unpack, pack)
65+import 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
79+import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
80+#endif
81+import Data.Foldable (forM_)
6782#endif
6883
69−-- | Forces execution of pending asyncronous code
70−syncPoint :: JSM ()
71−#ifdef ghcjs_HOST_OS
72−syncPoint = return ()
84+#ifndef ghcjs_HOST_OS
85+#if MIN_VERSION_base(4,11,0)
86+currentBytesUsed = gcdetails_live_bytes . gc
7387#else
74−syncPoint = do
75− SyncResult <- sendCommand Sync
76− return ()
88+getRTSStatsEnabled = getGCStatsEnabled
89+getRTSStats = getGCStats
90+#endif
7791#endif
7892
79−-- | Forces execution of pending asyncronous code after performing `f`
80−syncAfter :: JSM a -> JSM a
93+-- | Enable (or disable) JSaddle logging
94+enableLogging :: Bool -> JSM ()
8195#ifdef ghcjs_HOST_OS
82−syncAfter = id
96+enableLogging _ = return ()
8397#else
84−syncAfter f = do
85− result <- f
86− syncPoint
87− return result
98+enableLogging v = do
99+ f <- doEnableLogging <$> JSM ask
100+ liftIO $ f v
88101#endif
89102
90103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -112,17 +125,12 @@ nextAnimationFrame f = do
112125 syncAfter (f t)
113126
114127#ifndef ghcjs_HOST_OS
115−sendCommand :: Command -> JSM Result
116−sendCommand cmd = do
117− s <- doSendCommand <$> JSM ask
118− liftIO $ s cmd
119−
120128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
121129sendLazyCommand cmd = do
122130 nextRefTVar <- nextRef <$> JSM ask
123131 n <- liftIO . atomically $ do
124132 n <- subtract 1 <$> readTVar nextRefTVar
125− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
126134 return n
127135 s <- doSendAsyncCommand <$> JSM ask
128136 liftIO $ s (cmd $ JSValueForSend n)
@@ -133,52 +141,112 @@ sendAsyncCommand cmd = do
133141 s <- doSendAsyncCommand <$> JSM ask
134142 liftIO $ s cmd
135143
136−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
144+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
137145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
138147 startTime' <- getCurrentTime
139− recvChan <- newTChanIO
148+ recvMVar <- newEmptyMVar
149+ lastAsyncBatch <- newEmptyMVar
140150 commandChan <- newTChanIO
141151 callbacks <- newTVarIO M.empty
142152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
155+ loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
143157 let ctx = JSContextRef {
144− startTime = startTime'
145− , doSendCommand = \cmd -> cmd `deepseq` do
146− result <- newEmptyMVar
147− atomically $ writeTChan commandChan (Right (cmd, result))
148− unsafeInterleaveIO $
149− takeMVar result >>= \case
150− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
151− r -> return r
152− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
153− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
154− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
155− , nextRef = nextRef'
156− }
157− 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
158181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
159− (Callback f this a) -> do
160− 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
161185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
162186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187+ logInfo (("Call " <> show fNumber <> " ") <>)
163188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
164189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
165− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
166− m -> atomically $ writeTChan recvChan m
167− _ <- forkIO . forever $ readBatch commandChan >>= \case
168− (batch, 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
218+ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219+ _ <- tryTakeMVar lastAsyncBatch
220+ putMVar lastAsyncBatch batch
169221 sendBatch batch
170− atomically (readTChan recvChan) >>= \case
171− Success results -> zipWithM_ putMVar resultMVars results
172− 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
173231 -- The exception will only be rethrown in Haskell if/when one of the
174232 -- missing results (if any) is evaluated.
175233 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234+ putStrLn err
176235 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
177− _ -> error "Unexpected jsaddle results"
178− 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)
179239 where
180− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
181− 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
182250 first <- atomically $ readTChan chan -- We want at least one command to send
183251 loop first ([], [])
184252 where
@@ -189,28 +257,55 @@ runJavaScript sendBatch entryPoint = do
189257 let cmds = Right syncCmd:cmds'
190258 resultMVars = resultMVar:resultMVars'
191259 atomically (tryReadTChan chan) >>= \case
192− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
260+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
193261 Just cmd -> loop cmd (cmds, resultMVars)
194262 loop (Left asyncCmd) (cmds', resultMVars) = do
195263 let cmds = Left asyncCmd:cmds'
196264 atomically (tryReadTChan chan) >>= \case
197− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
265+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
198266 Just cmd -> loop cmd (cmds, resultMVars)
199267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
200268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
201269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
202− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
270+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
203271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
204272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
205273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
206274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
207275
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+
208281wrapJSVal :: JSValueReceived -> JSM JSVal
209−wrapJSVal (JSValueReceived ref) = do
210− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
211− let result = JSVal ref
212− when (ref >= 5) $ do
213− ctx <- JSM ask
214− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
215− 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)
216311#endif