@@ -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
@@ -37,59 +34,43 @@ module Language.Javascript.JSaddle.Run (
39#ifdef ghcjs_HOST_OS
36#ifdef ghcjs_HOST_OS
40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
37+import Language.Javascript.JSaddle.Types (JSM)
41import qualified JavaScript.Web.AnimationFrame as GHCJS
38import qualified JavaScript.Web.AnimationFrame as GHCJS
42 (waitForAnimationFrame)
39 (waitForAnimationFrame)
44−import Control.Exception (throwIO, evaluate)
41+import Control.Exception (throwIO)
45−import Control.Monad (void, when, zipWithM_)
42+import Control.Monad (void, when, forever, zipWithM_)
46import Control.Monad.IO.Class (MonadIO(..))
43import Control.Monad.IO.Class (MonadIO(..))
47import Control.Monad.Trans.Reader (ask, runReaderT)
44import Control.Monad.Trans.Reader (ask, runReaderT)
48import Control.Monad.STM (atomically)
45import Control.Monad.STM (atomically)
49−import Control.Concurrent (forkIO, myThreadId)
46+import Control.Concurrent (forkIO)
50import Control.Concurrent.STM.TChan
47import Control.Concurrent.STM.TChan
51 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
48 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
52import Control.Concurrent.STM.TVar
49import Control.Concurrent.STM.TVar
53 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
50 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
54import Control.Concurrent.MVar
51import Control.Concurrent.MVar
55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
52+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)
57import System.IO.Unsafe (unsafeInterleaveIO)
54import System.IO.Unsafe (unsafeInterleaveIO)
58import System.Mem.Weak (addFinalizer)
55import System.Mem.Weak (addFinalizer)
61−import GHC.Base (IO(..), mkWeak#)
62−import GHC.Conc (ThreadId(..))
63import Data.Monoid ((<>))
57import Data.Monoid ((<>))
64−import qualified Data.Text as T (unpack, pack)
58+import qualified Data.Text as T (unpack)
65import qualified Data.Map as M (lookup, delete, insert, empty, size)
59import 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)
60import Data.Time.Clock (getCurrentTime,diffUTCTime)
69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
61+import Data.IORef (newIORef, atomicWriteIORef, readIORef)
71import Language.Javascript.JSaddle.Types
63import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
64+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
65+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
74import Language.Javascript.JSaddle.Exception (JSException(..))
66import Language.Javascript.JSaddle.Exception (JSException(..))
67+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
75−import Control.DeepSeq (force, deepseq)
68+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(..))
69import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
80−#endif
70+import Data.Maybe (isJust)
81import Data.Foldable (forM_)
71import Data.Foldable (forM_)
85−#if MIN_VERSION_base(4,11,0)
86−currentBytesUsed = gcdetails_live_bytes . gc
88−getRTSStatsEnabled = getGCStatsEnabled
89−getRTSStats = getGCStats
93-- | Enable (or disable) JSaddle logging
74-- | Enable (or disable) JSaddle logging
94enableLogging :: Bool -> JSM ()
75enableLogging :: Bool -> JSM ()
95#ifdef ghcjs_HOST_OS
76#ifdef ghcjs_HOST_OS
@@ -100,6 +81,27 @@ enableLogging v = do
100 liftIO $ f v
81 liftIO $ f v
84+-- | Forces execution of pending asyncronous code
90+ SyncResult <- sendCommand Sync
94+-- | Forces execution of pending asyncronous code after performing `f`
95+syncAfter :: JSM a -> JSM a
103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
105-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
104-- On GHC it will delay the execution of the current batch of asynchronous
106-- On GHC it will delay the execution of the current batch of asynchronous
105-- command when they are sent to JavaScript. It will not delay the Haskell
107-- command when they are sent to JavaScript. It will not delay the Haskell
@@ -125,12 +127,17 @@ nextAnimationFrame f = do
125 syncAfter (f t)
127 syncAfter (f t)
127#ifndef ghcjs_HOST_OS
129#ifndef ghcjs_HOST_OS
130+sendCommand :: Command -> JSM Result
132+ s <- doSendCommand <$> JSM ask
128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
135sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129sendLazyCommand cmd = do
136sendLazyCommand cmd = do
130 nextRefTVar <- nextRef <$> JSM ask
137 nextRefTVar <- nextRef <$> JSM ask
131 n <- liftIO . atomically $ do
138 n <- liftIO . atomically $ do
132 n <- subtract 1 <$> readTVar nextRefTVar
139 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
140+ writeTVar nextRefTVar n
135 s <- doSendAsyncCommand <$> JSM ask
142 s <- doSendAsyncCommand <$> JSM ask
136 liftIO $ s (cmd $ JSValueForSend n)
143 liftIO $ s (cmd $ JSValueForSend n)
@@ -143,45 +150,34 @@ sendAsyncCommand cmd = do
144runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
151runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
145runJavaScript sendBatch entryPoint = do
152runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147 startTime' <- getCurrentTime
153 startTime' <- getCurrentTime
148 recvMVar <- newEmptyMVar
154 recvMVar <- newEmptyMVar
155+ syncSendBatch <- newEmptyMVar
149 lastAsyncBatch <- newEmptyMVar
156 lastAsyncBatch <- newEmptyMVar
150 commandChan <- newTChanIO
157 commandChan <- newTChanIO
151 callbacks <- newTVarIO M.empty
158 callbacks <- newTVarIO M.empty
152 nextRef' <- newTVarIO 0
159 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155 loggingEnabled <- newIORef False
160 loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157 let ctx = JSContextRef {
161 let ctx = JSContextRef {
158− contextId = contextId'
159− , startTime = startTime'
162+ startTime = startTime'
160− , doSendCommand = \cmd -> cmd `deepseq` do
163+ , doSendCommand = \cmd -> cmd `deepseq` do
161− result <- newEmptyMVar
164+ result <- newEmptyMVar
162− atomically $ writeTChan commandChan (Right (cmd, result))
165+ atomically $ writeTChan commandChan (Right (cmd, result))
163− unsafeInterleaveIO $
166+ unsafeInterleaveIO $
164− takeMVar result >>= \case
167+ takeMVar result >>= \case
165− (ThrowJSValue v) -> do
166− jsval <- wrapJSVal' ctx v
167− throwIO $ JSException jsval
168+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
168− r -> return r
169+ r -> return r
169− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
170+ , 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)
171+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
172+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
173− , nextRef = nextRef'
173+ , nextRef = nextRef'
174− , doEnableLogging = atomicWriteIORef loggingEnabled
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175− , finalizerThreads = finalizerThreads'
176− , animationFrameHandlers = animationFrameHandlers'
177− , liveRefs = liveRefs'
179− processResults :: Bool -> Results -> IO ()
176+ let processResults :: Bool -> Results -> IO ()
180 processResults syncCallbacks = \case
177 processResults syncCallbacks = \case
181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
182− (Callback n br (JSValueReceived fNumber) f this a) -> do
179+ (Callback f this a) -> do
183− putMVar recvMVar (n, br)
184− f' <- runReaderT (unJSM $ wrapJSVal f) ctx
180+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187 logInfo (("Call " <> show fNumber <> " ") <>)
183 logInfo (("Call " <> show fNumber <> " ") <>)
@@ -189,62 +185,58 @@ runJavaScript sendBatch entryPoint = do
189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
190 Just cb -> void . forkIO $ do
186 Just cb -> void . forkIO $ do
191 runReaderT (unJSM $ cb f' this' args) ctx
187 runReaderT (unJSM $ cb f' this' args) ctx
192− when syncCallbacks $
188+ when syncCallbacks $ do
193 doSendAsyncCommand ctx EndSyncBlock
189 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
190+ void $ doSendCommand ctx Sync
191+ Duplicate -> error "Error : Unexpected Duplicate"
198− BatchResults n br -> putMVar recvMVar (n, br)
192+ m -> putMVar recvMVar m
199 asyncResults :: Results -> IO ()
193 asyncResults :: Results -> IO ()
200− asyncResults results =
201− void . forkIO $ processResults False results
194+ asyncResults = processResults False
202 syncResults :: Results -> IO Batch
195 syncResults :: Results -> IO Batch
203 syncResults results = do
196 syncResults results = do
204− void . forkIO $ processResults True results
197+ existing <- tryTakeMVar syncSendBatch
198+ when (isJust existing) $ error "Error : Unexpected Sync Results"
205− readMVar lastAsyncBatch
199+ tryTakeMVar lastAsyncBatch >>= \case
200+ Just lastAsync -> processResults True results >> return lastAsync
202+ nextBatch <- newEmptyMVar
203+ putMVar syncSendBatch (\batch -> do
204+ existing <- tryTakeMVar nextBatch
205+ when (isJust existing) $ error "Error : Unexpected Sync Results"
206+ putMVar nextBatch batch)
207+ processResults True results
206 logInfo s =
209 logInfo s =
207 readIORef loggingEnabled >>= \case
210 readIORef loggingEnabled >>= \case
208 True -> do
211 True -> do
209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case
212+ currentBytesUsedStr <- getGCStatsEnabled >>= \case
210− True -> show . currentBytesUsed <$> getRTSStats
213+ True -> show . currentBytesUsed <$> getGCStats
211 False -> return "??"
214 False -> return "??"
212 cbCount <- M.size <$> readTVarIO callbacks
215 cbCount <- M.size <$> readTVarIO callbacks
213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
216+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
214 False -> return ()
217 False -> return ()
215− _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
218+ _ <- forkIO . forM_ [1..] $ \nBatch ->
216 readBatch nBatch commandChan >>= \case
219 readBatch nBatch commandChan >>= \case
217 (batch@(Batch cmds _ _), resultMVars) -> do
220 (batch@(Batch cmds _ _), resultMVars) -> do
218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
222+ tryTakeMVar syncSendBatch >>= \case
223+ Just send -> send batch
220− putMVar lastAsyncBatch batch
225+ putMVar lastAsyncBatch batch
221− sendBatch batch
226+ sendBatch batch
222− takeResult recvMVar nBatch >>= \case
227+ takeMVar recvMVar >>= \r -> do
223− (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
228+ _ <- tryTakeMVar lastAsyncBatch
224− (_, Success callbacksToFree results)
229+ case r of
225− | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
230+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
227− zipWithM_ putMVar resultMVars results
231+ | otherwise -> zipWithM_ putMVar resultMVars results
228− forM_ callbacksToFree $ \(JSValueReceived val) ->
229− atomically (modifyTVar' callbacks (M.delete val))
230− (_, Failure callbacksToFree results exception err) -> do
232+ Failure results exception -> do
231− -- The exception will only be rethrown in Haskell if/when one of the
233+ -- The exception will only be rethrown in Haskell if/when one of the
232− -- missing results (if any) is evaluated.
234+ -- missing results (if any) is evaluated.
233− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
235+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
235− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236− forM_ callbacksToFree $ \(JSValueReceived val) ->
237+ _ -> error "Unexpected jsaddle results"
237− atomically (modifyTVar' callbacks (M.delete val))
238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
238 return (asyncResults, syncResults, 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])
240 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
249 readBatch nBatch chan = do
241 readBatch nBatch chan = do
250 first <- atomically $ readTChan chan -- We want at least one command to send
242 first <- atomically $ readTChan chan -- We want at least one command to send
@@ -273,39 +265,12 @@ runJavaScript sendBatch entryPoint = do
273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
265 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
266 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
268wrapJSVal :: JSValueReceived -> JSM JSVal
282−wrapJSVal v = do
269+wrapJSVal (JSValueReceived ref) = do
283− ctx <- JSM ask
270+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
284− liftIO $ wrapJSVal' ctx v
271+ 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) $
272+ when (ref >= 5) $ do
290−#ifdef JSADDLE_CHECK_WRAPJSVAL
273+ 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
274+ 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)
275+ return result