diff --git a/Language/Atom/Code.hs b/Language/Atom/Code.hs --- a/Language/Atom/Code.hs +++ b/Language/Atom/Code.hs @@ -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)] diff --git a/Language/Atom/Compile.hs b/Language/Atom/Compile.hs --- a/Language/Atom/Compile.hs +++ b/Language/Atom/Compile.hs @@ -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 + diff --git a/Language/Atom/Elaboration.hs b/Language/Atom/Elaboration.hs --- a/Language/Atom/Elaboration.hs +++ b/Language/Atom/Elaboration.hs @@ -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 _ = [] + diff --git a/Language/Atom/Example.hs b/Language/Atom/Example.hs --- a/Language/Atom/Example.hs +++ b/Language/Atom/Example.hs @@ -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 + diff --git a/Language/Atom/Expressions.hs b/Language/Atom/Expressions.hs --- a/Language/Atom/Expressions.hs +++ b/Language/Atom/Expressions.hs @@ -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 diff --git a/Language/Atom/Language.hs b/Language/Atom/Language.hs --- a/Language/Atom/Language.hs +++ b/Language/Atom/Language.hs @@ -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 }) + diff --git a/Language/Atom/Partition.hs b/Language/Atom/Partition.hs new file mode 100644 --- /dev/null +++ b/Language/Atom/Partition.hs @@ -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 + + + diff --git a/Language/Atom/Scheduling.hs b/Language/Atom/Scheduling.hs --- a/Language/Atom/Scheduling.hs +++ b/Language/Atom/Scheduling.hs @@ -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. diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -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. diff --git a/atom.cabal b/atom.cabal --- a/atom.cabal +++ b/atom.cabal @@ -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