atom 0.0.5 → 0.1.0

raw patch · 10 files changed

+248/−67 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Language/Atom/Code.hs +47/−35
• Language/Atom/Compile.hs +6/−9
• Language/Atom/Elaboration.hs +74/−14
• Language/Atom/Example.hs +4/−1
• Language/Atom/Expressions.hs +25/−0
• Language/Atom/Language.hs +19/−0
• Language/Atom/Partition.hs +60/−0
• Language/Atom/Scheduling.hs +2/−7
• RELEASE-NOTES +9/−0
• atom.cabal +2/−1

@@ -21,19 +21,29 @@ -- | C code configuration parameters. data Config = Config   {-    cFuncName :: String          -- ^ Alternative primary function name.  Leave empty to use compile name.-  , cType     :: Type -> String  -- ^ C type naming rules.-  , cPreCode  :: String          -- ^ C code to insert above (includes, macros, etc.).-  , cPostCode :: String          -- ^ C code to insert below (main, etc.).+    cFuncName     :: String          -- ^ Alternative primary function name.  Leave empty to use compile name.+  , cType         :: Type -> String  -- ^ C type naming rules.+  , cPreCode      :: String          -- ^ C code to insert above (includes, macros, etc.).+  , cPostCode     :: String          -- ^ C code to insert below (main, etc.).+  , cRuleCoverage :: Bool            -- ^ Enable rule coverage tracking.+  , cAssert       :: Bool            -- ^ Enable assertion checking.+  , cAssertName   :: String          -- ^ Name of assertion function.  Type: void assert(char*, cType Bool);+  , cCover        :: Bool            -- ^ Enable functional coverage accumulation.+  , cCoverName    :: String          -- ^ Name of coverage function.  Type: void cover(char*, cType Bool);   }  -- | Default C code configuration parameters (default function name, no pre/post code, ANSI C types). defaults :: Config defaults = Config-  { cFuncName = ""-  , cType     = cTypes-  , cPreCode  = ""-  , cPostCode = ""+  { cFuncName     = ""+  , cType         = cTypes+  , cPreCode      = ""+  , cPostCode     = ""+  , cRuleCoverage = True+  , cAssert       = True+  , cAssertName   = "assert"+  , cCover        = True+  , cCoverName    = "cover"   }  showConst :: Const -> String@@ -41,12 +51,12 @@   CBool   c -> if c then "1" else "0"   CInt8   c -> show c   CInt16  c -> show c-  CInt32  c -> show c-  CInt64  c -> show c+  CInt32  c -> show c ++ "L"+  CInt64  c -> show c ++ "LL"   CWord8  c -> show c   CWord16 c -> show c-  CWord32 c -> show c-  CWord64 c -> show c+  CWord32 c -> show c ++ "UL"+  CWord64 c -> show c ++ "ULL"   CFloat  c -> show c   CDouble c -> show c @@ -55,13 +65,13 @@ cTypes t = case t of   Bool   -> "unsigned char"   Int8   -> "signed char"-  Int16  -> "signed short int"-  Int32  -> "signed long int"-  Int64  -> "signed long long int"+  Int16  -> "signed short"+  Int32  -> "signed long"+  Int64  -> "signed long long"   Word8  -> "unsigned char"-  Word16 -> "unsigned short int"-  Word32 -> "unsigned long int"-  Word64 -> "unsigned long long int"+  Word16 -> "unsigned short"+  Word32 -> "unsigned long"+  Word64 -> "unsigned long long"   Float  -> "float"   Double -> "double" @@ -116,18 +126,16 @@  writeC :: Name -> Config -> [[[Rule]]] -> ([Const], [Const], [Const], [Const]) -> IO () writeC name config periods (init8, init16, init32, init64) = do-  putStrLn $ "Writing C code (" ++ name ++ ".c)..."   writeFile (name ++ ".c") c-  putStrLn $ "Writing coverage data description (" ++ name' ++ "CoverageData.hs)..."   writeFile (name' ++ "CoverageData.hs") cov   where   name' = toUpper (head name) : tail name   c = unlines     [ cPreCode config     , "static " ++ cType config Word64 ++ " __clock = 0;"-    , "static const " ++ cType config Word32 ++ " __coverage_len = " ++ show covLen ++ ";"-    , "static " ++ cType config Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ (concat $ intersperse ", " $ replicate covLen "0") ++ "};"-    , "static " ++ cType config Word32 ++ " __coverage_index = 0;"+    , ruleCoverage config $ "static const " ++ cType config Word32 ++ " __coverage_len = " ++ show covLen ++ ";"+    , ruleCoverage config $ "static " ++ cType config Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ (concat $ intersperse ", " $ replicate covLen "0") ++ "};"+    , ruleCoverage config $ "static " ++ cType config Word32 ++ " __coverage_index = 0;"     , mi Word8 init8 ++ mi Word16 init16 ++ mi Word32 init32 ++ mi Word64 init64     , concatMap (codeRule config topo') $ concat $ concat periods     , "void " ++ (if null (cFuncName config) then name else cFuncName config) ++ "(void) {"@@ -152,6 +160,15 @@   topo' = topo 0   covLen = 1 + div (maximum $ map ruleId rules) 32 +ruleCoverage :: Config -> String -> String+ruleCoverage config s = if cRuleCoverage config then s else ""++coverage :: Config -> String -> String+coverage config s = if cCover config then s else ""++assertion :: Config -> String -> String+assertion config s = if cAssert config then s else ""+ memoryInit :: Config -> Type -> [Const] -> String memoryInit _ _ [] = "" memoryInit config t init = "static " ++ cType config t ++ " " ++ memory t ++ "[" ++ show (length init) ++ "] = {" ++ drop 2 (concat [", " ++ format a | a <- init ]) ++ "};\n"@@ -162,12 +179,12 @@     CBool False -> "0"     CInt8   a   -> show a     CInt16  a   -> show a-    CInt32  a   -> show a-    CInt64  a   -> show a+    CInt32  a   -> show a ++ "L"+    CInt64  a   -> show a ++ "LL"     CWord8  a   -> show a     CWord16 a   -> show a-    CWord32 a   -> show a-    CWord64 a   -> show a+    CWord32 a   -> show a ++ "UL"+    CWord64 a   -> show a ++ "ULL"     CFloat  a   -> show $ floatBits  a     CDouble a   -> show $ doubleBits a @@ -187,7 +204,9 @@   concatMap (codeUE    config ues "  ") ues ++   "  if (" ++ id (ruleEnable rule) ++ ") {\n" ++   concatMap codeAction (ruleActions rule) ++-  "    __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord ++ "] | (1 << " ++ covBit ++ ");\n" +++  ruleCoverage config ("    __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord ++ "] | (1 << " ++ covBit ++ ");\n") +++  concat [ assertion config ("    " ++ cAssertName config ++ "(" ++ show name ++ ", " ++ id check ++ ");\n") | (name, check) <- ruleAsserts rule ] +++  concat [ coverage  config ("    " ++ cCoverName  config ++ "(" ++ show name ++ ", " ++ id check ++ ");\n") | (name, check) <- ruleCovers  rule ] ++   "  }\n" ++   concatMap codeAssign (ruleAssigns rule) ++   "}\n\n"@@ -221,13 +240,6 @@  e :: Int -> String e i = "__" ++ show i--allUEs :: Rule -> [UE]-allUEs rule = ruleEnable rule : concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ] ++ concat (snd (unzip (ruleActions rule)))-  where-  index :: UV -> [UE]-  index (UV (Array _ ue)) = [ue]-  index _ = []  -- | Topologically sorts a list of expressions and subexpressions. topo :: Int -> [UE] -> [(UE, String)]

