@@ -42,7 +42,7 @@ import Control.Monad (void, when, forever, zipWithM_)
4242import Control.Monad.IO.Class (MonadIO(..))
4343import Control.Monad.Trans.Reader (ask, runReaderT)
4444import Control.Monad.STM (atomically)
45−import Control.Concurrent (forkIO, forkOS)
45+import Control.Concurrent (forkIO)
4646import Control.Concurrent.STM.TChan
4747 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
4848import Control.Concurrent.STM.TVar
@@ -55,7 +55,7 @@ import System.Mem.Weak (addFinalizer)
5555
5656import Data.Monoid ((<>))
5757import qualified Data.Text as T (unpack)
58−import qualified Data.Map as M (lookup, delete, insert, empty)
58+import qualified Data.Map as M (lookup, delete, insert, empty, size)
5959import Data.Time.Clock (getCurrentTime,diffUTCTime)
6060
6161import Language.Javascript.JSaddle.Types
@@ -64,6 +64,7 @@ import Language.Javascript.JSaddle.Types
6464import Language.Javascript.JSaddle.Exception (JSException(..))
6565-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
6666import Control.DeepSeq (deepseq)
67+import GHC.Stats (getGCStats, GCStats(..))
6768#endif
6869
6970-- | Forces execution of pending asyncronous code
@@ -136,7 +137,7 @@ sendAsyncCommand cmd = do
136137runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
137138runJavaScript sendBatch entryPoint = do
138139 startTime' <- getCurrentTime
139− recvChan <- newTChanIO
140+ recvMVar <- newEmptyMVar
140141 commandChan <- newTChanIO
141142 callbacks <- newTVarIO M.empty
142143 nextRef' <- newTVarIO 0
@@ -157,19 +158,25 @@ runJavaScript sendBatch entryPoint = do
157158 let processResults = \case
158159 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
159160 (Callback f this a) -> do
161+ logInfo ("Call " <>)
160162 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
161163 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
162164 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
163165 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
164166 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
165167 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
166− m -> atomically $ writeTChan recvChan m
167− _ <- forkOS . forever $ readBatch commandChan >>= \case
168+ m -> putMVar recvMVar m
169+ logInfo s = do
170+ current <- currentBytesUsed <$> getGCStats
171+ cbCount <- M.size <$> readTVarIO callbacks
172+ putStrLn . s $ show (current, cbCount)
173+ _ <- forkIO . forever $ readBatch commandChan >>= \case
168174 (batch@(Batch cmds _), resultMVars) -> do
169− -- putStrLn $ "sendBatch " <> show (length cmds, last cmds)
175+ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
170176 sendBatch batch
171− atomically (readTChan recvChan) >>= \case
172− Success results -> zipWithM_ putMVar resultMVars results
177+ takeMVar recvMVar >>= \case
178+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
179+ | otherwise -> zipWithM_ putMVar resultMVars results
173180 Failure results exception -> do
174181 -- The exception will only be rethrown in Haskell if/when one of the
175182 -- missing results (if any) is evaluated.