@@ -49,7 +49,7 @@ import Control.Concurrent.STM.TChan
4949import Control.Concurrent.STM.TVar
5050 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5151import Control.Concurrent.MVar
52− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
52+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)
5353
5454import System.IO.Unsafe (unsafeInterleaveIO)
5555import System.Mem.Weak (addFinalizer)
@@ -67,6 +67,8 @@ import Language.Javascript.JSaddle.Exception (JSException(..))
6767-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
6868import Control.DeepSeq (deepseq)
6969import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
70+import Data.Maybe (isJust)
71+import Data.Foldable (forM_)
7072#endif
7173
7274-- | Enable (or disable) JSaddle logging
@@ -146,10 +148,12 @@ sendAsyncCommand cmd = do
146148 s <- doSendAsyncCommand <$> JSM ask
147149 liftIO $ s cmd
148150
149−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
151+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
150152runJavaScript sendBatch entryPoint = do
151153 startTime' <- getCurrentTime
152154 recvMVar <- newEmptyMVar
155+ syncSendBatch <- newEmptyMVar
156+ lastAsyncBatch <- newEmptyMVar
153157 commandChan <- newTChanIO
154158 callbacks <- newTVarIO M.empty
155159 nextRef' <- newTVarIO 0
@@ -169,17 +173,39 @@ runJavaScript sendBatch entryPoint = do
169173 , nextRef = nextRef'
170174 , doEnableLogging = atomicWriteIORef loggingEnabled
171175 }
172− let processResults = \case
176+ let processResults :: Bool -> Results -> IO ()
177+ processResults syncCallbacks = \case
173178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
174179 (Callback f this a) -> do
175− logInfo ("Call " <>)
176180 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
177181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
178182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
183+ logInfo (("Call " <> show fNumber <> " ") <>)
179184 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
180185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
181− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
186+ Just cb -> void . forkIO $ do
187+ runReaderT (unJSM $ cb f' this' args) ctx
188+ when syncCallbacks $ do
189+ doSendAsyncCommand ctx EndSyncBlock
190+ void $ doSendCommand ctx Sync
191+ Duplicate -> error "Error : Unexpected Duplicate"
182192 m -> putMVar recvMVar m
193+ asyncResults :: Results -> IO ()
194+ asyncResults = processResults False
195+ syncResults :: Results -> IO Batch
196+ syncResults results = do
197+ existing <- tryTakeMVar syncSendBatch
198+ when (isJust existing) $ error "Error : Unexpected Sync Results"
199+ tryTakeMVar lastAsyncBatch >>= \case
200+ Just lastAsync -> processResults True results >> return lastAsync
201+ Nothing -> do
202+ nextBatch <- newEmptyMVar
203+ putMVar syncSendBatch (\batch -> do
204+ existing <- tryTakeMVar nextBatch
205+ when (isJust existing) $ error "Error : Unexpected Sync Results"
206+ putMVar nextBatch batch)
207+ processResults True results
208+ takeMVar nextBatch
183209 logInfo s =
184210 readIORef loggingEnabled >>= \case
185211 True -> do
@@ -189,23 +215,30 @@ runJavaScript sendBatch entryPoint = do
189215 cbCount <- M.size <$> readTVarIO callbacks
190216 putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount
191217 False -> return ()
192− _ <- forkIO . forever $ readBatch commandChan >>= \case
193− (batch@(Batch cmds _), resultMVars) -> do
218+ _ <- forkIO . forM_ [1..] $ \nBatch ->
219+ readBatch nBatch commandChan >>= \case
220+ (batch@(Batch cmds _ _), resultMVars) -> do
194221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
195− sendBatch batch
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
200− -- The exception will only be rethrown in Haskell if/when one of the
201− -- missing results (if any) is evaluated.
202− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
203− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
204− _ -> error "Unexpected jsaddle results"
205− return (processResults, runReaderT (unJSM entryPoint) ctx)
222+ tryTakeMVar syncSendBatch >>= \case
223+ Just send -> send batch
224+ Nothing -> do
225+ putMVar lastAsyncBatch batch
226+ sendBatch batch
227+ takeMVar recvMVar >>= \r -> do
228+ _ <- tryTakeMVar lastAsyncBatch
229+ case r of
230+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
231+ | otherwise -> zipWithM_ putMVar resultMVars results
232+ Failure results exception -> do
233+ -- The exception will only be rethrown in Haskell if/when one of the
234+ -- missing results (if any) is evaluated.
235+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
236+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
237+ _ -> error "Unexpected jsaddle results"
238+ return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
206239 where
207− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
208− readBatch chan = do
240+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
241+ readBatch nBatch chan = do
209242 first <- atomically $ readTChan chan -- We want at least one command to send
210243 loop first ([], [])
211244 where
@@ -216,17 +249,17 @@ runJavaScript sendBatch entryPoint = do
216249 let cmds = Right syncCmd:cmds'
217250 resultMVars = resultMVar:resultMVars'
218251 atomically (tryReadTChan chan) >>= \case
219− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
252+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
220253 Just cmd -> loop cmd (cmds, resultMVars)
221254 loop (Left asyncCmd) (cmds', resultMVars) = do
222255 let cmds = Left asyncCmd:cmds'
223256 atomically (tryReadTChan chan) >>= \case
224− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
257+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)
225258 Just cmd -> loop cmd (cmds, resultMVars)
226259 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
227260 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
228261 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
229− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
262+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))
230263 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
231264 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
232265 loopAnimation (Left asyncCmd) (cmds, resultMVars) =