@@ -65,13 +65,14 @@ import qualified Data.Text as T (unpack, pack)
6565import qualified Data.Map as M (lookup, delete, insert, empty, size)
6666import qualified Data.Set as S (empty, member, insert, delete)
6767import Data.Time.Clock (getCurrentTime,diffUTCTime)
68−import Data.IORef (newIORef, atomicWriteIORef, readIORef)
68+import Data.IORef
69+ (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)
6970
7071import Language.Javascript.JSaddle.Types
7172 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
7273 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
7374import Language.Javascript.JSaddle.Exception (JSException(..))
74−import Control.DeepSeq (deepseq)
75+import Control.DeepSeq (force, deepseq)
7576import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
7677import Data.Foldable (forM_)
7778#endif
@@ -165,6 +166,7 @@ runJavaScript sendBatch entryPoint = do
165166 finalizerThreads' <- newMVar S.empty
166167 animationFrameHandlers' <- newMVar []
167168 loggingEnabled <- newIORef False
169+ liveRefs' <- newMVar S.empty
168170 let ctx = JSContextRef {
169171 contextId = contextId'
170172 , startTime = startTime'
@@ -173,14 +175,19 @@ runJavaScript sendBatch entryPoint = do
173175 atomically $ writeTChan commandChan (Right (cmd, result))
174176 unsafeInterleaveIO $
175177 takeMVar result >>= \case
176− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
178+ (ThrowJSValue v) -> do
179+ jsval <- wrapJSVal' ctx v
180+ throwIO $ JSException jsval
177181 r -> return r
178182 , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
179− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)
183+ , addCallback = \(Object (JSVal ioref)) cb -> do
184+ val <- readIORef ioref
185+ atomically $ modifyTVar' callbacks (M.insert val cb)
180186 , nextRef = nextRef'
181187 , doEnableLogging = atomicWriteIORef loggingEnabled
182188 , finalizerThreads = finalizerThreads'
183189 , animationFrameHandlers = animationFrameHandlers'
190+ , liveRefs = liveRefs'
184191 }
185192 processResults :: Bool -> Results -> IO ()
186193 processResults syncCallbacks = \case
@@ -282,17 +289,29 @@ addThreadFinalizer :: ThreadId -> IO () -> IO ()
282289addThreadFinalizer t@(ThreadId t#) (IO finalizer) =
283290 IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) }
284291
292+
285293wrapJSVal :: JSValueReceived -> JSM JSVal
286−wrapJSVal (JSValueReceived ref) = do
287− -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)
288− let result = JSVal ref
289− when (ref >= 5 || ref < 0) $ do
290− ctx <- JSM ask
291− liftIO . addFinalizer ref $ do
294+wrapJSVal v = do
295+ ctx <- JSM ask
296+ liftIO $ wrapJSVal' ctx v
297+
298+wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
299+wrapJSVal' ctx (JSValueReceived n) = do
300+ ref <- liftIO $ newIORef n
301+ when (n >= 5 || n < 0) $
302+#ifdef JSADDLE_CHECK_WRAPJSVAL
303+ do lr <- takeMVar $ liveRefs ctx
304+ if n `S.member` lr
305+ then do
306+ putStrLn $ "JS Value Ref " <> show n <> " already wrapped"
307+ putMVar (liveRefs ctx) lr
308+ else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)
309+#endif
310+ void . mkWeakIORef ref $ do
292311 ft <- takeMVar $ finalizerThreads ctx
293312 t <- myThreadId
294313 let tname = T.pack $ show t
295− doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref
314+ doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n
296315 if tname `S.member` ft
297316 then putMVar (finalizerThreads ctx) ft
298317 else do
@@ -300,5 +319,5 @@ wrapJSVal (JSValueReceived ref) = do
300319 modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())
301320 doSendAsyncCommand ctx $ FreeRefs tname
302321 putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)
303− return result
322+ return (JSVal ref)
304323#endif