@@ -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,59 @@ 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
53− (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
49+ (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)
7060
7161import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
62+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
63+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
7464import 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
65+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
66+import Control.DeepSeq (deepseq)
7967import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
8068#endif
81−import Data.Foldable (forM_)
82−#endif
8369
84−#ifndef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
86−currentBytesUsed = gcdetails_live_bytes . gc
70+-- | Forces execution of pending asyncronous code
71+syncPoint :: JSM ()
72+#ifdef ghcjs_HOST_OS
73+syncPoint = return ()
8774#else
88−getRTSStatsEnabled = getGCStatsEnabled
89−getRTSStats = getGCStats
90−#endif
75+syncPoint = do
76+ SyncResult <- sendCommand Sync
77+ return ()
9178#endif
9279
93−-- | Enable (or disable) JSaddle logging
94−enableLogging :: Bool -> JSM ()
80+-- | Forces execution of pending asyncronous code after performing `f`
81+syncAfter :: JSM a -> JSM a
9582#ifdef ghcjs_HOST_OS
96−enableLogging _ = return ()
83+syncAfter = id
9784#else
98−enableLogging v = do
99− f <- doEnableLogging <$> JSM ask
100− liftIO $ f v
85+syncAfter f = do
86+ result <- f
87+ syncPoint
88+ return result
10189#endif
10290
10391-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -125,12 +113,17 @@ nextAnimationFrame f = do
125113 syncAfter (f t)
126114
127115#ifndef ghcjs_HOST_OS
116+sendCommand :: Command -> JSM Result
117+sendCommand cmd = do
118+ s <- doSendCommand <$> JSM ask
119+ liftIO $ s cmd
120+
128121sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129122sendLazyCommand cmd = do
130123 nextRefTVar <- nextRef <$> JSM ask
131124 n <- liftIO . atomically $ do
132125 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
126+ writeTVar nextRefTVar n
134127 return n
135128 s <- doSendAsyncCommand <$> JSM ask
136129 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,112 +134,61 @@ sendAsyncCommand cmd = do
141134 s <- doSendAsyncCommand <$> JSM ask
142135 liftIO $ s cmd
143136
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
137+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
145138runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147139 startTime' <- getCurrentTime
148140 recvMVar <- newEmptyMVar
149− lastAsyncBatch <- newEmptyMVar
150141 commandChan <- newTChanIO
151142 callbacks <- newTVarIO M.empty
152143 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155− loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157144 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
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
181159 (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
160+ (Callback f this a) -> do
161+ logInfo ("Call " <>)
162+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185163 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186164 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188165 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189166 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
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
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
218177 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
221178 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
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
231183 -- The exception will only be rethrown in Haskell if/when one of the
232184 -- missing results (if any) is evaluated.
233185 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234− putStrLn err
235186 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)
187+ _ -> error "Unexpected jsaddle results"
188+ return (processResults, runReaderT (unJSM entryPoint) ctx)
239189 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
190+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
191+ readBatch chan = do
250192 first <- atomically $ readTChan chan -- We want at least one command to send
251193 loop first ([], [])
252194 where
@@ -257,55 +199,28 @@ runJavaScript sendBatch entryPoint = do
257199 let cmds = Right syncCmd:cmds'
258200 resultMVars = resultMVar:resultMVars'
259201 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
202+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
261203 Just cmd -> loop cmd (cmds, resultMVars)
262204 loop (Left asyncCmd) (cmds', resultMVars) = do
263205 let cmds = Left asyncCmd:cmds'
264206 atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
207+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
266208 Just cmd -> loop cmd (cmds, resultMVars)
267209 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268210 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269211 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
270− return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
212+ return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
271213 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272214 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273215 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274216 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275217
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−
281218wrapJSVal :: 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)
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
311226#endif