@@ -57,6 +57,7 @@ import Data.Monoid ((<>))
57import qualified Data.Text as T (unpack)
57import qualified Data.Text as T (unpack)
58import qualified Data.Map as M (lookup, delete, insert, empty, size)
58import qualified Data.Map as M (lookup, delete, insert, empty, size)
59import Data.Time.Clock (getCurrentTime,diffUTCTime)
59import Data.Time.Clock (getCurrentTime,diffUTCTime)
60+import Data.IORef (newIORef, atomicWriteIORef, readIORef)
61import Language.Javascript.JSaddle.Types
62import Language.Javascript.JSaddle.Types
62 (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
63 (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
@@ -141,6 +142,7 @@ runJavaScript sendBatch entryPoint = do
141 commandChan <- newTChanIO
142 commandChan <- newTChanIO
142 callbacks <- newTVarIO M.empty
143 callbacks <- newTVarIO M.empty
143 nextRef' <- newTVarIO 0
144 nextRef' <- newTVarIO 0
145+ loggingEnabled <- newIORef False
144 let ctx = JSContextRef {
146 let ctx = JSContextRef {
145 startTime = startTime'
147 startTime = startTime'
146 , doSendCommand = \cmd -> cmd `deepseq` do
148 , doSendCommand = \cmd -> cmd `deepseq` do
@@ -154,6 +156,7 @@ runJavaScript sendBatch entryPoint = do
154 , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
156 , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
155 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
157 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)
156 , nextRef = nextRef'
158 , nextRef = nextRef'
159+ , enableLogging = atomicWriteIORef loggingEnabled
158 let processResults = \case
161 let processResults = \case
159 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
162 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
@@ -166,12 +169,15 @@ runJavaScript sendBatch entryPoint = do
166 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
169 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
167 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
170 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
168 m -> putMVar recvMVar m
171 m -> putMVar recvMVar m
169− logInfo s = do
172+ logInfo s =
173+ readIORef loggingEnabled >>= \case
170− stats <- getGCStatsEnabled
175+ currentBytesUsedStr <- getGCStatsEnabled >>= \case
172− current <- currentBytesUsed <$> getGCStats
176+ True -> show . currentBytesUsed <$> getGCStats
177+ False -> return "??"
173− cbCount <- M.size <$> readTVarIO callbacks
178+ cbCount <- M.size <$> readTVarIO callbacks
174− putStrLn . s $ show (current, cbCount)
179+ putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
175 _ <- forkIO . forever $ readBatch commandChan >>= \case
181 _ <- forkIO . forever $ readBatch commandChan >>= \case
176 (batch@(Batch cmds _), resultMVars) -> do
182 (batch@(Batch cmds _), resultMVars) -> do
177 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
183 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))