elaboration.hs

Cores are generated from Confluence a modern logic design language. Confluence is a simple, yet high

module Language.Atom.Elaboration
  (
  -- * System and Action Containers
    System
  , SystemDB   (..)
  , SystemContent (..)
  , Action
  , ActionDB   (..)
  , Relation   (..)
  -- ** Container Utilities
  , buildAction
  -- * Type Aliases and Utilities
  , Rule       (..)
  --, Output     (..)
  --, SimDirective (..)
  , RTL (..)
  , UID
  , Name
  , elaborate
  ) where

import Control.Monad.State hiding (join)
import qualified Data.List as List
import System.IO

import Language.Atom.Terms
import Language.Atom.Utils

-- | Unique identifier.
type UID = Int

-- | A name or label.
type Name = String

data RTL = RTL
  { rtlName    :: Name
  , rtlSystem  :: SystemDB
  , rtlDoc     :: String
  , rtlAssigns :: [(UVar, UTerm)]
  }

-- | Top level output.
--data Output = Output UID Name Signal


-- | The 'Rule' type represents a rule of an atomic state transition.
data Rule = Rule 
  { ruleUID     :: UID
  , ruleName    :: [Name]
  , ruleEnable  :: Term Bool
  , ruleAssigns :: [(UVar, UTerm)]
  , ruleActiveWhenEnabled :: Bool
  , ruleRelations         :: [Relation]
  }

instance Show Rule where show r = join (ruleName r) "."
instance Eq  Rule where (==) a b = ruleUID a == ruleUID b
instance Ord Rule where compare a b = compare (ruleUID a) (ruleUID b)

data SystemDB = SystemDB
  { sysNextId  :: Int
  , sysPath    :: [Name]
  , sysEnable  :: Term Bool
  , sysContent :: [SystemContent]
  , sysRules   :: [Rule]
  , sysVars    :: [UVar]
  , sysIns     :: [UTerm]
  , sysAsserts :: [([Name], Term Bool)]
  , sysPeriod  :: Double
  }

data SystemContent
  = SystemVar    Name UVar
  | SystemInput  Name UTerm
  | SystemAssert Name ([Name], Term Bool)
  | SystemScope  Name [SystemContent]

buildSystem :: Name -> Double -> System () -> IO SystemDB
buildSystem name period system = execStateT system emptySystemDB
  where
  emptySystemDB :: SystemDB
  emptySystemDB = SystemDB
    { sysNextId  = 0
    , sysPath    = [name]
    , sysEnable  = true
    , sysContent = []
    , sysRules   = []
    , sysVars    = []
    , sysIns     = []
    , sysAsserts = []
    , sysPeriod  = period
    }

data ActionDB = ActionDB
  { actEnable            :: Term Bool
  , actAssigns           :: [(UVar, UTerm)]
  , actActiveWhenEnabled :: Bool
  , actRelations         :: [Relation]
  }

buildAction :: Action () -> System ActionDB
buildAction action = execStateT action ActionDB
    { actEnable = true
    , actAssigns = []
    , actActiveWhenEnabled = False
    , actRelations = []
    }

-- | The 'Action' container holds enabling conditions, conditional actions, register assignments, and simulation directives.
type Action = StateT ActionDB System

-- | The 'System' container holds top level IO, 'Var', and 'Rule' definitions.
type System = StateT SystemDB IO

-- | A Relation is used for relative performance constraints between 'Action's.
data Relation = Higher UID | Lower UID deriving Eq

-- | Given a top level name and a base sample period, elabortes a 'System', returning a 'SystemDB'.
elaborate :: Name -> Double -> System () -> IO (Maybe SystemDB)
elaborate name period system = do
  putStrLn "Starting system elaboration..."
  hFlush stdout
  systemDB <- buildSystem name period system
  let rules = sysRules systemDB
  ruleChecks <- mapM isRuleOk rules
  if not (and ruleChecks) then return Nothing else return $ Just systemDB

isRuleOk :: Rule -> IO Bool
isRuleOk r = checkAssignConflicts
  where
  assigns = ruleAssigns r
  --condition = ruleEnable r
  --displays = actDisplays $ ruleAction r
  --displaySignals = concatMap (\ (_,s,_) -> s) displays
  (vars, _) = unzip assigns
  vars' = List.nub vars
  --dup = foldl (flip List.delete) vars vars'

  checkAssignConflicts :: IO Bool
  checkAssignConflicts = do
    if length vars /= length vars'
      then do
        putStrLn $ "ERROR: Rule " ++ show r ++ " contains multiple assignments to the same variable(s)." -- ++ concatMap (\ (Var n _) -> "  " ++ n) (List.nub dup)
        return False
      else return True