@@ -1,9 +1,6 @@
1−{-# LANGUAGE BangPatterns #-}
21{-# LANGUAGE CPP #-}
32{-# LANGUAGE LambdaCase #-}
43{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE MagicHash #-}
6−{-# LANGUAGE UnboxedTuples #-}
74-----------------------------------------------------------------------------
85--
96-- Module : Language.Javascript.JSaddle.Run
@@ -22,7 +19,6 @@ module Language.Javascript.JSaddle.Run (
2219 , syncAfter
2320 , waitForAnimationFrame
2421 , nextAnimationFrame
25− , enableLogging
2622#ifndef ghcjs_HOST_OS
2723 -- * Functions used to implement JSaddle using JSON messaging
2824 , runJavaScript
@@ -37,67 +33,60 @@ module Language.Javascript.JSaddle.Run (
3733) where
3834
3935#ifdef ghcjs_HOST_OS
40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
36+import Language.Javascript.JSaddle.Types (JSM)
4137import qualified JavaScript.Web.AnimationFrame as GHCJS
4238 (waitForAnimationFrame)
4339#else
44−import Control.Exception (throwIO, evaluate)
45−import Control.Monad (void, when, zipWithM_)
40+import Control.Exception (throwIO)
41+import Control.Monad (void, when, forever, zipWithM_)
4642import Control.Monad.IO.Class (MonadIO(..))
4743import Control.Monad.Trans.Reader (ask, runReaderT)
4844import Control.Monad.STM (atomically)
49−import Control.Concurrent (forkIO, myThreadId)
45+import Control.Concurrent (forkIO)
5046import Control.Concurrent.STM.TChan
5147 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
5248import Control.Concurrent.STM.TVar
5349 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5450import Control.Concurrent.MVar
55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
51+ (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
5652
5753import System.IO.Unsafe (unsafeInterleaveIO)
5854import System.Mem.Weak (addFinalizer)
59−import System.Random
6055
61−import GHC.Base (IO(..), mkWeak#)
62−import GHC.Conc (ThreadId(..))
6356import Data.Monoid ((<>))
64−import qualified Data.Text as T (unpack, pack)
57+import qualified Data.Text as T (unpack)
6558import qualified Data.Map as M (lookup, delete, insert, empty, size)
66−import qualified Data.Set as S (empty, member, insert, delete)
6759import Data.Time.Clock (getCurrentTime,diffUTCTime)
68−import Data.IORef
69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
60+import Data.IORef (newIORef, atomicWriteIORef, readIORef)
7061
7162import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
63+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
64+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
7465import Language.Javascript.JSaddle.Exception (JSException(..))
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
66+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
67+import Control.DeepSeq (deepseq)
7968import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
8069#endif
81−import Data.Foldable (forM_)
82−#endif
8370
84−#ifndef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
86−currentBytesUsed = gcdetails_live_bytes . gc
71+-- | Forces execution of pending asyncronous code
72+syncPoint :: JSM ()
73+#ifdef ghcjs_HOST_OS
74+syncPoint = return ()
8775#else
88−getRTSStatsEnabled = getGCStatsEnabled
89−getRTSStats = getGCStats
90−#endif
76+syncPoint = do
77+ SyncResult <- sendCommand Sync
78+ return ()
9179#endif
9280
93−-- | Enable (or disable) JSaddle logging
94−enableLogging :: Bool -> JSM ()
81+-- | Forces execution of pending asyncronous code after performing `f`
82+syncAfter :: JSM a -> JSM a
9583#ifdef ghcjs_HOST_OS
96−enableLogging _ = return ()
84+syncAfter = id
9785#else
98−enableLogging v = do
99− f <- doEnableLogging <$> JSM ask
100− liftIO $ f v
86+syncAfter f = do
87+ result <- f
88+ syncPoint
89+ return result
10190#endif
10291
10392-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -125,12 +114,17 @@ nextAnimationFrame f = do
125114 syncAfter (f t)
126115
127116#ifndef ghcjs_HOST_OS
117+sendCommand :: Command -> JSM Result
118+sendCommand cmd = do
119+ s <- doSendCommand <$> JSM ask
120+ liftIO $ s cmd
121+
128122sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129123sendLazyCommand cmd = do
130124 nextRefTVar <- nextRef <$> JSM ask
131125 n <- liftIO . atomically $ do
132126 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
127+ writeTVar nextRefTVar n
134128 return n
135129 s <- doSendAsyncCommand <$> JSM ask
136130 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,112 +135,66 @@ sendAsyncCommand cmd = do
141135 s <- doSendAsyncCommand <$> JSM ask
142136 liftIO $ s cmd
143137
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
138+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
145139runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147140 startTime' <- getCurrentTime
148141 recvMVar <- newEmptyMVar
149− lastAsyncBatch <- newEmptyMVar
150142 commandChan <- newTChanIO
151143 callbacks <- newTVarIO M.empty
152144 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155145 loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157146 let ctx = JSContextRef {
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
147+ startTime = startTime'
148+ , doSendCommand = \cmd -> cmd `deepseq` do
149+ result <- newEmptyMVar
150+ atomically $ writeTChan commandChan (Right (cmd, result))
151+ unsafeInterleaveIO $
152+ takeMVar result >>= \case
153+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
154+ r -> return r
155+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
156+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
157+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
158+ , nextRef = nextRef'
159+ , enableLogging = atomicWriteIORef loggingEnabled
160+ }
161+ let processResults = \case
181162 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
182− (Callback n br (JSValueReceived fNumber) f this a) -> do
183− putMVar recvMVar (n, br)
184− f' <- runReaderT (unJSM $ wrapJSVal f) ctx
163+ (Callback f this a) -> do
164+ logInfo ("Call " <>)
165+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185166 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186167 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188168 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189169 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
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
170+ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
171+ m -> putMVar recvMVar m
206172 logInfo s =
207173 readIORef loggingEnabled >>= \case
208174 True -> do
209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210− True -> show . currentBytesUsed <$> getRTSStats
175+ currentBytesUsedStr <- getGCStatsEnabled >>= \case
176+ True -> show . currentBytesUsed <$> getGCStats
211177 False -> return "??"
212178 cbCount <- M.size <$> readTVarIO callbacks
213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
179+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
214180 False -> return ()
215− _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216− readBatch nBatch commandChan >>= \case
217− (batch@(Batch cmds _ _), resultMVars) -> do
181+ _ <- forkIO . forever $ readBatch commandChan >>= \case
182+ (batch@(Batch cmds _), resultMVars) -> do
218183 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
221184 sendBatch batch
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
185+ takeMVar recvMVar >>= \case
186+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
187+ | otherwise -> zipWithM_ putMVar resultMVars results
188+ Failure results exception -> do
231189 -- The exception will only be rethrown in Haskell if/when one of the
232190 -- missing results (if any) is evaluated.
233191 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234− putStrLn err
235192 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236− forM_ callbacksToFree $ \(JSValueReceived val) ->
237− atomically (modifyTVar' callbacks (M.delete val))
238− return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
193+ _ -> error "Unexpected jsaddle results"
194+ return (processResults, runReaderT (unJSM entryPoint) ctx)
239195 where
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
196+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
197+ readBatch chan = do
250198 first <- atomically $ readTChan chan -- We want at least one command to send
251199 loop first ([], [])
252200 where
@@ -257,55 +205,28 @@ runJavaScript sendBatch entryPoint = do
257205 let cmds = Right syncCmd:cmds'
258206 resultMVars = resultMVar:resultMVars'
259207 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
208+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
261209 Just cmd -> loop cmd (cmds, resultMVars)
262210 loop (Left asyncCmd) (cmds', resultMVars) = do
263211 let cmds = Left asyncCmd:cmds'
264212 atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
213+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
266214 Just cmd -> loop cmd (cmds, resultMVars)
267215 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268216 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269217 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
270− return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
218+ return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
271219 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272220 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273221 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274222 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275223
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−
281224wrapJSVal :: JSValueReceived -> JSM JSVal
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)
225+wrapJSVal (JSValueReceived ref) = do
226+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
227+ let result = JSVal ref
228+ when (ref >= 5) $ do
229+ ctx <- JSM ask
230+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
231+ return result
311232#endif