460cf87 · jsaddle · git.iko.soy

42import Control.Monad.IO.Class (MonadIO(..))

43import Control.Monad.Trans.Reader (ask, runReaderT)

44import Control.Monad.STM (atomically)

45−import Control.Concurrent (forkIO, forkOS)

45+import Control.Concurrent (forkIO)

46import Control.Concurrent.STM.TChan

47 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)

48import Control.Concurrent.STM.TVar

55

56import Data.Monoid ((<>))

57import 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)

59import Data.Time.Clock (getCurrentTime,diffUTCTime)

60

61import Language.Javascript.JSaddle.Types

64import Language.Javascript.JSaddle.Exception (JSException(..))

65-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

66import Control.DeepSeq (deepseq)

67+import GHC.Stats (getGCStats, GCStats(..))

67#endif

68#endif

68

69

69-- | Forces execution of pending asyncronous code

70-- | Forces execution of pending asyncronous code

136runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())

137runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())

137runJavaScript sendBatch entryPoint = do

138runJavaScript sendBatch entryPoint = do

138 startTime' <- getCurrentTime

139 startTime' <- getCurrentTime

139− recvChan <- newTChanIO

140+ recvMVar <- newEmptyMVar

140 commandChan <- newTChanIO

141 commandChan <- newTChanIO

141 callbacks <- newTVarIO M.empty

142 callbacks <- newTVarIO M.empty

142 nextRef' <- newTVarIO 0

143 nextRef' <- newTVarIO 0

157 let processResults = \case

158 let processResults = \case

158 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

159 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

159 (Callback f this a) -> do

160 (Callback f this a) -> do

161+ logInfo ("Call " <>)

160 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

162 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

161 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

163 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

162 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

164 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

163 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case

165 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case

164 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

166 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

165 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx

167 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx

166− m -> atomically $ writeTChan recvChan m

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)

167− _ <- forkOS . forever $ readBatch commandChan >>= \case

173+ _ <- forkIO . forever $ readBatch commandChan >>= \case

168 (batch@(Batch cmds _), resultMVars) -> do

174 (batch@(Batch cmds _), resultMVars) -> do

169− -- putStrLn $ "sendBatch " <> show (length cmds, last cmds)

175+ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

170 sendBatch batch

176 sendBatch batch

171− atomically (readTChan recvChan) >>= \case

177+ takeMVar recvMVar >>= \case

178+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

172− Success results -> zipWithM_ putMVar resultMVars results

179+ | otherwise -> zipWithM_ putMVar resultMVars results

173 Failure results exception -> do

180 Failure results exception -> do

174 -- The exception will only be rethrown in Haskell if/when one of the

181 -- The exception will only be rethrown in Haskell if/when one of the

175 -- missing results (if any) is evaluated.

182 -- missing results (if any) is evaluated.