@@ -1,9 +1,6 @@
1−{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE MagicHash #-}
6−{-# LANGUAGE UnboxedTuples #-}
7-----------------------------------------------------------------------------
4-----------------------------------------------------------------------------
9-- Module : Language.Javascript.JSaddle.Run
6-- Module : Language.Javascript.JSaddle.Run
@@ -22,7 +19,6 @@ module Language.Javascript.JSaddle.Run (
22 , syncAfter
19 , syncAfter
23 , waitForAnimationFrame
20 , waitForAnimationFrame
24 , nextAnimationFrame
21 , nextAnimationFrame
26#ifndef ghcjs_HOST_OS
22#ifndef ghcjs_HOST_OS
27 -- * Functions used to implement JSaddle using JSON messaging
23 -- * Functions used to implement JSaddle using JSON messaging
28 , runJavaScript
24 , runJavaScript
@@ -37,67 +33,60 @@ module Language.Javascript.JSaddle.Run (
39#ifdef ghcjs_HOST_OS
35#ifdef ghcjs_HOST_OS
40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
36+import Language.Javascript.JSaddle.Types (JSM)
41import qualified JavaScript.Web.AnimationFrame as GHCJS
37import qualified JavaScript.Web.AnimationFrame as GHCJS
42 (waitForAnimationFrame)
38 (waitForAnimationFrame)
44−import Control.Exception (throwIO, evaluate)
40+import Control.Exception (throwIO)
45−import Control.Monad (void, when, zipWithM_)
41+import Control.Monad (void, when, forever, zipWithM_)
46import Control.Monad.IO.Class (MonadIO(..))
42import Control.Monad.IO.Class (MonadIO(..))
47import Control.Monad.Trans.Reader (ask, runReaderT)
43import Control.Monad.Trans.Reader (ask, runReaderT)
48import Control.Monad.STM (atomically)
44import Control.Monad.STM (atomically)
49−import Control.Concurrent (forkIO, myThreadId)
45+import Control.Concurrent (forkIO)
50import Control.Concurrent.STM.TChan
46import Control.Concurrent.STM.TChan
51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
47 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
52import Control.Concurrent.STM.TVar
48import Control.Concurrent.STM.TVar
53 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
49 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
54import Control.Concurrent.MVar
50import Control.Concurrent.MVar
55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
51+ (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
57import System.IO.Unsafe (unsafeInterleaveIO)
53import System.IO.Unsafe (unsafeInterleaveIO)
58import System.Mem.Weak (addFinalizer)
54import System.Mem.Weak (addFinalizer)
61−import GHC.Base (IO(..), mkWeak#)
62−import GHC.Conc (ThreadId(..))
63import Data.Monoid ((<>))
56import Data.Monoid ((<>))
64−import qualified Data.Text as T (unpack, pack)
57+import qualified Data.Text as T (unpack)
65import qualified Data.Map as M (lookup, delete, insert, empty, size)
58import qualified Data.Map as M (lookup, delete, insert, empty, size)
66−import qualified Data.Set as S (empty, member, insert, delete)
67import Data.Time.Clock (getCurrentTime,diffUTCTime)
59import Data.Time.Clock (getCurrentTime,diffUTCTime)
69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
60+import Data.IORef (newIORef, atomicWriteIORef, readIORef)
71import Language.Javascript.JSaddle.Types
62import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
63+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
64+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
74import Language.Javascript.JSaddle.Exception (JSException(..))
65import Language.Javascript.JSaddle.Exception (JSException(..))
66+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
75−import Control.DeepSeq (force, deepseq)
67+import Control.DeepSeq (deepseq)
76−#if MIN_VERSION_base(4,11,0)
77−import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)
79import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
68import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
81−import Data.Foldable (forM_)
71+-- | Forces execution of pending asyncronous code
84−#ifndef ghcjs_HOST_OS
73+#ifdef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
74+syncPoint = return ()
86−currentBytesUsed = gcdetails_live_bytes . gc
88−getRTSStatsEnabled = getGCStatsEnabled
76+syncPoint = do
89−getRTSStats = getGCStats
77+ SyncResult <- sendCommand Sync
93−-- | Enable (or disable) JSaddle logging
81+-- | Forces execution of pending asyncronous code after performing `f`
94−enableLogging :: Bool -> JSM ()
82+syncAfter :: JSM a -> JSM a
95#ifdef ghcjs_HOST_OS
83#ifdef ghcjs_HOST_OS
96−enableLogging _ = return ()
84+syncAfter = id
98−enableLogging v = do
86+syncAfter f = do
99− f <- doEnableLogging <$> JSM ask
87+ result <- f
100− liftIO $ f v
88+ syncPoint
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
92-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
@@ -125,12 +114,17 @@ nextAnimationFrame f = do
125 syncAfter (f t)
114 syncAfter (f t)
127#ifndef ghcjs_HOST_OS
116#ifndef ghcjs_HOST_OS
117+sendCommand :: Command -> JSM Result
119+ s <- doSendCommand <$> JSM ask
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
122sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129sendLazyCommand cmd = do
123sendLazyCommand cmd = do
130 nextRefTVar <- nextRef <$> JSM ask
124 nextRefTVar <- nextRef <$> JSM ask
131 n <- liftIO . atomically $ do
125 n <- liftIO . atomically $ do
132 n <- subtract 1 <$> readTVar nextRefTVar
126 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
127+ writeTVar nextRefTVar n
135 s <- doSendAsyncCommand <$> JSM ask
129 s <- doSendAsyncCommand <$> JSM ask
136 liftIO $ s (cmd $ JSValueForSend n)
130 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,112 +135,66 @@ sendAsyncCommand cmd = do
141 s <- doSendAsyncCommand <$> JSM ask
135 s <- doSendAsyncCommand <$> JSM ask
142 liftIO $ s cmd
136 liftIO $ s cmd
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
138+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
145runJavaScript sendBatch entryPoint = do
139runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147 startTime' <- getCurrentTime
140 startTime' <- getCurrentTime
148 recvMVar <- newEmptyMVar
141 recvMVar <- newEmptyMVar
149− lastAsyncBatch <- newEmptyMVar
150 commandChan <- newTChanIO
142 commandChan <- newTChanIO
151 callbacks <- newTVarIO M.empty
143 callbacks <- newTVarIO M.empty
152 nextRef' <- newTVarIO 0
144 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155 loggingEnabled <- newIORef False
145 loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157 let ctx = JSContextRef {
146 let ctx = JSContextRef {
158− contextId = contextId'
159− , startTime = startTime'
147+ startTime = startTime'
160− , doSendCommand = \cmd -> cmd `deepseq` do
148+ , doSendCommand = \cmd -> cmd `deepseq` do
161− result <- newEmptyMVar
149+ result <- newEmptyMVar
162− atomically $ writeTChan commandChan (Right (cmd, result))
150+ atomically $ writeTChan commandChan (Right (cmd, result))
163− unsafeInterleaveIO $
151+ unsafeInterleaveIO $
164− takeMVar result >>= \case
152+ takeMVar result >>= \case
165− (ThrowJSValue v) -> do
166− jsval <- wrapJSVal' ctx v
167− throwIO $ JSException jsval
153+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
168− r -> return r
154+ r -> return r
169− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
155+ , 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)
156+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
157+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
173− , nextRef = nextRef'
158+ , nextRef = nextRef'
174− , doEnableLogging = atomicWriteIORef loggingEnabled
159+ , enableLogging = atomicWriteIORef loggingEnabled
175− , finalizerThreads = finalizerThreads'
176− , animationFrameHandlers = animationFrameHandlers'
177− , liveRefs = liveRefs'
179− processResults :: Bool -> Results -> IO ()
180− processResults syncCallbacks = \case
161+ let processResults = \case
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
162 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
182− (Callback n br (JSValueReceived fNumber) f this a) -> do
163+ (Callback f this a) -> do
183− putMVar recvMVar (n, br)
164+ logInfo ("Call " <>)
184− f' <- runReaderT (unJSM $ wrapJSVal f) ctx
165+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
166 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
167 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
168 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
169 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
190− Just cb -> void . forkIO $ do
191− runReaderT (unJSM $ cb f' this' args) ctx
170+ Just cb -> void . forkIO $ 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)
171+ m -> putMVar recvMVar m
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 =
172 logInfo s =
207 readIORef loggingEnabled >>= \case
173 readIORef loggingEnabled >>= \case
208 True -> do
174 True -> do
209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case
175+ currentBytesUsedStr <- getGCStatsEnabled >>= \case
210− True -> show . currentBytesUsed <$> getRTSStats
176+ True -> show . currentBytesUsed <$> getGCStats
211 False -> return "??"
177 False -> return "??"
212 cbCount <- M.size <$> readTVarIO callbacks
178 cbCount <- M.size <$> readTVarIO callbacks
213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
179+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
214 False -> return ()
180 False -> return ()
215− _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216− readBatch nBatch commandChan >>= \case
181+ _ <- forkIO . forever $ readBatch commandChan >>= \case
217− (batch@(Batch cmds _ _), resultMVars) -> do
182+ (batch@(Batch cmds _), resultMVars) -> do
218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
183 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
221 sendBatch batch
184 sendBatch batch
222− takeResult recvMVar nBatch >>= \case
185+ takeMVar recvMVar >>= \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"
186+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
227− zipWithM_ putMVar resultMVars results
187+ | otherwise -> zipWithM_ putMVar resultMVars results
228− forM_ callbacksToFree $ \(JSValueReceived val) ->
229− atomically (modifyTVar' callbacks (M.delete val))
230− (_, Failure callbacksToFree results exception err) -> do
188+ Failure results exception -> do
231 -- The exception will only be rethrown in Haskell if/when one of the
189 -- The exception will only be rethrown in Haskell if/when one of the
232 -- missing results (if any) is evaluated.
190 -- missing results (if any) is evaluated.
233 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
191 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
235 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
192 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236− forM_ callbacksToFree $ \(JSValueReceived val) ->
193+ _ -> error "Unexpected jsaddle results"
237− atomically (modifyTVar' callbacks (M.delete val))
238− return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
194+ return (processResults, runReaderT (unJSM entryPoint) ctx)
240− numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
241− numberForeverFromM_ !n f = do
243− numberForeverFromM_ (succ n) f
244− takeResult recvMVar nBatch =
245− takeMVar recvMVar >>= \case
246− (n, _) | n < nBatch -> takeResult recvMVar nBatch
248− readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
196+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
249− readBatch nBatch chan = do
197+ readBatch chan = do
250 first <- atomically $ readTChan chan -- We want at least one command to send
198 first <- atomically $ readTChan chan -- We want at least one command to send
251 loop first ([], [])
199 loop first ([], [])
@@ -257,55 +205,28 @@ runJavaScript sendBatch entryPoint = do
257 let cmds = Right syncCmd:cmds'
205 let cmds = Right syncCmd:cmds'
258 resultMVars = resultMVar:resultMVars'
206 resultMVars = resultMVar:resultMVars'
259 atomically (tryReadTChan chan) >>= \case
207 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
208+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
261 Just cmd -> loop cmd (cmds, resultMVars)
209 Just cmd -> loop cmd (cmds, resultMVars)
262 loop (Left asyncCmd) (cmds', resultMVars) = do
210 loop (Left asyncCmd) (cmds', resultMVars) = do
263 let cmds = Left asyncCmd:cmds'
211 let cmds = Left asyncCmd:cmds'
264 atomically (tryReadTChan chan) >>= \case
212 atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
213+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
266 Just cmd -> loop cmd (cmds, resultMVars)
214 Just cmd -> loop cmd (cmds, resultMVars)
267 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
215 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
216 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
217 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))
271 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
219 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
220 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
221 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
222 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
276−addThreadFinalizer :: ThreadId -> IO () -> IO ()
277−addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
278− IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
281wrapJSVal :: JSValueReceived -> JSM JSVal
224wrapJSVal :: JSValueReceived -> JSM JSVal
282−wrapJSVal v = do
225+wrapJSVal (JSValueReceived ref) = do
283− ctx <- JSM ask
226+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
284− liftIO $ wrapJSVal' ctx v
227+ let result = JSVal ref
286−wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
287−wrapJSVal' ctx (JSValueReceived n) = do
288− ref <- liftIO $ newIORef n
289− when (n >= 5 || n < 0) $
228+ when (ref >= 5) $ do
290−#ifdef JSADDLE_CHECK_WRAPJSVAL
229+ ctx <- JSM ask
291− do lr <- takeMVar $ liveRefs ctx
294− putStrLn $ "JS Value Ref " <> show n <> " already wrapped"
295− putMVar (liveRefs ctx) lr
296− else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)
298− void . mkWeakIORef ref $ do
299− ft <- takeMVar $ finalizerThreads ctx
301− let tname = T.pack $ show t
302− doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n
230+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
303− if tname `S.member` ft
304− then putMVar (finalizerThreads ctx) ft
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)
231+ return result