atom 0.1.0 → 0.1.1

raw patch · 14 files changed

+466/−278 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Language/Atom.hs +2/−0
• Language/Atom/Analysis.hs +24/−0
• Language/Atom/Code.hs +95/−99
• Language/Atom/Common.hs +6/−1
• Language/Atom/Compile.hs +7/−5
• Language/Atom/Elaboration.hs +28/−27
• Language/Atom/Example.hs +31/−27
• Language/Atom/Expressions.hs +23/−14
• Language/Atom/Language.hs +18/−7
• Language/Atom/Partition.hs +0/−60
• Language/Atom/Scheduling.hs +41/−32
• Language/Atom/Unit.hs +172/−0
• RELEASE-NOTES +12/−0
• atom.cabal +7/−6

@@ -10,9 +10,11 @@   , module Language.Atom.Compile   , module Language.Atom.Common   , module Language.Atom.Language+  , module Language.Atom.Unit   ) where  import Language.Atom.Code import Language.Atom.Compile import Language.Atom.Common import Language.Atom.Language+import Language.Atom.Unit

@@ -0,0 +1,24 @@+module Language.Atom.Analysis+  ( topo+  , ruleComplexity+  ) where++import Language.Atom.Elaboration+import Language.Atom.Expressions++-- | Topologically sorts a list of expressions and subexpressions.+topo :: Int -> [UE] -> [(UE, String)]+topo start ues = reverse ues'+  where+  (_, ues') = foldl collect (start, []) ues+  collect :: (Int, [(UE, String)]) -> UE -> (Int, [(UE, String)])+  collect (n, ues) ue | any ((== ue) . fst) ues = (n, ues)+  collect (n, ues) ue = (n' + 1, (ue, e n') : ues') where (n', ues') = foldl collect (n, ues) $ ueUpstream ue++e :: Int -> String+e i = "__" ++ show i++-- | Number of UE's computed in rule.+ruleComplexity :: Rule -> Int+ruleComplexity = length . topo 0 . allUEs+

