compile.hs

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

-- | Atom compilation.
module Language.Atom.Compile
  ( Program (..)
  , Reference (..)
  , compile
  , compileGuided
  ) where

import Control.Monad.State hiding (join)
import Data.Char
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import System.Exit
import System.IO

import Language.Atom.Scheduling
import Language.Atom.Elaboration
import Language.Atom.Terms
import Language.Atom.Utils

-- | Given a top level name and a base sample period, compiles an Atom 'System' for code generation.
--   Generates a Graphviz *.dot and rendered *.png file illustrating the optimized rule schedule.
compile :: Name -> Double -> System () -> IO Program
compile = compileGeneric []

compileGeneric :: [[String]] -> String -> Double -> System () -> IO Program
compileGeneric priorities name period system = do
  r <- elaborate name period system
  case r of
    Nothing -> putStrLn "ERROR: Design rule checks failed." >> exitWith (ExitFailure 1)
    Just systemDB -> do
      r <- schedule name systemDB priorities
      case r of
        Nothing  -> putStrLn "ERROR: Rule scheduling failed." >> exitWith (ExitFailure 1)
        Just rtl -> return $ assemble rtl


-- | Compiles an Atom 'System' with a rule schedule guide file.
--   The guide file list rules on consecutive lines.
--   Multiple rule orderings are separated with a blank line.
--
--   > (initProg, cycleProg) <- compileGuided "design_name" samplePeriod system "guide_file"
--
--   Example guide_file:
--
--   > # A rule ordering.
--   > rule1
--   > rule2
--   >
--   > # Another rule ordering.
--   > rule1
--   > rule3
--   > rule4
--
compileGuided :: Name -> Double -> System () -> FilePath -> IO Program
compileGuided name period system guide = do
  guide <- readFile guide
  compileGeneric (guidedRules guide) name period system

guidedRules :: String -> [[String]]
guidedRules f = split l3
  where

  l1 = map (filter $ not . isSpace) $ lines f
  l2 = filter isNotComment l1
  l3 = map filterComments l2

  split :: [String] -> [[String]]
  split [] = []
  split (a:b) | null a = split $ dropWhile null b
  split l = a : split b where (a,b) = span (not . null) l

  isNotComment ('#':_) = False
  isNotComment _ = True

  filterComments [] = []
  filterComments ('#':_) = []
  filterComments (a:b) = a : filterComments b

--data Variable = Variable [String] TermConst deriving (Eq, Ord)
--instance Show Variable where show (Variable n _) = join n "."

data Reference
  = RefVar UVar
  | RefInp [String]
  | RefTmp Int
  deriving Eq

instance Show Reference where
  show (RefVar v) = show v
  show (RefInp n) = join n "."
  show (RefTmp i) = "_" ++ show i

type Routine = [(Int, [Reference], UTerm)]

data Program = Program
  { progName    :: Name
  , progNames   :: SystemContent
  , progRoutine :: Routine
  , progVars    :: [(UVar, Reference)]
  , progIns     :: [UTerm]
  , progAsserts :: [([Name], Reference)]
  , progDoc     :: String
  , progPeriod  :: Double
  }

type Assemble = State (Int, Map.Map UTerm Reference, Routine)

instr :: TermT a => Term a -> [Reference] -> Assemble Reference
instr t rs = do
  (id, m, p) <- get
  put (id + 1, Map.insert (uterm t) (RefTmp id) m, (id, rs, uterm t):p)
  return $ RefTmp id

assemble :: RTL -> Program
assemble rtl = Program
  { progName    = rtlName rtl
  , progNames   = SystemScope (rtlName rtl) $ sysContent $ rtlSystem rtl
  , progRoutine = reverse cycleProgram
  , progVars    = assigns'
  , progIns     = sysIns     $ rtlSystem rtl
  , progAsserts = asserts'
  , progDoc     = rtlDoc rtl
  , progPeriod  = sysPeriod $ rtlSystem rtl
  }
  where
  assigns = rtlAssigns rtl
  asserts = sysAsserts $  rtlSystem rtl

  ((assigns', asserts'), (_,_,cycleProgram)) = runState program (0, Map.empty, [])

  program :: Assemble ([(UVar, Reference)], [([Name], Reference)])
  program = do
    t1 <- mapM programAssignTerm assignTerms
    t2 <- mapM (programAssignTerm . UTermBool) assertTerms
    return $ (zip vars t1, zip names t2)
    where
    (vars, assignTerms)  = unzip assigns
    (names, assertTerms) = unzip asserts

  programAssignTerm :: UTerm -> Assemble Reference
  programAssignTerm ut = case ut of
    UTermBool   t -> term t
    UTermInt    t -> term t
    UTermFloat  t -> term t
    UTermDouble t -> term t

  term :: TermT a => Term a -> Assemble Reference
  term t = do
    (_, m, _) <- get
    if Map.member (uterm t) m then return (m Map.! (uterm t)) else case t of
      Ref v -> return $ RefVar (uvar v)
      Cast a -> ins1 a
      Const _ -> ins []
      Input a -> return $ RefInp a
      Add a b   -> ins2 a b
      Sub a b   -> ins2 a b
      Mul a b   -> ins2 a b
      Div a b   -> ins2 a b
      Mod a b   -> ins2 a b
      Inv a     -> ins1 a
      And a b   -> ins2 a b
      Eq  a b   -> ins2 a b
      Lt  a b   -> ins2 a b
      Mux a b c -> do
        a <- term a
        b <- term b
        c <- term c
        ins [a,b,c]
      Exp a     -> ins1 a
      Log a     -> ins1 a
      Sqrt a    -> ins1 a
      Pow a b   -> ins2 a b
      Sin a     -> ins1 a
      Cos a     -> ins1 a
      Sinh a    -> ins1 a
      Cosh a    -> ins1 a
      Asin a    -> ins1 a
      Acos a    -> ins1 a
      Atan a    -> ins1 a
      Atan2 a b -> ins2 a b
      Asinh a   -> ins1 a
      Acosh a   -> ins1 a
      Atanh a   -> ins1 a
      where
      ins = instr t
      ins1 a = term a >>= (ins. (:[]))
      ins2 a b = do
        a <- term a
        b <- term b
        ins [a,b]