@@ -14,16 +14,13 @@ import Language.Atom.Language hiding (Atom)  -- | Compiles an atom description to C.-compile :: Name -> Config -> Atom () -> IO ()+compile :: Name -> Config -> Atom () -> IO [Name] compile name config atom = do   r <- elaborate name atom   case r of     Nothing -> putStrLn "ERROR: Design rule checks failed." >> exitWith (ExitFailure 1)-    Just (rules, init) -> do-      r <- schedule name rules-      case r of-        Nothing -> putStrLn "ERROR: Rule scheduling failed." >> exitWith (ExitFailure 1)-        Just schedule -> do-          putStrLn "Starting code generation..."-          hFlush stdout-          writeC name config schedule init+    Just (rules, init, coverage) -> do+      schedule <- schedule name rules+      writeC name config schedule init+      return coverage+

@@ -17,6 +17,8 @@   , addName   , get   , put+  , allUVs+  , allUEs   ) where  import Control.Monad.Trans@@ -54,6 +56,8 @@   , atomPeriod      :: Int   , atomAssigns     :: [(UV, UE)]   , atomActions     :: [([String] -> String, [UE])]+  , atomAsserts     :: [(Name, UE)]+  , atomCovers      :: [(Name, UE)]   }  data Rule = Rule@@ -63,6 +67,8 @@   , ruleAssigns   :: [(UV, UE)]   , ruleActions   :: [([String] -> String, [UE])]   , rulePeriod    :: Int+  , ruleAsserts   :: [(Name, UE)]+  , ruleCovers    :: [(Name, UE)]   }  instance Show AtomDB where show = atomName@@ -75,7 +81,7 @@ elaborateRules:: UE -> AtomDB -> [Rule] elaborateRules parentEnable atom = if isRule then rule : rules else rules   where-  isRule = not (null $ atomAssigns atom) || not (null $ atomActions atom)+  isRule = not $ null (atomAssigns atom) && null (atomActions atom) && null (atomAsserts atom) && null (atomCovers atom)   enable = uand parentEnable $ atomEnable atom   rule = Rule     { ruleId        = atomId   atom@@ -83,7 +89,9 @@     , ruleEnable    = enable     , ruleAssigns   = map enableAssign $ atomAssigns atom     , ruleActions   = atomActions atom-    , rulePeriod    = atomPeriod atom+    , rulePeriod    = atomPeriod  atom+    , ruleAsserts   = atomAsserts atom+    , ruleCovers    = atomCovers  atom     }   rules = concatMap (elaborateRules enable) (atomSubs atom)   enableAssign :: (UV, UE) -> (UV, UE)@@ -104,6 +112,8 @@   , atomPeriod    = gPeriod g   , atomAssigns   = []   , atomActions   = []+  , atomAsserts   = []+  , atomCovers    = []   })  -- | The Atom monad holds variable and rule declarations.@@ -135,35 +145,62 @@ -- data Relation = Higher UID | Lower UID deriving (Show, Eq)  -- | Given a top level name and design, elaborates design and returns a design database.-elaborate :: Name -> Atom () -> IO (Maybe ([Rule], ([Const], [Const], [Const], [Const])))+elaborate :: Name -> Atom () -> IO (Maybe ([Rule], ([Const], [Const], [Const], [Const]), [Name])) elaborate name atom = do-  putStrLn "Starting atom elaboration..."-  hFlush stdout   (_, (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 <- checkAssignConflicts atomDB-  if not ok+  ok <- mapM checkAssignConflicts rules+  if not $ and ok     then return Nothing-    else return $ Just (rules, (gInit8 g, gInit16 g, gInit32 g, gInit64 g))+    else return $ Just (rules, (gInit8 g, gInit16 g, gInit32 g, gInit64 g), coverage) ++++-- | Checks that a rule will not be trivially disabled. checkEnable :: Rule -> IO () checkEnable rule | ruleEnable rule == ubool False = putStrLn $ "WARNING: Rule will never execute: " ++ show rule                  | otherwise                      = return () -checkAssignConflicts :: AtomDB -> IO Bool-checkAssignConflicts atom =+-- | Check that a variable is assigned more than once in a rule.  Will eventually be replaced consistent assignment checking.+checkAssignConflicts :: Rule -> IO Bool+checkAssignConflicts rule =   if length vars /= length vars'     then do-      putStrLn $ "ERROR: Atom " ++ show atom ++ " contains multiple assignments to the same variable(s)."+      putStrLn $ "ERROR: Rule " ++ show rule ++ " contains multiple assignments to the same variable(s)."       return False     else do-      subs <- mapM checkAssignConflicts $ atomSubs atom-      return $ and subs+      return True   where-  vars = fst $ unzip $ atomAssigns atom+  vars = fst $ unzip $ ruleAssigns rule   vars' = nub vars +{-+-- | Checks that all array indices are not a function of array variables.+checkArrayIndices :: [Rule] -> Rule -> IO Bool+checkArrayIndices rules rule =+  where+  ues = allUEs rule+  arrayIndices' = concatMap arrayIndices ues+  [ (name, ) | (UA _ name _, index) <- concatMap arrayIndices ues, UV (Array (UA _ name' init)) <- allUVs rules index, length init /= 1 ]++data UA = UA Int String [Const] deriving (Show, Eq, Ord)+data UV = UV UVLocality deriving (Show, Eq, Ord)+data UVLocality = Array UA UE | External String Type deriving (Show, Eq, Ord)++  allUVs :: [Rule] -> UE -> [UV]+  arrayIndices :: UE -> [(UA, UE)]+++  , ruleEnable    :: UE+  , ruleAssigns   :: [(UV, UE)]+  , ruleActions   :: [([String] -> String, [UE])]+-}+++ -- | Generic local variable declaration. var :: Expr a => Name -> a -> Atom (V a) var name init = do@@ -228,3 +265,26 @@     where     ues = ruleEnable r : snd (unzip (ruleAssigns r)) ++ concat (snd (unzip (ruleActions r))) -}++-- | All the variables that directly and indirectly control the value of an expression.+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++-- | All primary expressions used in a rule.+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 _ = []+

