@@ -2,6 +2,8 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE LambdaCase #-}
44{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MagicHash #-}
6+{-# LANGUAGE UnboxedTuples #-}
57-----------------------------------------------------------------------------
68--
79-- Module : Language.Javascript.JSaddle.Run
@@ -39,25 +41,30 @@ import Language.Javascript.JSaddle.Types (JSM)
3941import qualified JavaScript.Web.AnimationFrame as GHCJS
4042 (waitForAnimationFrame)
4143#else
42−import Control.Exception (throwIO)
44+import Control.Exception (throwIO, evaluate)
4345import Control.Monad (void, when, zipWithM_)
4446import Control.Monad.IO.Class (MonadIO(..))
4547import Control.Monad.Trans.Reader (ask, runReaderT)
4648import Control.Monad.STM (atomically)
47−import Control.Concurrent (forkIO)
49+import Control.Concurrent (forkIO, myThreadId)
4850import Control.Concurrent.STM.TChan
4951 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
5052import Control.Concurrent.STM.TVar
5153 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5254import Control.Concurrent.MVar
53− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)
55+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)
5456
5557import System.IO.Unsafe (unsafeInterleaveIO)
56−import System.Mem.Weak (addFinalizer)
58+import System.Mem.Weak (addFinalizer, mkWeak)
5759
60+import GHC.Int (Int64(..))
61+import GHC.Base (IO(..), mkWeak#)
62+import GHC.Conc (ThreadId(..))
5863import Data.Monoid ((<>))
59−import qualified Data.Text as T (unpack)
64+import qualified Data.Text as T (unpack, pack)
6065import qualified Data.Map as M (lookup, delete, insert, empty, size)
66+import Data.Set (Set)
67+import qualified Data.Set as S (empty, member, insert, delete)
6168import Data.UUID.V4 (nextRandom)
6269import Data.Time.Clock (getCurrentTime,diffUTCTime)
6370import Data.IORef (newIORef, atomicWriteIORef, readIORef)
@@ -66,7 +73,6 @@ import Language.Javascript.JSaddle.Types
6673 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
6774 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
6875import Language.Javascript.JSaddle.Exception (JSException(..))
69−-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
7076import Control.DeepSeq (deepseq)
7177import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
7278#endif
@@ -137,7 +143,7 @@ sendLazyCommand cmd = do
137143 nextRefTVar <- nextRef <$> JSM ask
138144 n <- liftIO . atomically $ do
139145 n <- subtract 1 <$> readTVar nextRefTVar
140− writeTVar nextRefTVar n
146+ writeTVar nextRefTVar $! n
141147 return n
142148 s <- doSendAsyncCommand <$> JSM ask
143149 liftIO $ s (cmd $ JSValueForSend n)
@@ -157,6 +163,7 @@ runJavaScript sendBatch entryPoint = do
157163 commandChan <- newTChanIO
158164 callbacks <- newTVarIO M.empty
159165 nextRef' <- newTVarIO 0
166+ finalizerThreads <- newMVar S.empty
160167 loggingEnabled <- newIORef False
161168 let ctx = JSContextRef {
162169 contextId = contextId'
@@ -173,13 +180,14 @@ runJavaScript sendBatch entryPoint = do
173180 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
174181 , nextRef = nextRef'
175182 , doEnableLogging = atomicWriteIORef loggingEnabled
183+ , finalizerThreads = finalizerThreads
176184 }
177185 let processResults :: Bool -> Results -> IO ()
178186 processResults syncCallbacks = \case
179187 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
180− (Callback n br f this a) -> do
188+ (Callback n br (JSValueReceived fNumber) f this a) -> do
181189 putMVar recvMVar (n, br)
182− f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
190+ f' <- runReaderT (unJSM $ wrapJSVal f) ctx
183191 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
184192 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
185193 logInfo (("Call " <> show fNumber <> " ") <>)
@@ -208,7 +216,7 @@ runJavaScript sendBatch entryPoint = do
208216 True -> show . currentBytesUsed <$> getGCStats
209217 False -> return "??"
210218 cbCount <- M.size <$> readTVarIO callbacks
211− putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
219+ putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
212220 False -> return ()
213221 _ <- forkIO . numberForeverFromM_ 1 $ \nBatch ->
214222 readBatch nBatch commandChan >>= \case
@@ -264,12 +272,27 @@ runJavaScript sendBatch entryPoint = do
264272 loopAnimation (Left asyncCmd) (cmds, resultMVars) =
265273 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
266274
275+addThreadFinalizer :: ThreadId -> IO () -> IO ()
276+addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
277+ IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
278+
267279wrapJSVal :: JSValueReceived -> JSM JSVal
268280wrapJSVal (JSValueReceived ref) = do
269281 -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
270282 let result = JSVal ref
271− when (ref >= 5) $ do
283+ when (ref >= 5 || ref < 0) $ do
272284 ctx <- JSM ask
273− liftIO . addFinalizer result $ doSendAsyncCommand ctx $ FreeRef $ JSValueForSend ref
285+ liftIO . addFinalizer ref $ do
286+ ft <- takeMVar $ finalizerThreads ctx
287+ t@(ThreadId t#) <- myThreadId
288+ let tname = T.pack $ show t
289+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref
290+ if tname `S.member` ft
291+ then putMVar (finalizerThreads ctx) ft
292+ else do
293+ addThreadFinalizer t $ do
294+ modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())
295+ doSendAsyncCommand ctx $ FreeRefs tname
296+ putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)
274297 return result
275298#endif