module AERN2.QA.Strategy.CachedUnsafe
(
qaUnsafeCachingMV
)
where
#ifdef DEBUG
import Debug.Trace (trace)
#define maybeTrace trace
#define maybeTraceIO putStrLn
#else
#define maybeTrace (\ (_ :: String) t -> t)
#define maybeTraceIO (\ (_ :: String)-> return ())
#endif
import MixedTypesNumPrelude
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent.MVar
import AERN2.QA.Protocol
instance QAArrow (->) where
type QAId (->) = ()
qaRegister _ = id
newQA name sources p sampleQ makeQ =
addUnsafeMemoisation $
defaultNewQA name sources p sampleQ makeQ
qaMakeQueryGetPromiseA src (qa,q) = qaMakeQueryGetPromise qa (qaId qa, src) q
qaFulfilPromiseA promise = promise ()
qaUnsafeCachingMV :: MVar Bool
qaUnsafeCachingMV = unsafePerformIO (newMVar True)
addUnsafeMemoisation :: (QAProtocolCacheable p) => QA (->) p -> QA (->) p
addUnsafeMemoisation qa = qa { qaMakeQueryGetPromise = \ _src -> unsafeMemo }
where
unsafeMemo = (unsafePerformIO .) . unsafePerformIO memoIO
p = qaProtocol qa
memoIO =
do
cacheVar <- newMVar $ newQACache p
return $ useMVar cacheVar
where
useMVar cacheVar q () =
do
shouldCache <- readMVar qaUnsafeCachingMV
if not shouldCache then return $ qaMakeQueryGetPromise qa (Nothing, Nothing) q ()
else
do
cache <- readMVar cacheVar
case lookupQACache p cache q of
(Just a, _logMsg) ->
do
return a
_ ->
do
let a = qaMakeQueryGetPromise qa (Nothing, Nothing) q ()
modifyMVar_ cacheVar (const (return (updateQACache p q a cache)))
cache' <- readMVar cacheVar
case lookupQACache p cache' q of
(Just a', _) -> return a'
_ -> return a