@@ -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,58 @@ 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)
65−import qualified Data.Map as M (lookup, delete, insert, empty, size)
66−import qualified Data.Set as S (empty, member, insert, delete)
57+import qualified Data.Text as T (unpack)
58+import qualified Data.Map as M (lookup, delete, insert, empty)
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
79−import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
80−#endif
81−import Data.Foldable (forM_)
65+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
66+import Control.DeepSeq (deepseq)
8267#endif
8368
84−#ifndef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
86−currentBytesUsed = gcdetails_live_bytes . gc
69+-- | Forces execution of pending asyncronous code
70+syncPoint :: JSM ()
71+#ifdef ghcjs_HOST_OS
72+syncPoint = return ()
8773#else
88−getRTSStatsEnabled = getGCStatsEnabled
89−getRTSStats = getGCStats
90−#endif
74+syncPoint = do
75+ SyncResult <- sendCommand Sync
76+ return ()
9177#endif
9278
93−-- | Enable (or disable) JSaddle logging
94−enableLogging :: Bool -> JSM ()
79+-- | Forces execution of pending asyncronous code after performing `f`
80+syncAfter :: JSM a -> JSM a
9581#ifdef ghcjs_HOST_OS
96−enableLogging _ = return ()
82+syncAfter = id
9783#else
98−enableLogging v = do
99− f <- doEnableLogging <$> JSM ask
100− liftIO $ f v
84+syncAfter f = do
85+ result <- f
86+ syncPoint
87+ return result
10188#endif
10289
10390-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -125,12 +112,17 @@ nextAnimationFrame f = do
125112 syncAfter (f t)
126113
127114#ifndef ghcjs_HOST_OS
115+sendCommand :: Command -> JSM Result
116+sendCommand cmd = do
117+ s <- doSendCommand <$> JSM ask
118+ liftIO $ s cmd
119+
128120sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129121sendLazyCommand cmd = do
130122 nextRefTVar <- nextRef <$> JSM ask
131123 n <- liftIO . atomically $ do
132124 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
125+ writeTVar nextRefTVar n
134126 return n
135127 s <- doSendAsyncCommand <$> JSM ask
136128 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,112 +133,52 @@ sendAsyncCommand cmd = do
141133 s <- doSendAsyncCommand <$> JSM ask
142134 liftIO $ s cmd
143135
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
136+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
145137runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147138 startTime' <- getCurrentTime
148− recvMVar <- newEmptyMVar
149− lastAsyncBatch <- newEmptyMVar
139+ recvChan <- newTChanIO
150140 commandChan <- newTChanIO
151141 callbacks <- newTVarIO M.empty
152142 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155− loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157143 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
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
181158 (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
159+ (Callback f this a) -> do
160+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185161 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186162 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188163 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189164 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
218− logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
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
221169 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
170+ atomically (readTChan recvChan) >>= \case
171+ Success results -> zipWithM_ putMVar resultMVars results
172+ Failure results exception -> do
231173 -- The exception will only be rethrown in Haskell if/when one of the
232174 -- missing results (if any) is evaluated.
233175 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234− putStrLn err
235176 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)
177+ _ -> error "Unexpected jsaddle results"
178+ return (processResults, runReaderT (unJSM entryPoint) ctx)
239179 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
180+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
181+ readBatch chan = do
250182 first <- atomically $ readTChan chan -- We want at least one command to send
251183 loop first ([], [])
252184 where
@@ -257,55 +189,28 @@ runJavaScript sendBatch entryPoint = do
257189 let cmds = Right syncCmd:cmds'
258190 resultMVars = resultMVar:resultMVars'
259191 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
192+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
261193 Just cmd -> loop cmd (cmds, resultMVars)
262194 loop (Left asyncCmd) (cmds', resultMVars) = do
263195 let cmds = Left asyncCmd:cmds'
264196 atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
197+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
266198 Just cmd -> loop cmd (cmds, resultMVars)
267199 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268200 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269201 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
270− return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
202+ return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
271203 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272204 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273205 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274206 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275207
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−
281208wrapJSVal :: 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)
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
311216#endif