module Data.Unsafe.Reify (
MuRef(..),
Graph(..),
reifyGraph
) where
import GHC.Exts (Int(I#))
import GHC.Prim (reallyUnsafePtrEquality#, (/=#))
import Control.Concurrent.MVar
import Control.Monad
import Data.Unique
class MuRef a where
type DeRef a :: * -> *
deRef :: a -> (DeRef a) a
mapDeRef :: (Monad m) => (a -> m Unique) -> (DeRef a) a -> m (DeRef a Unique)
data Graph e = Graph [(Unique,e Unique)] Unique
instance (Functor e,Show (e Int)) => Show (Graph e) where
show (Graph netlist start) = "let " ++ show [ (hashUnique u,fmap hashUnique e)
| (u,e) <- netlist
] ++ " in " ++ show (hashUnique start)
reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s))
reifyGraph m = do rt1 <- newMVar []
rt2 <- newMVar []
root <- findNodes rt1 rt2 m
pairs <- readMVar rt2
return (Graph pairs root)
findNodes :: (MuRef s) => MVar [(Unique,s)] -> MVar [(Unique,DeRef s Unique)] -> s -> IO Unique
findNodes rt1 rt2 j = do
tab <- takeMVar rt1
case [ m | (m,i) <- tab, j `seq` i `seq` (j `eq` i) ] of
(var:_) -> do putMVar rt1 tab
return $ var
[] -> do var <- newUnique
let e = deRef j
putMVar rt1 $ (var,j) : tab
res <- mapDeRef (findNodes rt1 rt2) e
tab' <- takeMVar rt2
putMVar rt2 $ (var,res) : tab'
return var
eq :: a -> a -> Bool
eq a b = reallyUnsafePtrEquality# a b /=# 0#