@@ -2,34 +2,36 @@ module Language.Atom.Code   ( Config (..)   , writeC-  , ruleComplexity   , defaults   , cTypes   , c99Types+  , RuleCoverage   ) where  import Data.Char import Data.List import Data.Maybe+import Data.Function import Data.Word import System.IO+import Text.Printf import Unsafe.Coerce +import Language.Atom.Analysis import Language.Atom.Elaboration import Language.Atom.Expressions+import Language.Atom.Scheduling  -- | 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.).-  , 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);+  { cFuncName     :: String                                                  -- ^ Alternative primary function name.  Leave empty to use compile name.+  , cType         :: Type -> String                                          -- ^ C type naming rules.+  , cCode         :: [Name] -> [Name] -> [(Name, Type)] -> (String, String)  -- ^ Custom C code to insert above and below, given assertion names, coverage names, and probe names and types.+  , cRuleCoverage :: Bool                                                    -- ^ Enable rule coverage tracking.+  , cAssert       :: Bool                                                    -- ^ Enable assertion checking.+  , cAssertName   :: String                                                  -- ^ Name of assertion function.  Type: void assert(int, cType Bool, cType Word64);+  , cCover        :: Bool                                                    -- ^ Enable functional coverage accumulation.+  , cCoverName    :: String                                                  -- ^ Name of coverage function.  Type: void cover(int, cType Bool, cType Word64);   }  -- | Default C code configuration parameters (default function name, no pre/post code, ANSI C types).@@ -37,8 +39,7 @@ defaults = Config   { cFuncName     = ""   , cType         = cTypes-  , cPreCode      = ""-  , cPostCode     = ""+  , cCode         = \ _ _ _ -> ("", "")   , cRuleCoverage = True   , cAssert       = True   , cAssertName   = "assert"@@ -96,8 +97,10 @@   operands = map (fromJust . flip lookup ues) $ ueUpstream ue   basic :: [String] -> String   basic operands = concat $ case ue of-    UVRef (UV (Array ua@(UA _ n _) _)) -> [arrayIndex config ua a, " /* ", n, " */ "]-    UVRef (UV (External n _)) -> [n]+    UVRef (UV i n _)                 -> ["__v", show i, " /* ", n, " */ "]+    UVRef (UVArray (UA i n _) _)     -> ["__a", show i, "[", a, "] /* ", n, " */ "]+    UVRef (UVArray (UAExtern n _) _) -> [n, "[", a, "]"]+    UVRef (UVExtern n _)             -> [n]     UCast _ _            -> ["(", cType config (typeOf ue), ") ", a]     UConst c             -> [showConst c]     UAdd _ _             -> [a, " + ", b]@@ -124,69 +127,64 @@     b = operands !! 1     c = operands !! 2 -writeC :: Name -> Config -> [[[Rule]]] -> ([Const], [Const], [Const], [Const]) -> IO ()-writeC name config periods (init8, init16, init32, init64) = do+type RuleCoverage = [(Name, Int, Int)]++writeC :: Name -> Config -> Schedule -> [UV] -> [UA] -> [Name] -> [Name] -> [(Name, Type)] -> IO RuleCoverage+writeC name config schedule uvs uas assertionNames coverageNames probeNames = do   writeFile (name ++ ".c") c-  writeFile (name' ++ "CoverageData.hs") cov+  return [ (ruleName r, div (ruleId r) 32, mod (ruleId r) 32) | r <- rules ]   where-  name' = toUpper (head name) : tail name+  (preCode, postCode) = cCode config assertionNames coverageNames probeNames   c = unlines-    [ cPreCode config+    [ preCode+    , ""     , "static " ++ cType config Word64 ++ " __clock = 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+    , codeIf (cRuleCoverage config) $ "static const " ++ cType config Word32 ++ " __coverage_len = " ++ show covLen ++ ";"+    , codeIf (cRuleCoverage config) $ "static " ++ cType config Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ (concat $ intersperse ", " $ replicate covLen "0") ++ "};"+    , codeIf (cRuleCoverage config) $ "static " ++ cType config Word32 ++ " __coverage_index = 0;"+    , concatMap (declUV config) uvs+    , concatMap (declUA config) uas+    , concatMap (codeRule config assertionNames coverageNames topo') $ rules     , "void " ++ (if null (cFuncName config) then name else cFuncName config) ++ "(void) {"-    , concatMap codePeriod $ zip [1..] periods+    , concatMap (codePeriodPhase config) schedule     , "  __clock = __clock + 1;"     , "}"-    , cPostCode config-    ]--  mi = memoryInit config--  rules = concat $ concat periods--  cov = unlines-    [ "module " ++ name' ++ "CoverageData (coverageData) where"     , ""-    , "-- | Encoding of rule coverage: (rule name, coverage array index, coverage bit)"-    , "coverageData :: [(String, (Int, Int))]"-    , "coverageData = " ++ show [ (ruleName r, (div (ruleId r) 32, mod (ruleId r) 32)) | r <- rules ]+    , postCode     ] +  rules :: [Rule]+  rules = concat [ r | (_, _, r) <- schedule ]+   topo' = topo 0   covLen = 1 + div (maximum $ map ruleId rules) 32 -ruleCoverage :: Config -> String -> String-ruleCoverage config s = if cRuleCoverage config then s else ""+codeIf :: Bool -> String -> String+codeIf a b = if a then b else "" -coverage :: Config -> String -> String-coverage config s = if cCover config then s else ""+declUA :: Config -> UA -> String+declUA _ (UAExtern _ _) = error "declUA"+declUA config ua@(UA i n init) = concat ["static ", cType config (typeOf ua), " __a", show i, "[", show (length init), "] = {", intercalate "," (map formatConst init), "};  /* ", n, " */\n"] -assertion :: Config -> String -> String-assertion config s = if cAssert config then s else ""+declUV :: Config -> UV -> String+declUV _ (UVArray _ _)  = error "declUV"+declUV _ (UVExtern _ _) = error "declUV"+declUV config (UV i n init) = concat ["static ", cType config (typeOf init), " __v", show i, " = ", formatConst init, ";  /* ", n, " */\n"] -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"-  where-  format :: Const -> String-  format c = case c of-    CBool True  -> "1"-    CBool False -> "0"-    CInt8   a   -> show a-    CInt16  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 ++ "UL"-    CWord64 a   -> show a ++ "ULL"-    CFloat  a   -> show $ floatBits  a-    CDouble a   -> show $ doubleBits a+formatConst :: Const -> String+formatConst c = case c of+  CBool True  -> "1"+  CBool False -> "0"+  CInt8   a   -> show a+  CInt16  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 ++ "UL"+  CWord64 a   -> show a ++ "ULL"+  CFloat  a   -> show $ floatBits  a+  CDouble a   -> show $ doubleBits a  floatBits :: Float -> Word32 floatBits = unsafeCoerce@@ -194,19 +192,16 @@ doubleBits :: Double -> Word64 doubleBits = unsafeCoerce -memory :: Width a => a -> String-memory a = "__memory" ++ show (if width a == 1 then 8 else width a)--codeRule :: Config -> ([UE] -> [(UE, String)]) -> Rule -> String-codeRule config topo rule =+codeRule :: Config -> [Name] -> [Name] -> ([UE] -> [(UE, String)]) -> Rule -> String+codeRule config assertionNames coverageNames topo rule =   "/* " ++ show rule ++ " */\n" ++   "static void __r" ++ show (ruleId rule) ++ "(void) {\n" ++   concatMap (codeUE    config ues "  ") ues ++   "  if (" ++ id (ruleEnable rule) ++ ") {\n" ++   concatMap codeAction (ruleActions rule) ++-  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 ] +++  codeIf (cRuleCoverage config) ("    __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord ++ "] | (1 << " ++ covBit ++ ");\n") +++  concat [ codeIf (cAssert config) ("    " ++ cAssertName config ++ "(" ++ assertionId name ++ ", " ++ id check ++ ", __clock);\n") | (name, check) <- ruleAsserts rule ] +++  concat [ codeIf (cCover  config) ("    " ++ cCoverName  config ++ "(" ++ coverageId  name ++ ", " ++ id check ++ ", __clock);\n") | (name, check) <- ruleCovers  rule ] ++   "  }\n" ++   concatMap codeAssign (ruleAssigns rule) ++   "}\n\n"@@ -214,6 +209,12 @@   ues = topo $ allUEs rule   id ue = fromJust $ lookup ue ues +  assertionId :: Name -> String+  assertionId name = show $ fromJust $ elemIndex name assertionNames++  coverageId :: Name -> String+  coverageId name = show $ fromJust $ elemIndex name coverageNames+   codeAction :: (([String] -> String), [UE]) -> String   codeAction (f, args) = "    " ++ f (map id args) ++ ";\n" @@ -221,35 +222,30 @@   covBit  = show $ mod (ruleId rule) 32    codeAssign :: (UV, UE) -> String-  codeAssign (UV (Array ua@(UA _ n _) i), ue) = "  " ++ arrayIndex config ua (id i) ++ " = " ++ id ue ++ ";  /* " ++ n ++ " */\n"-  codeAssign (UV (External n _), ue) = "  " ++ n ++ " = " ++ id ue ++ ";\n"--arrayIndex :: Config -> UA -> String -> String-arrayIndex config (UA addr _ c) i = "((" ++ cType config (typeOf (head c)) ++ " *) (" ++ memory (head c) ++ " + " ++ show addr ++ "))[" ++ i ++ "]"--codePeriod :: (Int, [[Rule]]) -> String-codePeriod (period, cycles) = concatMap (codeCycle period) $ zip [0..] cycles--codeCycle :: Int -> (Int, [Rule]) -> String-codeCycle period (cycle, _) | cycle >= period = error "Code.codeCycle"-codeCycle _ (_, rules)      | null rules = ""-codeCycle period (cycle, rules) =-  "  if (__clock % " ++ show period ++ " == " ++ show cycle ++ ") {\n" ++-  concatMap (\ r -> "    __r" ++ show (ruleId r) ++ "();  /* " ++ show r ++ " */\n") rules ++-  "  }\n"--e :: Int -> String-e i = "__" ++ show i+  codeAssign (uv, ue) = concat ["  ", lh, " = ", id ue, ";\n"]+    where+    lh = case uv of+      UV i n _                     -> concat ["__v", show i, " /* ", n, " */"]+      UVArray (UA i n _)     index -> concat ["__a", show i, "[", id index, "] /* ", n, " */"]+      UVArray (UAExtern n _) index -> concat [n, "[", id index, "]"]+      UVExtern n _                 -> n --- | Topologically sorts a list of expressions and subexpressions.-topo :: Int -> [UE] -> [(UE, String)]-topo start ues = reverse ues'+codePeriodPhase :: Config -> (Int, Int, [Rule]) -> String+codePeriodPhase config (period, phase, rules) = unlines+  [ printf "  {"+  , printf "    static %s __clock = %i;" (cType config clockType) phase+  , printf "    if (__clock == 0) {"+  , intercalate "\n" $ map callRule rules+  , printf "      __clock = %i;" (period - 1)+  , printf "    }"+  , printf "    else {"+  , printf "      __clock = __clock - 1;"+  , printf "    }"+  , printf "  }"+  ]   where-  (_, ues') = foldl collect (start, []) ues-  collect :: (Int, [(UE, String)]) -> UE -> (Int, [(UE, String)])-  collect (n, ues) ue | any ((== ue) . fst) ues = (n, ues)-  collect (n, ues) ue = (n' + 1, (ue, e n') : ues') where (n', ues') = foldl collect (n, ues) $ ueUpstream ue+  clockType | period < 2 ^  8 = Word8+            | period < 2 ^ 16 = Word16+            | otherwise       = Word32+  callRule r = concat ["      __r", show (ruleId r), "();  /* ", show r, " */"] --- | Number of UE's computed in rule.-ruleComplexity :: Rule -> Int-ruleComplexity = length . topo 0 . allUEs

