@@ -1,6 +1,9 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE CPP #-}
23{-# LANGUAGE LambdaCase #-}
34{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnboxedTuples #-}
47-----------------------------------------------------------------------------
58--
69-- Module : Language.Javascript.JSaddle.Run
@@ -34,43 +37,59 @@ module Language.Javascript.JSaddle.Run (
3437) where
3538
3639#ifdef ghcjs_HOST_OS
37−import Language.Javascript.JSaddle.Types (JSM)
40+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
3841import qualified JavaScript.Web.AnimationFrame as GHCJS
3942 (waitForAnimationFrame)
4043#else
41−import Control.Exception (throwIO)
42−import Control.Monad (void, when, forever, zipWithM_)
44+import Control.Exception (throwIO, evaluate)
45+import Control.Monad (void, when, zipWithM_)
4346import Control.Monad.IO.Class (MonadIO(..))
4447import Control.Monad.Trans.Reader (ask, runReaderT)
4548import Control.Monad.STM (atomically)
46−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
4750import Control.Concurrent.STM.TChan
4851 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
4952import Control.Concurrent.STM.TVar
5053 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5154import Control.Concurrent.MVar
52− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
5356
5457import System.IO.Unsafe (unsafeInterleaveIO)
5558import System.Mem.Weak (addFinalizer)
59+import System.Random
5660
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
5763import Data.Monoid ((<>))
58−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
5965import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import qualified Data.Set as S (empty, member, insert, delete)
6067import Data.Time.Clock (getCurrentTime,diffUTCTime)
61−import Data.IORef (newIORef, atomicWriteIORef, readIORef)
68+import Data.IORef
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
6270
6371import Language.Javascript.JSaddle.Types
64− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
65− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
72+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
6674import Language.Javascript.JSaddle.Exception (JSException(..))
67−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
68−import Control.DeepSeq (deepseq)
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
6979import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
70−import Data.Maybe (isJust)
80+#endif
7181import Data.Foldable (forM_)
7282#endif
7383
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+
7493-- | Enable (or disable) JSaddle logging
7594enableLogging :: Bool -> JSM ()
7695#ifdef ghcjs_HOST_OS
@@ -81,27 +100,6 @@ enableLogging v = do
81100 liftIO $ f v
82101#endif
83102
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−
105103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
106104-- On GHC it will delay the execution of the current batch of asynchronous
107105-- command when they are sent to JavaScript. It will not delay the Haskell
@@ -127,17 +125,12 @@ nextAnimationFrame f = do
127125 syncAfter (f t)
128126
129127#ifndef ghcjs_HOST_OS
130−sendCommand :: Command -> JSM Result
131−sendCommand cmd = do
132− s <- doSendCommand <$> JSM ask
133− liftIO $ s cmd
134−
135128sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
136129sendLazyCommand cmd = do
137130 nextRefTVar <- nextRef <$> JSM ask
138131 n <- liftIO . atomically $ do
139132 n <- subtract 1 <$> readTVar nextRefTVar
140− writeTVar nextRefTVar n
133+ writeTVar nextRefTVar $! n
141134 return n
142135 s <- doSendAsyncCommand <$> JSM ask
143136 liftIO $ s (cmd $ JSValueForSend n)
@@ -150,34 +143,45 @@ sendAsyncCommand cmd = do
150143
151144runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
152145runJavaScript sendBatch entryPoint = do
146+ contextId' <- randomIO
153147 startTime' <- getCurrentTime
154148 recvMVar <- newEmptyMVar
155− syncSendBatch <- newEmptyMVar
156149 lastAsyncBatch <- newEmptyMVar
157150 commandChan <- newTChanIO
158151 callbacks <- newTVarIO M.empty
159152 nextRef' <- newTVarIO 0
153+ finalizerThreads' <- newMVar S.empty
154+ animationFrameHandlers' <- newMVar []
160155 loggingEnabled <- newIORef False
156+ liveRefs' <- newMVar S.empty
161157 let ctx = JSContextRef {
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 ()
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 ()
177180 processResults syncCallbacks = \case
178181 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
179− (Callback f this a) -> do
180− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
182+ (Callback n br (JSValueReceived fNumber) f this a) -> do
183+ putMVar recvMVar (n, br)
184+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
181185 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
182186 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
183187 logInfo (("Call " <> show fNumber <> " ") <>)
@@ -185,58 +189,62 @@ runJavaScript sendBatch entryPoint = do
185189 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
186190 Just cb -> void . forkIO $ do
187191 runReaderT (unJSM $ cb f' this' args) ctx
188− when syncCallbacks $ do
192+ when syncCallbacks $
189193 doSendAsyncCommand ctx EndSyncBlock
190− void $ doSendCommand ctx Sync
191− Duplicate -> error "Error : Unexpected Duplicate"
192− m -> putMVar recvMVar m
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)
193199 asyncResults :: Results -> IO ()
194− asyncResults = processResults False
200+ asyncResults results =
201+ void . forkIO $ processResults False results
195202 syncResults :: Results -> IO Batch
196203 syncResults results = do
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
204+ void . forkIO $ processResults True results
205+ readMVar lastAsyncBatch
209206 logInfo s =
210207 readIORef loggingEnabled >>= \case
211208 True -> do
212− currentBytesUsedStr <- getGCStatsEnabled >>= \case
213− True -> show . currentBytesUsed <$> getGCStats
209+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210+ True -> show . currentBytesUsed <$> getRTSStats
214211 False -> return "??"
215212 cbCount <- M.size <$> readTVarIO callbacks
216− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
213+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
217214 False -> return ()
218− _ <- forkIO . forM_ [1..] $ \nBatch ->
215+ _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
219216 readBatch nBatch commandChan >>= \case
220217 (batch@(Batch cmds _ _), resultMVars) -> do
221218 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
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"
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))
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
240248 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
241249 readBatch nBatch chan = do
242250 first <- atomically $ readTChan chan -- We want at least one command to send
@@ -265,12 +273,39 @@ runJavaScript sendBatch entryPoint = do
265273 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
266274 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
267275
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+
268281wrapJSVal :: JSValueReceived -> JSM JSVal
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
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)
276311#endif