@@ -8,7 +8,9 @@  -- | Invoke the atom compiler. compileExample :: IO ()-compileExample = compile "example" defaults { cPreCode = preCode, cPostCode = postCode } example+compileExample = do+  compile "example" defaults { cPreCode = preCode, cPostCode = postCode } example+  return ()  preCode :: String preCode = unlines@@ -63,3 +65,4 @@   atom "stop" $ do     cond $ value a ==. value b     running <== false+

@@ -19,6 +19,8 @@   , ue   , uv   , ueUpstream+  , nearestUVs+  , arrayIndices   , NumE   , IntegralE   , FloatingE@@ -37,6 +39,7 @@   , or_   , any_   , all_+  , imply   -- * Equality and Comparison   , (==.)   , (/=.)@@ -247,6 +250,7 @@ instance Expr a => Width (E a) where width = width . typeOf instance Expr a => Width (V a) where width = width . typeOf instance Width UE              where width = width . typeOf+instance Width UV              where width = width . typeOf  class TypeOf a where typeOf :: a -> Type @@ -535,6 +539,10 @@ any_ :: (a -> E Bool) -> [a] -> E Bool any_ f a = or_ $ map f a +-- Logical implication (if a then b).+imply :: E Bool -> E Bool -> E Bool +imply a b = not_ a ||. b+ -- | Equal. (==.) :: (EqE a, OrdE a) => E a -> E a -> E Bool (==.) = Eq@@ -638,6 +646,23 @@   UB2F a      -> [a]   UB2D a      -> [a] +-- | The list of all UVs that directly control the value of an expression.+nearestUVs :: UE -> [UV]+nearestUVs = nub . f+  where+  f :: UE -> [UV]+  f (UVRef uv) = [uv]+  f ue = concatMap f $ ueUpstream ue++-- | All array indexing subexpressions.+arrayIndices :: UE -> [(UA, UE)]+arrayIndices = nub . f+  where+  f :: UE -> [(UA, UE)]+  f (UVRef (UV (Array ua ue))) = (ua, ue) : f ue+  f ue = concatMap f $ ueUpstream ue++-- | Converts an typed expression (E a) to an untyped expression (UE). ue :: Expr a => E a -> UE ue t = case t of   VRef (V v) -> UVRef v