@@ -5,6 +5,7 @@     Timer   , timer   , startTimer+  , startTimerIf   , timerDone   -- * One Shots   , oneShotRise@@ -32,7 +33,11 @@  -- | Starts a Timer.  A Timer can be restarted at any time. startTimer :: Timer -> E Word64 -> Atom ()-startTimer (Timer t) time = t <== clock + time+startTimer t = startTimerIf t true++-- | Conditionally start a Timer.+startTimerIf :: Timer -> E Bool -> E Word64 -> Atom ()+startTimerIf (Timer t) a time = t <== mux a (clock + time) (value t)  -- | 'True' when a timer has completed. timerDone :: Timer -> E Bool

@@ -1,6 +1,8 @@ -- | Atom compilation. module Language.Atom.Compile   ( compile+  , reportSchedule+  , Schedule   ) where  import Control.Monad.State hiding (join)@@ -14,13 +16,13 @@ import Language.Atom.Language hiding (Atom)  -- | Compiles an atom description to C.-compile :: Name -> Config -> Atom () -> IO [Name]+compile :: Name -> Config -> Atom () -> IO (Schedule, RuleCoverage, [Name], [Name], [(Name, Type)]) 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, coverage) -> do-      schedule <- schedule name rules-      writeC name config schedule init-      return coverage+    Just (rules, uvs, uas, assertionNames, coverageNames, probeNames) -> do+      let schedule' = schedule rules+      ruleCoverage <- writeC name config schedule' uvs uas assertionNames coverageNames probeNames+      return (schedule', ruleCoverage, assertionNames, coverageNames, probeNames) 

@@ -14,6 +14,7 @@   , var   , var'   , array+  , array'   , addName   , get   , put@@ -25,7 +26,6 @@ import Data.Function (on) import Data.List import Data.Maybe-import Data.Word import Language.Atom.Expressions import System.IO @@ -38,12 +38,12 @@ type Path = [Name]  data Global = Global-  { gId      :: Int-  , gProbes  :: [(String, Type, E Word64)]-  , gInit8   :: [Const]-  , gInit16  :: [Const]-  , gInit32  :: [Const]-  , gInit64  :: [Const]+  { gRuleId  :: Int+  , gVarId   :: Int+  , gArrayId :: Int+  , gVars    :: [UV]+  , gArrays  :: [UA]+  , gProbes  :: [(String, UE)]   , gPeriod  :: Int   } @@ -103,8 +103,8 @@   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+buildAtom g name (Atom f) = f (g { gRuleId = gRuleId g + 1 }, AtomDB+  { atomId        = gRuleId g   , atomName      = name   , atomNames     = []   , atomEnable    = ubool True@@ -145,16 +145,18 @@ -- 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]), [Name]))+elaborate :: Name -> Atom () -> IO (Maybe ([Rule], [UV], [UA], [Name], [Name], [(Name, Type)])) elaborate name atom = do-  (_, (g, atomDB)) <- buildAtom Global { gId = 0, gInit8 = [], gInit16 = [], gInit32 = [], gInit64 = [], gProbes = [], gPeriod = 1 } name atom+  (_, (g, atomDB)) <- buildAtom Global { gRuleId = 0, gVarId = 0, gArrayId = 0, gVars = [], gArrays = [], gProbes = [], gPeriod = 1 } name atom   let rules = reIdRules $ elaborateRules (ubool True) atomDB-      coverage = concatMap (fst . unzip . ruleCovers ) rules+      coverageNames  = concatMap (fst . unzip . ruleCovers ) rules+      assertionNames = concatMap (fst . unzip . ruleAsserts) rules+      probeNames = [ (n, typeOf a) | (n, a) <- gProbes g ]   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)+    else return $ Just (rules, gVars g, gArrays g, assertionNames, coverageNames, probeNames)   @@ -204,12 +206,15 @@ -- | Generic local variable declaration. 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+  name <- addName name+  (g, atom) <- get+  let uv = UV (gVarId g) name (constant init)+  put (g { gVarId = gVarId g + 1, gVars = uv : gVars g }, atom)+  return $ V uv  -- | Generic external variable declaration. var' :: Name -> Type -> Atom (V a)-var' name t = return $ V $ UV $ External name t+var' name t = return $ V $ UVExtern name t  -- | Generic array declaration. array :: Expr a => Name -> [a] -> Atom (A a)@@ -217,18 +222,14 @@ 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)+  let ua = UA (gArrayId g) name (map constant init)+  put (g { gArrayId = gArrayId g + 1, gArrays = ua : gArrays g}, atom)   return $ A ua +-- | Generic external array declaration.+array' :: Expr a => Name -> Type -> Atom (A a)+array' name t = return $ A $ UAExtern  name t+ addName :: Name -> Atom Name addName name = do   (g, atom) <- get@@ -285,6 +286,6 @@ 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 (UVArray _ ue) = [ue]   index _ = [] 

