module Language.KansasLava.Probes (
probeS, unpackedProbe,
resetProbesForVCD, snapProbesAsVCD,
setProbesAsTrace, setShallowProbes, setProbes
) where
import Language.KansasLava.Rep
import Language.KansasLava.Signal
import qualified Language.KansasLava.Stream as S
import Language.KansasLava.VCD
import Control.Concurrent.MVar
import System.IO.Unsafe
import Data.IORef
probeS :: (Rep a) => String -> Signal c a -> Signal c a
probeS str sig = unsafePerformIO $ do
(ProbeFn fn) <- readIORef probeFn
return (fn str sig)
unpackedProbe :: forall c a p . (Rep a, Pack c a, p ~ Unpacked c a) => String -> p -> p
unpackedProbe nm a = unpack (probeS nm (pack a) :: Signal c a)
data ProbeFn = ProbeFn (forall a i . (Rep a) => String -> Signal i a -> Signal i a)
probeFn :: IORef ProbeFn
probeFn = unsafePerformIO $ newIORef $ ProbeFn $ \ _ s -> s
setProbes :: (forall a i . (Rep a) => String -> Signal i a -> Signal i a) -> IO ()
setProbes = writeIORef probeFn . ProbeFn
setShallowProbes :: (forall a . (Rep a) => String -> Integer -> X a -> X a) -> IO ()
setShallowProbes write = setProbes $ \ nm sig -> shallowMapS (probe_shallow nm) sig
where
probe_shallow :: forall a . (Rep a) => String -> S.Stream (X a) -> S.Stream (X a)
probe_shallow nm = id
. S.fromList
. map (\ (i,a) -> write nm i a)
. zip [0..]
. S.toList
setProbesAsTrace :: (String -> IO ()) -> IO ()
setProbesAsTrace write = setShallowProbes $ \ nm i a -> unsafePerformIO $ do
write $ nm ++ "(" ++ show i ++ ")" ++ showRep a ++ "\n"
return a
vcdOfProbes :: MVar VCD
vcdOfProbes = unsafePerformIO $ newEmptyMVar
resetProbesForVCD :: IO ()
resetProbesForVCD = do
_ <- tryTakeMVar vcdOfProbes
putMVar vcdOfProbes $ VCD []
setShallowProbes $ \ nm clkNo x -> unsafePerformIO $ do
vcd <- takeMVar vcdOfProbes
putMVar vcdOfProbes $ addEvent nm (fromIntegral clkNo) x vcd
return x
return ()
snapProbesAsVCD :: IO VCD
snapProbesAsVCD = readMVar vcdOfProbes