@@ -44,6 +44,9 @@   -- * Probing   , probe   , probes+  -- * Assertions and Functional Coverage+  , assert+  , cover   -- * Utilities   , Name   , liftIO@@ -257,3 +260,19 @@ nextCoverage = do   action (const "__coverage_index = (__coverage_index + 1) % __coverage_len") []   return (value $ V $ UV $ External "__coverage_index" Word32, value $ V $ UV $ External "__coverage[__coverage_index]" Word32)+++-- | Assertion that checks an E Bool.  Assertions are only check if containing rule is enabled and executed.+assert :: Name -> E Bool -> Atom ()+assert name check = do+  name <- addName name+  (g, atom) <- get+  put (g, atom { atomAsserts = (name, ue check) : atomAsserts atom })++-- | Addes a functional coverage point.+cover :: Name -> E Bool -> Atom ()+cover name check = do+  name <- addName name+  (g, atom) <- get+  put (g, atom { atomCovers = (name, ue check) : atomCovers atom })+

@@ -0,0 +1,60 @@+module Language.Atom.Partition+  ( partitionRules+  ) where++import Data.List++import Language.Atom.Code+import Language.Atom.Elaboration+import Language.Atom.Expressions++class Weight a where weight :: a -> Int+instance Weight a => Weight [a] where weight = sum . map weight+data Graph a b where Graph :: (Eq a, Eq b, Weight a, Weight b) => [a] -> [(a, b, a)] -> Graph a b+instance (Show a, Show b) => Show (Graph a b) where show (Graph nodes edges) = "Graph " ++ show nodes ++ show edges++instance Weight Rule where weight = ruleComplexity+instance Weight UV   where weight = width++{-+groupCycles :: Graph a b -> Graph [a] [b]+groupCycles (Graph nodes edges) = +  where+  +  _ = cycles $ map (:[]) nodes++  cycles :: a -> [[a]]+  cycles a path = +    where+    downstream = [ b | (a', _, b) <- edges, a == a' ]++    cycle :: [a] -> [a]+    cycle a+-}++partitionRules :: [Rule] -> IO ()+partitionRules rules = do+  print $ graphRules rules++graphRules :: [Rule] -> Graph Rule UV+graphRules rules = Graph rules [ (r, uv, w) | uv <- uvs, r <-reads uv, w <- writes uv ] +  where+  readWrites = map readWrite rules+  (uvs1, _, uvs2) = unzip3 readWrites+  uvs = intersect (nub $ concat uvs1) (nub $ concat uvs2)+  reads  uv = [ rule | (reads,  rule, _) <- readWrites, elem uv reads  ]+  writes uv = [ rule | (_, rule, writes) <- readWrites, elem uv writes ]++readWrite :: Rule -> ([UV], Rule, [UV])+readWrite rule = (nub uvs, rule, nub assignUVs)+  where+  (assignUVs, assignUEs) = unzip $ ruleAssigns rule+  ues = ruleEnable rule : assignUEs ++ concat (snd $ unzip $ ruleActions rule)+  uvs = nub $ concatMap reads ues++  reads :: UE -> [UV]+  reads (UVRef uv) = [uv]+  reads ue = concatMap reads $ ueUpstream ue+++

@@ -5,20 +5,15 @@  import Control.Monad import Data.List-import Data.Maybe import Language.Atom.Code import Language.Atom.Elaboration import System.IO import Text.Printf -schedule :: Name -> [Rule] -> IO (Maybe [[[Rule]]])+schedule :: Name -> [Rule] -> IO [[[Rule]]] schedule name rules = do-  putStrLn "Starting rule scheduling..."-  hFlush stdout-  putStrLn $ "Writing scheduling report (" ++ name ++ ".rpt)..."   writeFile (name ++ ".rpt") $ reportSchedule periods-  hFlush stdout-  return $ Just periods+  return periods   where    periods = map spread $ zip [1..] $ map rulesWithPeriod [1 .. maxPeriod]  -- XXX No scheduling done.

@@ -1,3 +1,12 @@+atom 0.1.0    07/31/2009++- Quieted compilation messages.+- Added config to disable rule coverage instrumentation.+- Added assert and cover statements.+- Added imply to expressions.+- Removed "int" for standard C types.+- Added L, UL, LL, and ULL C constant annotations for 32 and 64 bit integral types.+ atom 0.0.5    06/03/2009  - Fixed GHC seg fault issue related to Prelude.negate.

@@ -1,5 +1,5 @@ name:    atom-version: 0.0.5+version: 0.1.0  category: Language @@ -40,6 +40,7 @@         Language.Atom.Example         Language.Atom.Expressions         Language.Atom.Language+        Language.Atom.Partition         Language.Atom.Scheduling      extensions: GADTs