@@ -9,34 +9,38 @@ -- | Invoke the atom compiler. compileExample :: IO () compileExample = do-  compile "example" defaults { cPreCode = preCode, cPostCode = postCode } example-  return ()--preCode :: String-preCode = unlines-  [ "#include <stdlib.h>"-  , "#include <stdio.h>"-  , "unsigned long int a;"-  , "unsigned long int b;"-  , "unsigned long int x;"-  , "unsigned char running = 1;"-  ]--postCode :: String-postCode = unlines-  [ "int main(int argc, char* argv[]) {"-  , "  a = atoi(argv[1]);"-  , "  b = atoi(argv[2]);"-  , "  printf(\"Computing the GCD of %lu and %lu...\\n\", a, b);"-  , "  while(running) {"-  , "    example();"-  , "    printf(\"iteration:  a = %lu  b = %lu\\n\", a, b);"-  , "  }"-  , "  printf(\"GCD result: %lu\\n\", a);"-  , "  return 0;"-  , "}"-  ]+  (schedule, _, _, _, _) <- compile "example" defaults { cCode = prePostCode } example+  putStrLn $ reportSchedule schedule +prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String)+prePostCode _ _ _ =+  ( unlines+    [ "#include <stdlib.h>"+    , "#include <stdio.h>"+    , "unsigned long int a;"+    , "unsigned long int b;"+    , "unsigned long int x;"+    , "unsigned char running = 1;"+    ]+  , unlines+    [ "int main(int argc, char* argv[]) {"+    , "  if (argc < 3) {"+    , "    printf(\"usage: gcd <num1> <num2>\\n\");"+    , "  }"+    , "  else {"+    , "    a = atoi(argv[1]);"+    , "    b = atoi(argv[2]);"+    , "    printf(\"Computing the GCD of %lu and %lu...\\n\", a, b);"+    , "    while(running) {"+    , "      example();"+    , "      printf(\"iteration:  a = %lu  b = %lu\\n\", a, b);"+    , "    }"+    , "    printf(\"GCD result: %lu\\n\", a);"+    , "  }"+    , "  return 0;"+    , "}"+    ]+  )  -- | An example design that computes the greatest common divisor. example :: Atom ()

