@@ -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
@@ -37,59 +34,43 @@ module Language.Javascript.JSaddle.Run (
3734) where
3835
3936#ifdef ghcjs_HOST_OS
40−import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
37+import Language.Javascript.JSaddle.Types (JSM)
4138import qualified JavaScript.Web.AnimationFrame as GHCJS
4239 (waitForAnimationFrame)
4340#else
44−import Control.Exception (throwIO, evaluate)
45−import Control.Monad (void, when, zipWithM_)
41+import Control.Exception (throwIO)
42+import Control.Monad (void, when, forever, zipWithM_)
4643import Control.Monad.IO.Class (MonadIO(..))
4744import Control.Monad.Trans.Reader (ask, runReaderT)
4845import Control.Monad.STM (atomically)
49−import Control.Concurrent (forkIO, myThreadId)
46+import Control.Concurrent (forkIO)
5047import Control.Concurrent.STM.TChan
5148 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
5249import Control.Concurrent.STM.TVar
5350 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5451import Control.Concurrent.MVar
55− (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
52+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)
5653
5754import System.IO.Unsafe (unsafeInterleaveIO)
5855import System.Mem.Weak (addFinalizer)
59−import System.Random
6056
61−import GHC.Base (IO(..), mkWeak#)
62−import GHC.Conc (ThreadId(..))
6357import Data.Monoid ((<>))
64−import qualified Data.Text as T (unpack, pack)
58+import qualified Data.Text as T (unpack)
6559import qualified Data.Map as M (lookup, delete, insert, empty, size)
66−import qualified Data.Set as S (empty, member, insert, delete)
6760import Data.Time.Clock (getCurrentTime,diffUTCTime)
68−import Data.IORef
69− (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
61+import Data.IORef (newIORef, atomicWriteIORef, readIORef)
7062
7163import Language.Javascript.JSaddle.Types
72− (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
64+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
65+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
7466import 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
67+-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
68+import Control.DeepSeq (deepseq)
7969import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
80−#endif
70+import Data.Maybe (isJust)
8171import Data.Foldable (forM_)
8272#endif
8373
84−#ifndef ghcjs_HOST_OS
85−#if MIN_VERSION_base(4,11,0)
86−currentBytesUsed = gcdetails_live_bytes . gc
87−#else
88−getRTSStatsEnabled = getGCStatsEnabled
89−getRTSStats = getGCStats
90−#endif
91−#endif
92−
9374-- | Enable (or disable) JSaddle logging
9475enableLogging :: Bool -> JSM ()
9576#ifdef ghcjs_HOST_OS
@@ -100,6 +81,27 @@ enableLogging v = do
10081 liftIO $ f v
10182#endif
10283
84+-- | Forces execution of pending asyncronous code
85+syncPoint :: JSM ()
86+#ifdef ghcjs_HOST_OS
87+syncPoint = return ()
88+#else
89+syncPoint = do
90+ SyncResult <- sendCommand Sync
91+ return ()
92+#endif
93+
94+-- | Forces execution of pending asyncronous code after performing `f`
95+syncAfter :: JSM a -> JSM a
96+#ifdef ghcjs_HOST_OS
97+syncAfter = id
98+#else
99+syncAfter f = do
100+ result <- f
101+ syncPoint
102+ return result
103+#endif
104+
103105-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
104106-- On GHC it will delay the execution of the current batch of asynchronous
105107-- command when they are sent to JavaScript. It will not delay the Haskell
@@ -125,12 +127,17 @@ nextAnimationFrame f = do
125127 syncAfter (f t)
126128
127129#ifndef ghcjs_HOST_OS
130+sendCommand :: Command -> JSM Result
131+sendCommand cmd = do
132+ s <- doSendCommand <$> JSM ask
133+ liftIO $ s cmd
134+
128135sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129136sendLazyCommand cmd = do
130137 nextRefTVar <- nextRef <$> JSM ask
131138 n <- liftIO . atomically $ do
132139 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
140+ writeTVar nextRefTVar n
134141 return n
135142 s <- doSendAsyncCommand <$> JSM ask
136143 liftIO $ s (cmd $ JSValueForSend n)
@@ -143,45 +150,34 @@ sendAsyncCommand cmd = do
143150
144151runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
145152runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147153 startTime' <- getCurrentTime
148154 recvMVar <- newEmptyMVar
155+ syncSendBatch <- newEmptyMVar
149156 lastAsyncBatch <- newEmptyMVar
150157 commandChan <- newTChanIO
151158 callbacks <- newTVarIO M.empty
152159 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155160 loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157161 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 ()
162+ startTime = startTime'
163+ , doSendCommand = \cmd -> cmd `deepseq` do
164+ result <- newEmptyMVar
165+ atomically $ writeTChan commandChan (Right (cmd, result))
166+ unsafeInterleaveIO $
167+ takeMVar result >>= \case
168+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
169+ r -> return r
170+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
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'
174+ , doEnableLogging = atomicWriteIORef loggingEnabled
175+ }
176+ let processResults :: Bool -> Results -> IO ()
180177 processResults syncCallbacks = \case
181178 (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
179+ (Callback f this a) -> do
180+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187183 logInfo (("Call " <> show fNumber <> " ") <>)
@@ -189,62 +185,58 @@ runJavaScript sendBatch entryPoint = do
189185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
190186 Just cb -> void . forkIO $ do
191187 runReaderT (unJSM $ cb f' this' args) ctx
192− when syncCallbacks $
188+ when syncCallbacks $ do
193189 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)
190+ void $ doSendCommand ctx Sync
191+ Duplicate -> error "Error : Unexpected Duplicate"
192+ m -> putMVar recvMVar m
199193 asyncResults :: Results -> IO ()
200− asyncResults results =
201− void . forkIO $ processResults False results
194+ asyncResults = processResults False
202195 syncResults :: Results -> IO Batch
203196 syncResults results = do
204− void . forkIO $ processResults True results
205− readMVar lastAsyncBatch
197+ existing <- tryTakeMVar syncSendBatch
198+ when (isJust existing) $ error "Error : Unexpected Sync Results"
199+ tryTakeMVar lastAsyncBatch >>= \case
200+ Just lastAsync -> processResults True results >> return lastAsync
201+ Nothing -> do
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
208+ takeMVar nextBatch
206209 logInfo s =
207210 readIORef loggingEnabled >>= \case
208211 True -> do
209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210− True -> show . currentBytesUsed <$> getRTSStats
212+ currentBytesUsedStr <- getGCStatsEnabled >>= \case
213+ True -> show . currentBytesUsed <$> getGCStats
211214 False -> return "??"
212215 cbCount <- M.size <$> readTVarIO callbacks
213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
216+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
214217 False -> return ()
215− _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
218+ _ <- forkIO . forM_ [1..] $ \nBatch ->
216219 readBatch nBatch commandChan >>= \case
217220 (batch@(Batch cmds _ _), resultMVars) -> do
218221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
221− 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
231− -- The exception will only be rethrown in Haskell if/when one of the
232− -- missing results (if any) is evaluated.
233− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234− putStrLn err
235− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
236− forM_ callbacksToFree $ \(JSValueReceived val) ->
237− atomically (modifyTVar' callbacks (M.delete val))
222+ tryTakeMVar syncSendBatch >>= \case
223+ Just send -> send batch
224+ Nothing -> do
225+ putMVar lastAsyncBatch batch
226+ sendBatch batch
227+ takeMVar recvMVar >>= \r -> do
228+ _ <- tryTakeMVar lastAsyncBatch
229+ case r of
230+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
231+ | otherwise -> zipWithM_ putMVar resultMVars results
232+ Failure results exception -> do
233+ -- The exception will only be rethrown in Haskell if/when one of the
234+ -- missing results (if any) is evaluated.
235+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
236+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
237+ _ -> error "Unexpected jsaddle results"
238238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
239239 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
248240 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
249241 readBatch nBatch chan = do
250242 first <- atomically $ readTChan chan -- We want at least one command to send
@@ -273,39 +265,12 @@ runJavaScript sendBatch entryPoint = do
273265 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274266 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275267
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−
281268wrapJSVal :: 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)
269+wrapJSVal (JSValueReceived ref) = do
270+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
271+ let result = JSVal ref
272+ when (ref >= 5) $ do
273+ ctx <- JSM ask
274+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
275+ return result
311276#endif