module Language.Atom.Elaboration
(
Atom
, AtomDB (..)
, Global (..)
, Rule (..)
, buildAtom
, UID
, Name
, Path
, elaborate
, var
, var'
, array
, addName
, get
, put
, allUVs
, allUEs
) where
import Control.Monad.Trans
import Data.Function (on)
import Data.List
import Data.Maybe
import Data.Word
import Language.Atom.Expressions
import System.IO
type UID = Int
type Name = String
type Path = [Name]
data Global = Global
{ gId :: Int
, gProbes :: [(String, Type, E Word64)]
, gInit8 :: [Const]
, gInit16 :: [Const]
, gInit32 :: [Const]
, gInit64 :: [Const]
, gPeriod :: Int
}
data AtomDB = AtomDB
{ atomId :: Int
, atomName :: Name
, atomNames :: [Name]
, atomEnable :: UE
, atomSubs :: [AtomDB]
, atomPeriod :: Int
, atomAssigns :: [(UV, UE)]
, atomActions :: [([String] -> String, [UE])]
, atomAsserts :: [(Name, UE)]
, atomCovers :: [(Name, UE)]
}
data Rule = Rule
{ ruleId :: Int
, ruleName :: Name
, ruleEnable :: UE
, ruleAssigns :: [(UV, UE)]
, ruleActions :: [([String] -> String, [UE])]
, rulePeriod :: Int
, ruleAsserts :: [(Name, UE)]
, ruleCovers :: [(Name, UE)]
}
instance Show AtomDB where show = atomName
instance Eq AtomDB where (==) = (==) `on` atomId
instance Ord AtomDB where compare a b = compare (atomId a) (atomId b)
instance Show Rule where show = ruleName
instance Eq Rule where (==) = (==) `on` ruleId
instance Ord Rule where compare a b = compare (ruleId a) (ruleId b)
elaborateRules:: UE -> AtomDB -> [Rule]
elaborateRules parentEnable atom = if isRule then rule : rules else rules
where
isRule = not $ null (atomAssigns atom) && null (atomActions atom) && null (atomAsserts atom) && null (atomCovers atom)
enable = uand parentEnable $ atomEnable atom
rule = Rule
{ ruleId = atomId atom
, ruleName = atomName atom
, ruleEnable = enable
, ruleAssigns = map enableAssign $ atomAssigns atom
, ruleActions = atomActions atom
, rulePeriod = atomPeriod atom
, ruleAsserts = atomAsserts atom
, ruleCovers = atomCovers atom
}
rules = concatMap (elaborateRules enable) (atomSubs atom)
enableAssign :: (UV, UE) -> (UV, UE)
enableAssign (uv, ue) = (uv, umux enable ue $ UVRef uv)
reIdRules :: [Rule] -> [Rule]
reIdRules rules = map (\ r -> r { ruleId = fromJust $ lookup (ruleId r) ids } ) rules
where
ids = zip (map ruleId rules) [0..]
buildAtom :: Global -> Name -> Atom a -> IO (a, (Global, AtomDB))
buildAtom g name (Atom f) = f (g { gId = gId g + 1 }, AtomDB
{ atomId = gId g
, atomName = name
, atomNames = []
, atomEnable = ubool True
, atomSubs = []
, atomPeriod = gPeriod g
, atomAssigns = []
, atomActions = []
, atomAsserts = []
, atomCovers = []
})
data Atom a = Atom ((Global, AtomDB) -> IO (a, (Global, AtomDB)))
instance Monad Atom where
return a = Atom (\ s -> return (a, s))
(Atom f1) >>= f2 = Atom f3
where
f3 s = do
(a, s) <- f1 s
let Atom f4 = f2 a
f4 s
instance MonadIO Atom where
liftIO io = Atom f
where
f s = do
a <- io
return (a, s)
get :: Atom (Global, AtomDB)
get = Atom (\ s -> return (s, s))
put :: (Global, AtomDB) -> Atom ()
put s = Atom (\ _ -> return ((), s))
elaborate :: Name -> Atom () -> IO (Maybe ([Rule], ([Const], [Const], [Const], [Const]), [Name]))
elaborate name atom = do
(_, (g, atomDB)) <- buildAtom Global { gId = 0, gInit8 = [], gInit16 = [], gInit32 = [], gInit64 = [], gProbes = [], gPeriod = 1 } name atom
let rules = reIdRules $ elaborateRules (ubool True) atomDB
coverage = concatMap (fst . unzip . ruleCovers ) rules
mapM_ checkEnable rules
ok <- mapM checkAssignConflicts rules
if not $ and ok
then return Nothing
else return $ Just (rules, (gInit8 g, gInit16 g, gInit32 g, gInit64 g), coverage)
checkEnable :: Rule -> IO ()
checkEnable rule | ruleEnable rule == ubool False = putStrLn $ "WARNING: Rule will never execute: " ++ show rule
| otherwise = return ()
checkAssignConflicts :: Rule -> IO Bool
checkAssignConflicts rule =
if length vars /= length vars'
then do
putStrLn $ "ERROR: Rule " ++ show rule ++ " contains multiple assignments to the same variable(s)."
return False
else do
return True
where
vars = fst $ unzip $ ruleAssigns rule
vars' = nub vars
var :: Expr a => Name -> a -> Atom (V a)
var name init = do
A a <- array name [init]
return $ V $ UV $ Array a $ UConst $ CWord8 0
var' :: Name -> Type -> Atom (V a)
var' name t = return $ V $ UV $ External name t
array :: Expr a => Name -> [a] -> Atom (A a)
array name [] = error $ "ERROR: arrays can not be empty: " ++ name
array name init = do
name <- addName name
(g, atom) <- get
let constants = map constant init
(addr, g') = case width $ head constants of
1 -> (length $ gInit8 g, g { gInit8 = gInit8 g ++ constants })
8 -> (length $ gInit8 g, g { gInit8 = gInit8 g ++ constants })
16 -> (length $ gInit16 g, g { gInit16 = gInit16 g ++ constants })
32 -> (length $ gInit32 g, g { gInit32 = gInit32 g ++ constants })
64 -> (length $ gInit64 g, g { gInit64 = gInit64 g ++ constants })
_ -> error "Elaboration.array: unknown width"
ua = UA addr name constants
put (g', atom)
return $ A ua
addName :: Name -> Atom Name
addName name = do
(g, atom) <- get
if elem name (atomNames atom)
then error $ "ERROR: Name \"" ++ name ++ "\" not unique in " ++ show atom ++ "."
else do
put (g, atom { atomNames = name : atomNames atom })
return $ atomName atom ++ "." ++ name
allUVs :: [Rule] -> UE -> [UV]
allUVs rules ue = fixedpoint next $ nearestUVs ue
where
assigns = concatMap ruleAssigns rules
previousUVs :: UV -> [UV]
previousUVs uv = concat [ nearestUVs ue | (uv', ue) <- assigns, uv == uv' ]
next :: [UV] -> [UV]
next uvs = sort $ nub $ uvs ++ concatMap previousUVs uvs
fixedpoint :: Eq a => (a -> a) -> a -> a
fixedpoint f a | a == f a = a
| otherwise = fixedpoint f $ f a
allUEs :: Rule -> [UE]
allUEs rule = ruleEnable rule : concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ] ++ concat (snd (unzip (ruleActions rule))) ++ snd (unzip (ruleAsserts rule)) ++ snd (unzip (ruleCovers rule))
where
index :: UV -> [UE]
index (UV (Array _ ue)) = [ue]
index _ = []