@@ -5,7 +5,6 @@   , V     (..)   , UE    (..)   , UV    (..)-  , UVLocality (..)   , A     (..)   , UA    (..)   , Expr  (..)@@ -160,16 +159,20 @@ data V a = V UV deriving Eq  -- | Untyped variables.-data UV = UV UVLocality deriving (Show, Eq, Ord)---- | UV locality.-data UVLocality = Array UA UE | External String Type deriving (Show, Eq, Ord)+data UV+  = UV Int String Const+  | UVArray UA UE+  | UVExtern String Type+  deriving (Show, Eq, Ord)  -- | A typed array. data A a = A UA deriving Eq  -- | An untyped array.-data UA = UA Int String [Const] deriving (Show, Eq, Ord)+data UA+  = UA Int String [Const]+  | UAExtern String Type+  deriving (Show, Eq, Ord)  -- | A typed expression. data E a where@@ -194,6 +197,7 @@   D2B     :: E Double -> E Word64   B2F     :: E Word32 -> E Float   B2D     :: E Word64 -> E Double+  Retype  :: UE -> E a  instance Show (E a) where   show _ = error "Show (E a) not implemented"@@ -270,14 +274,17 @@  instance TypeOf UV where   typeOf a = case a of-    UV (Array a _)  -> typeOf a-    UV (External _ t) -> t+    UV _ _ a     -> typeOf a+    UVArray a _  -> typeOf a+    UVExtern _ t -> t  instance TypeOf (V a) where   typeOf (V uv) = typeOf uv  instance TypeOf UA where-  typeOf (UA _ _ c) = typeOf $ head c+  typeOf a = case a of+    UA _ _ c     -> typeOf $ head c+    UAExtern _ t -> t  instance TypeOf (A a) where   typeOf (A ua) = typeOf ua@@ -612,7 +619,7 @@  -- | Array index to variable. (!) :: (Expr a, IntegralE b) => A a -> E b -> V a-(!) (A ua) = V . UV . Array ua . ue+(!) (A ua) = V . UVArray ua . ue  -- | Array index to expression. (!.) :: (Expr a, IntegralE b) => A a -> E b -> E a@@ -623,8 +630,9 @@ -- | The list of UEs adjacent upstream of a UE. ueUpstream :: UE -> [UE] ueUpstream t = case t of-  UVRef (UV (Array _ ue))   -> [ue]-  UVRef (UV (External _ _)) -> []+  UVRef (UV _ _ _)     -> []+  UVRef (UVArray _ a)  -> [a]+  UVRef (UVExtern _ _) -> []   UCast _ a   -> [a]   UConst _    -> []   UAdd a b    -> [a, b]@@ -659,13 +667,13 @@ arrayIndices = nub . f   where   f :: UE -> [(UA, UE)]-  f (UVRef (UV (Array ua ue))) = (ua, ue) : f ue+  f (UVRef (UVArray 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+  VRef (V v)   -> UVRef v   Const  a     -> UConst $ constant a   Cast   a     -> UCast    tt (ue a)   Add    a b   -> UAdd     (ue a) (ue b)@@ -686,6 +694,7 @@   D2B    a     -> UD2B     (ue a)   B2F    a     -> UB2F     (ue a)   B2D    a     -> UB2D     (ue a)+  Retype a     -> a   where   tt = eType t 

@@ -17,6 +17,7 @@   , var   , var'   , array+  , array'   , bool   , bool'   , int8@@ -47,6 +48,7 @@   -- * Assertions and Functional Coverage   , assert   , cover+  , assertImply   -- * Utilities   , Name   , liftIO@@ -56,6 +58,7 @@   , nextCoverage   ) where +import Control.Monad import Control.Monad.Trans import Data.Int import Data.List@@ -203,13 +206,13 @@ probe :: Expr a => Name -> E a -> Atom () probe name a = do   (g, atom) <- get-  if any (\ (n, _, _) -> name == n) $ gProbes g+  if any (\ (n, _) -> name == n) $ gProbes g     then error $ "ERROR: Duplicated probe name: " ++ name-    else put (g { gProbes = (name, eType a, rawBits a) : gProbes g }, atom)+    else put (g { gProbes = (name, ue a) : gProbes g }, atom)   -- | Fetches all declared probes to current design point.-probes :: Atom [(String, Type, E Word64)]+probes :: Atom [(String, UE)] probes = do   (g, _) <- get   return $ gProbes g@@ -253,26 +256,34 @@  -- | Reference to the 64-bit free running clock. clock :: E Word64-clock = value $ V $ UV $ External "__clock" Word64+clock = value $ V $ UVExtern "__clock" Word64  -- | Rule coverage information.  (current coverage index, coverage data) nextCoverage :: Atom (E Word32, E Word32) 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)+  return (value $ V $ UVExtern "__coverage_index" Word32, value $ V $ UVExtern "__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+  let names = fst $ unzip $ atomAsserts atom+  when (elem name names) (liftIO $ putStrLn $ "WARNING: Assertion name already used: " ++ name)   put (g, atom { atomAsserts = (name, ue check) : atomAsserts atom }) +-- | Implication assertions.  Creates an implicit coverage point for the precondition.+assertImply :: Name -> E Bool -> E Bool -> Atom ()+assertImply name a b = do+  assert name $ imply a b+  cover (name ++ "Precondition") a+ -- | Addes a functional coverage point. cover :: Name -> E Bool -> Atom () cover name check = do-  name <- addName name   (g, atom) <- get+  let names = fst $ unzip $ atomAsserts atom+  when (elem name names) (liftIO $ putStrLn $ "WARNING: Assertion name already used: " ++ name)   put (g, atom { atomCovers = (name, ue check) : atomCovers atom }) 

@@ -1,60 +0,0 @@-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---

@@ -1,52 +1,61 @@ -- | Atom rule scheduling. module Language.Atom.Scheduling   ( schedule+  , Schedule+  , reportSchedule   ) where -import Control.Monad import Data.List-import Language.Atom.Code+import Language.Atom.Analysis import Language.Atom.Elaboration-import System.IO import Text.Printf -schedule :: Name -> [Rule] -> IO [[[Rule]]]-schedule name rules = do-  writeFile (name ++ ".rpt") $ reportSchedule periods-  return periods-  where--  periods = map spread $ zip [1..] $ map rulesWithPeriod [1 .. maxPeriod]  -- XXX No scheduling done.--  maxPeriod = maximum $ map rulePeriod rules+type Schedule = [(Int, Int, [Rule])]  -- (period, phase, rules) -  rulesWithPeriod :: Int -> [Rule]-  rulesWithPeriod p = [ r | r <- rules, rulePeriod r == p ]+schedule :: [Rule] -> Schedule+schedule rules = concatMap spread periods+  where -  spread :: (Int, [Rule]) -> [[Rule]]-  spread (0, []) = []-  spread (0, _)  = error "Scheduling.spread"-  spread (period, rules) = take rulesInCycle rules : spread (period - 1, drop rulesInCycle rules)+  spread :: (Int, [Rule]) -> Schedule+  spread (period, rules) = [ (period, phase, rules) | (phase, rules) <- zip [0..] $ unconcat rulesPerPhase rules ]     where-    rulesInCycle = (length rules `div` period) + (if length rules `mod` period > 0 then 1 else 0)+    rulesPerPhase = (length rules `div` period) + (if length rules `mod` period > 0 then 1 else 0) +  periods = foldl grow [] [ (rulePeriod r, r) | r <- rules ] -reportSchedule :: [[[Rule]]] -> String-reportSchedule s = "Rule Scheduling Report\n\n  Period  Cycle  Exprs  Rule\n  ------  -----  -----  ----\n" ++ concatMap reportPeriod (zip [1..] s) ++-                   "                 -----\n" ++-                   printf "                 %5i\n" (sum $ map ruleComplexity (concat (concat s))) ++ "\n" ++-                   "Hierarchical Expression Count\n\n" ++-                   "  Total   Local     Rule\n" ++-                   "  ------  ------    ----\n" ++-                   reportUsage "" (usage $ concat $ concat s) ++-                   "\n"+  grow :: [(Int, [Rule])] -> (Int, Rule) -> [(Int, [Rule])]+  grow [] (a, b) = [(a, [b])]+  grow ((a, bs):rest) (a', b) | a' == a   = (a, b : bs) : rest+                              | otherwise = (a, bs) : grow rest (a', b) -reportPeriod (period, p) = concatMap (reportCycle period) (zip [0..] p)+unconcat :: Int -> [a] -> [[a]]+unconcat _ [] = []+unconcat n a  = take n a : unconcat n (drop n a) -reportCycle period (cycle, c) = concatMap (reportRule period cycle) c+reportSchedule :: Schedule -> String+reportSchedule schedule = concat+  [ "Rule Scheduling Report\n\n"+  , "Period  Phase  Exprs  Rule\n"+  , "------  -----  -----  ----\n"+  , concatMap reportPeriod schedule+  , "               -----\n"+  , printf "               %5i\n" $ sum $ map ruleComplexity rules+  , "\n"+  , "Hierarchical Expression Count\n\n"+  , "  Total   Local     Rule\n"+  , "  ------  ------    ----\n"+  , reportUsage "" $ usage rules+  , "\n"+  ]+  where+  rules = concat $ [ r | (_, _, r) <- schedule ] -reportRule :: Int -> Int -> Rule -> String-reportRule period cycle rule = printf "  %6i  %5i  %5i  %s\n" period cycle (ruleComplexity rule) (show rule)++reportPeriod :: (Int, Int, [Rule]) -> String+reportPeriod (period, phase, rules) = concatMap reportRule rules+  where+  reportRule :: Rule -> String+  reportRule rule = printf "%6i  %5i  %5i  %s\n" period phase (ruleComplexity rule) (show rule)   data Usage = Usage String Int [Usage] deriving Eq

@@ -0,0 +1,172 @@+module Language.Atom.Unit+  (+  -- * Types and Classes+    Test (..)+  , defaultTest+  , Random (..)+  -- * Test Execution+  , runTests+  -- * Printing Utilities+  , printStrLn+  , printIntegralE+  , printFloatingE+  ) where++import Control.Monad+import Data.Bits+import Data.Int+import Data.List+import Data.Word+import Language.Atom.Code+import Language.Atom.Compile+import Language.Atom.Language+import System.Exit+import System.IO+import System.Process+import Text.Printf+++-- | Data constructor:Test+data Test = Test+  { name      :: String+  , cycles    :: Int+  , testbench :: Atom ()+  , modules   :: [FilePath]+  , includes  :: [FilePath]+  , declCode  :: String+  , initCode  :: String+  , loopCode  :: String+  , endCode   :: String+  }++defaultTest :: Test+defaultTest = Test+  { name      = "test"+  , cycles    = 1000+  , testbench = return ()+  , modules   = []+  , includes  = []+  , declCode  = ""+  , initCode  = ""+  , loopCode  = ""+  , endCode   = ""+  }+++-- | Running TestList+runTests :: Int -> [IO Test] -> IO ()+runTests seed tests = do+  testResults <- mapM (runTest seed) tests+  let totalTests    = length testResults+      passingTests  = length $ filter (\ (_, p, _, _, _) -> p) testResults+      totalCoverage = nub $ concat [ a | (_, _, _, a, _) <- testResults ]+      unHitCoverage = sort $ totalCoverage \\ (nub $ concat [ a | (_, _, _, _, a) <- testResults ])+      totalCycles   = sum [ c | (_, _, c, _, _) <- testResults ]+      maxNameLen    = maximum [ length n | (n, _, _, _, _) <- testResults ]+  mapM_ (reportResult maxNameLen) testResults+  putStrLn ""+  putStrLn $ "Total Passing Tests     : " ++ show passingTests ++ " / " ++ show totalTests+  putStrLn $ "Total Simulation Cycles : " ++ show totalCycles+  putStrLn $ "Total Function Coverage : " ++ show (length totalCoverage - length unHitCoverage) ++ " / " ++ show (length totalCoverage)+  when (not $ null unHitCoverage) $ do+    putStrLn ""+    putStrLn "  Missed Coverage Points:"+    putStrLn ""+    mapM_ (putStrLn . ("    " ++)) unHitCoverage+  putStrLn ""+  putStrLn $ (if passingTests /= totalTests then "RED" else if not $ null unHitCoverage then "YELLOW" else "GREEN") ++ " LIGHT"+  putStrLn ""++reportResult :: Int -> (Name, Bool, Int, a, b) -> IO ()+reportResult m (name, pass, cycles, _, _) =+      printf "%s:  %s    cycles = %7i  %s\n"+        (if pass then "pass" else "FAIL")+        (printf ("%-" ++ show m ++ "s") name :: String)+        cycles+        (if pass then "" else "    (see " ++ name ++ ".log)")++runTest :: Int -> IO Test -> IO (Name, Bool, Int, [Name], [Name])+runTest seed test = do+  test <- test+  (_, _, _, coverageNames, _) <- compile "atom_unit_test" defaults { cCode = prePostCode test, cRuleCoverage = False } $ testbench test+  (exit, out, err) <- readProcessWithExitCode "gcc" (["-Wall", "-g", "-o", "atom_unit_test"] ++ [ "-i" ++ i | i <- includes test ] ++ modules test ++ ["atom_unit_test.c"]) ""+  let file = name test ++ ".log"+  case exit of +    ExitFailure _ -> do+      writeFile file $ out ++ err+      return (name test, False, 0, coverageNames, [])+    ExitSuccess -> do+      log <- readProcess "./atom_unit_test" [] ""+      let pass = not $ elem "FAILURE:" $ words log+          covered = [ words line !! 1 | line <- lines log, isPrefixOf "covered:" line ]+      writeFile file $ out ++ err ++ log+      hFlush stdout+      return (name test, pass, cycles test, coverageNames, covered)+  where+  prePostCode test assertionNames coverageNames _ = (preCode, postCode)+    where+    preCode = unlines+      [ "#include <stdio.h>"+      , "#include <stdlib.h>"+      , "void assert (int id, unsigned char check, unsigned long long clock) {"+      , "  static unsigned char failed[" ++ show (length assertionNames) ++ "] = {" ++ intercalate "," (replicate (length assertionNames) "0") ++ "};"+      , "  " ++ intercalate "\n  else " [ "if (id == " ++ show id ++ ") { if (! check && ! failed[id]) { printf(\"ASSERTION FAILURE: " ++ name ++ " at time %lli\\n\", clock); failed[id] = 1; } }" | (name, id) <- zip assertionNames [0..] ]+      , "}"+      , "void cover  (int id, unsigned char check, unsigned long long clock) {"+      , "  static unsigned char covered[" ++ show (length coverageNames) ++ "] = {" ++ intercalate "," (replicate (length coverageNames) "0") ++ "};"+      , "  " ++ intercalate "\n  else " [ "if (id == " ++ show id ++ ") { if (check && ! covered[id]) { printf(\"covered: " ++ name ++ " at time %lli\\n\", clock); covered[id] = 1; } }" | (name, id) <- zip coverageNames [0..] ]+      , "}"+      ] ++ declCode test++    postCode = unlines+      [ "int main() {"+      , "  int loop;"+      , "  srand(" ++ show seed ++ ");"+      , initCode test+      , "  for (loop = 0; loop < " ++ show (cycles test) ++ "; loop++) {"+      , "    atom_unit_test();"+      , loopCode test+      , "  }"+      , endCode test+      , "  return 0;"+      , "}"+      ]+  ++++-- | Printing strings in C using printf.+printStrLn :: String -> Atom ()+printStrLn s = action (\ _ -> "printf(\"" ++ s ++ "\\n\")") []++-- | Print integral values.+printIntegralE :: IntegralE a => String -> E a -> Atom ()+printIntegralE name value = action (\ [v] -> "printf(\"" ++ name ++ ": %i\\n\", " ++ v ++ ")") [ue value]++-- | Print floating point values.+printFloatingE :: FloatingE a => String -> E a -> Atom ()+printFloatingE name value = action (\ [v] -> "printf(\"" ++ name ++ ": %f\\n\", " ++ v ++ ")") [ue value]+++class Expr a => Random a where random :: Atom (E a)++instance Random Bool where+  random = do+    r <- random32+    return $ (1 .&. r) ==. 1+instance Random Word8  where random = random32 >>= (return . Cast)+instance Random Word16 where random = random32 >>= (return . Cast)+instance Random Word32 where random = random32+instance Random Word64 where+  random = do+    a <- random32+    b <- random32  -- XXX Will repeated "rand()" variables work?+    return $ Cast a .|. shiftL (Cast b) 32+instance Random Int8  where random = random32 >>= (return . Cast)+instance Random Int16 where random = random32 >>= (return . Cast)+instance Random Int32 where random = random32 >>= (return . Cast)+instance Random Int64 where random = (random :: Atom (E Word64)) >>= (return . Cast)++random32 :: Atom (E Word32)+random32 = word32' "rand()" >>= (return . value)+

@@ -1,3 +1,15 @@+atom 0.1.1    09/29/2009++- Added ULL C constant annotations for rule scheduling.+- Created new Schedule type.+- compile returns schedule and coverage information.+- reportSchedule function to report scheduling information.+- Replaced global 64-bit clock used in scheduling with local clocks.+- Created unit testing framework.+- Added startTimerIf.+- Added exernal arrays (array').+- Replaced global memory arrays with individual variables.+ atom 0.1.0    07/31/2009  - Quieted compilation messages.

@@ -1,5 +1,5 @@ name:    atom-version: 0.1.0+version: 0.1.1  category: Language @@ -17,7 +17,7 @@ license:      BSD3 license-file: LICENSE -homepage: http://patch-tag.com/r/atom/home+homepage: http://patch-tag.com/r/tomahawkins/atom  build-type:    Simple cabal-version: >= 1.6@@ -27,12 +27,13 @@  library     build-depends:-        base    >= 4       && < 5,-        mtl     >= 1.1.0.1 && < 1.2,-        process >= 1.0.1.1 && < 1.2+        base       >= 4       && < 5,+        mtl        >= 1.1.0.1 && < 1.2,+        process    >= 1.0.1.1 && < 1.2      exposed-modules:         Language.Atom+        Language.Atom.Analysis         Language.Atom.Code         Language.Atom.Common         Language.Atom.Compile@@ -40,8 +41,8 @@         Language.Atom.Example         Language.Atom.Expressions         Language.Atom.Language-        Language.Atom.Partition         Language.Atom.Scheduling+        Language.Atom.Unit      extensions: GADTs