@@ -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,58 +34,40 @@ 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+ (MVar, 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(..))
8070#endif
81−import Data.Foldable (forM_)
82−#endif
83−
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
9271
9372-- | Enable (or disable) JSaddle logging
9473enableLogging :: Bool -> JSM ()
@@ -100,6 +79,27 @@ enableLogging v = do
10079 liftIO $ f v
10180#endif
10281
82+-- | Forces execution of pending asyncronous code
83+syncPoint :: JSM ()
84+#ifdef ghcjs_HOST_OS
85+syncPoint = return ()
86+#else
87+syncPoint = do
88+ SyncResult <- sendCommand Sync
89+ return ()
90+#endif
91+
92+-- | Forces execution of pending asyncronous code after performing `f`
93+syncAfter :: JSM a -> JSM a
94+#ifdef ghcjs_HOST_OS
95+syncAfter = id
96+#else
97+syncAfter f = do
98+ result <- f
99+ syncPoint
100+ return result
101+#endif
102+
103103-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
104104-- On GHC it will delay the execution of the current batch of asynchronous
105105-- command when they are sent to JavaScript. It will not delay the Haskell
@@ -125,12 +125,17 @@ nextAnimationFrame f = do
125125 syncAfter (f t)
126126
127127#ifndef ghcjs_HOST_OS
128+sendCommand :: Command -> JSM Result
129+sendCommand cmd = do
130+ s <- doSendCommand <$> JSM ask
131+ liftIO $ s cmd
132+
128133sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
129134sendLazyCommand cmd = do
130135 nextRefTVar <- nextRef <$> JSM ask
131136 n <- liftIO . atomically $ do
132137 n <- subtract 1 <$> readTVar nextRefTVar
133− writeTVar nextRefTVar $! n
138+ writeTVar nextRefTVar n
134139 return n
135140 s <- doSendAsyncCommand <$> JSM ask
136141 liftIO $ s (cmd $ JSValueForSend n)
@@ -141,112 +146,66 @@ sendAsyncCommand cmd = do
141146 s <- doSendAsyncCommand <$> JSM ask
142147 liftIO $ s cmd
143148
144−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
149+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
145150runJavaScript sendBatch entryPoint = do
146− contextId' <- randomIO
147151 startTime' <- getCurrentTime
148152 recvMVar <- newEmptyMVar
149− lastAsyncBatch <- newEmptyMVar
150153 commandChan <- newTChanIO
151154 callbacks <- newTVarIO M.empty
152155 nextRef' <- newTVarIO 0
153− finalizerThreads' <- newMVar S.empty
154− animationFrameHandlers' <- newMVar []
155156 loggingEnabled <- newIORef False
156− liveRefs' <- newMVar S.empty
157157 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
158+ startTime = startTime'
159+ , doSendCommand = \cmd -> cmd `deepseq` do
160+ result <- newEmptyMVar
161+ atomically $ writeTChan commandChan (Right (cmd, result))
162+ unsafeInterleaveIO $
163+ takeMVar result >>= \case
164+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
165+ r -> return r
166+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
167+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
168+ , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
169+ , nextRef = nextRef'
170+ , doEnableLogging = atomicWriteIORef loggingEnabled
171+ }
172+ let processResults = \case
181173 (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
174+ (Callback f this a) -> do
175+ logInfo ("Call " <>)
176+ f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
185177 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
186178 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
187− logInfo (("Call " <> show fNumber <> " ") <>)
188179 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
189180 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
181+ Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
182+ m -> putMVar recvMVar m
206183 logInfo s =
207184 readIORef loggingEnabled >>= \case
208185 True -> do
209− currentBytesUsedStr <- getRTSStatsEnabled >>= \case
210− True -> show . currentBytesUsed <$> getRTSStats
186+ currentBytesUsedStr <- getGCStatsEnabled >>= \case
187+ True -> show . currentBytesUsed <$> getGCStats
211188 False -> return "??"
212189 cbCount <- M.size <$> readTVarIO callbacks
213− putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
190+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
214191 False -> return ()
215− _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
216− readBatch nBatch commandChan >>= \case
217− (batch@(Batch cmds _ _), resultMVars) -> do
192+ _ <- forkIO . forever $ readBatch commandChan >>= \case
193+ (batch@(Batch cmds _), resultMVars) -> do
218194 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
219− _ <- tryTakeMVar lastAsyncBatch
220− putMVar lastAsyncBatch batch
221195 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
196+ takeMVar recvMVar >>= \case
197+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
198+ | otherwise -> zipWithM_ putMVar resultMVars results
199+ Failure results exception -> do
231200 -- The exception will only be rethrown in Haskell if/when one of the
232201 -- missing results (if any) is evaluated.
233202 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
234− putStrLn err
235203 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)
204+ _ -> error "Unexpected jsaddle results"
205+ return (processResults, runReaderT (unJSM entryPoint) ctx)
239206 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
207+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
208+ readBatch chan = do
250209 first <- atomically $ readTChan chan -- We want at least one command to send
251210 loop first ([], [])
252211 where
@@ -257,55 +216,28 @@ runJavaScript sendBatch entryPoint = do
257216 let cmds = Right syncCmd:cmds'
258217 resultMVars = resultMVar:resultMVars'
259218 atomically (tryReadTChan chan) >>= \case
260− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
219+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
261220 Just cmd -> loop cmd (cmds, resultMVars)
262221 loop (Left asyncCmd) (cmds', resultMVars) = do
263222 let cmds = Left asyncCmd:cmds'
264223 atomically (tryReadTChan chan) >>= \case
265− Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
224+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
266225 Just cmd -> loop cmd (cmds, resultMVars)
267226 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
268227 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
269228 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
270− return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
229+ return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
271230 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
272231 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
273232 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
274233 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
275234
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−
281235wrapJSVal :: 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)
236+wrapJSVal (JSValueReceived ref) = do
237+ -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
238+ let result = JSVal ref
239+ when (ref >= 5) $ do
240+ ctx <- JSM ask
241+ liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
242+ return result
311243#endif