atom 0.0.2 → 0.0.3

raw patch · 8 files changed

+190/−81 lines, 8 filesdep ~processPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: process

API changes (from Hackage documentation)

Files

• Language/Atom.hs +3/−1
• Language/Atom/Code.hs +81/−38
• Language/Atom/Compile.hs +3/−3
• Language/Atom/Elaboration.hs +44/−16
• Language/Atom/Example.hs +48/−18
• Language/Atom/Language.hs +2/−3
• RELEASE-NOTES +7/−0
• atom.cabal +2/−2

@@ -5,11 +5,13 @@ -}  module Language.Atom-  ( module Language.Atom.Compile+  ( module Language.Atom.Code+  , module Language.Atom.Compile   , module Language.Atom.Common   , module Language.Atom.Language   ) where +import Language.Atom.Code import Language.Atom.Compile import Language.Atom.Common import Language.Atom.Language

@@ -1,7 +1,11 @@--- | Atom code generation.+-- | Atom C code generation. module Language.Atom.Code-  ( writeC+  ( Config (..)+  , writeC   , ruleComplexity+  , defaults+  , cTypes+  , c99Types   ) where  import Data.Char@@ -12,8 +16,26 @@ import Language.Atom.Elaboration import Language.Atom.Expressions -declareMemory :: UV -> String-declareMemory (UV id name (Local init)) = cType (constType init) ++ " " ++ e id ++ " = " ++ c ++ ";  /* " ++ name ++ " */\n"+-- | 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.).+  }++-- | Default C code configuration parameters (default function name, no pre/post code, ANSI C types).+defaults :: Config+defaults = Config+  { cFuncName = ""+  , cType     = cTypes+  , cPreCode  = ""+  , cPostCode = ""+  }++declareMemory :: Config -> UV -> String+declareMemory config (UV id name (Local init)) = cType config (constType init) ++ " " ++ e id ++ " = " ++ c ++ ";  /* " ++ name ++ " */\n"   where   c = case init of     CBool   c -> if c then "1" else "0" @@ -27,18 +49,19 @@     CWord64 c -> show c     CFloat  c -> show c     CDouble c -> show c-declareMemory (UV _ _ (External _)) = ""+declareMemory _ (UV _ _ (External _)) = "" -declareUE :: String -> (UE, String) -> String-declareUE d (ue, n) = case ue of+declareUE :: Config -> String -> (UE, String) -> String+declareUE config d (ue, n) = case ue of   UVRef _              -> ""-  UConst (CBool True ) -> d ++ "const " ++ cType (ueType ue) ++ " " ++ n ++ " = 1;\n"-  UConst (CBool False) -> d ++ "const " ++ cType (ueType ue) ++ " " ++ n ++ " = 0;\n"-  UConst c             -> d ++ "const " ++ cType (ueType ue) ++ " " ++ n ++ " = " ++ show c ++ ";\n"-  _                    -> d ++             cType (ueType ue) ++ " " ++ n ++ ";\n"+  UConst (CBool True ) -> d ++ "const " ++ cType config (ueType ue) ++ " " ++ n ++ " = 1;\n"+  UConst (CBool False) -> d ++ "const " ++ cType config (ueType ue) ++ " " ++ n ++ " = 0;\n"+  UConst c             -> d ++ "const " ++ cType config (ueType ue) ++ " " ++ n ++ " = " ++ show c ++ ";\n"+  _                    -> d ++             cType config (ueType ue) ++ " " ++ n ++ ";\n" -cType :: Type -> String-cType t = case t of+-- | ANSI C type naming rules.+cTypes :: Type -> String+cTypes t = case t of   Bool   -> "unsigned char"   Int8   -> "signed char"   Int16  -> "signed short int"@@ -51,8 +74,23 @@   Float  -> "float"   Double -> "double" -codeUE :: [(UE, String)] -> String -> (UE, String) -> String-codeUE ues d (ue, n) = case ue of+-- | C99 type naming rules.+c99Types :: Type -> String+c99Types t = case t of+  Bool   -> "uint8_t"+  Int8   -> "int8_t"+  Int16  -> "int16_t"+  Int32  -> "int32_t"+  Int64  -> "int64_t"+  Word8  -> "uint8_t"+  Word16 -> "uint16_t"+  Word32 -> "uint32_t"+  Word64 -> "uint64_t"+  Float  -> "float"+  Double -> "double"++codeUE :: Config -> [(UE, String)] -> String -> (UE, String) -> String+codeUE config ues d (ue, n) = case ue of   UConst _       -> ""   UVRef _        -> ""   _              -> d ++ n ++ " = " ++ basic operands ++ ";\n"@@ -61,7 +99,7 @@   basic :: [String] -> String   basic operands = case ue of     UVRef _              -> error "Code.ueStmt: should not get here."-    UCast _ _            -> "(" ++ cType (ueType ue) ++ ") " ++ a+    UCast _ _            -> "(" ++ cType config (ueType ue) ++ ") (" ++ a ++ ")"     UConst _             -> error "Code.ueStmt: should not get here."     UAdd _ _             ->  a ++ " + " ++ b     USub _ _             ->  a ++ " - " ++ b@@ -77,37 +115,42 @@     UEq  _ _             -> a ++ " == " ++ b     ULt  _ _             -> a ++ " < " ++ b     UMux _ _ _           -> a ++ " ? " ++ b ++ " : " ++ c-    UF2B _               -> "*((unsigned long int *) &" ++ a ++ ")"-    UD2B _               -> "*((unsigned long long int *) &" ++ a ++ ")"-    UB2F _               -> "*((float *) &" ++ a ++ ")"-    UB2D _               -> "*((double *) &" ++ a ++ ")"+    UF2B _               -> "*((unsigned long int *) &(" ++ a ++ "))"+    UD2B _               -> "*((unsigned long long int *) &(" ++ a ++ "))"+    UB2F _               -> "*((float *) &(" ++ a ++ "))"+    UB2D _               -> "*((double *) &(" ++ a ++ "))"     where     a = operands !! 0     b = operands !! 1     c = operands !! 2 -writeC :: Name -> [[[Rule]]] -> [UV] -> IO ()-writeC name periods uvs = do+writeC :: Name -> Config -> [[[Rule]]] -> [UV] -> IO ()+writeC name config periods uvs = do+  putStrLn $ "Writing C code (" ++ name ++ ".c)..."   writeFile (name ++ ".c") c-  writeFile "CoverageData.hs" cov+  putStrLn $ "Writing coverage data description (" ++ name' ++ "CoverageData.hs)..."+  writeFile (name' ++ "CoverageData.hs") cov   where+  name' = toUpper (head name) : tail name   c = unlines-    [ cType Word64 ++ " __clock = 0;"-    , "const " ++ cType Word32 ++ " __coverage_len = " ++ show covLen ++ ";"-    , cType Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ drop 2 (concat $ replicate covLen ", 0") ++ "};"-    , cType Word32 ++ " __coverage_index = 0;"-    , concatMap declareMemory uvs-    , concatMap (codeRule topo') $ concat $ concat periods-    , "void " ++ name ++ "(void) {"+    [ cPreCode config+    , cType config Word64 ++ " __clock = 0;"+    , "const " ++ cType config Word32 ++ " __coverage_len = " ++ show covLen ++ ";"+    , cType config Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ drop 2 (concat $ replicate covLen ", 0") ++ "};"+    , cType config Word32 ++ " __coverage_index = 0;"+    , concatMap (declareMemory config) uvs+    , concatMap (codeRule config topo') $ concat $ concat periods+    , "void " ++ (if null (cFuncName config) then name else cFuncName config) ++ "(void) {"     , concatMap codePeriod $ zip [1..] periods     , "  __clock = __clock + 1;"     , "}"+    , cPostCode config     ]    rules = concat $ concat periods    cov = unlines-    [ "module CoverageData (coverageData) where"+    [ "module " ++ name' ++ "CoverageData (coverageData) where"     , ""     , "-- | Encoding of rule coverage: (rule name, coverage array index, coverage bit)"     , "coverageData :: [(String, (Int, Int))]"@@ -117,12 +160,12 @@   topo' = topo $ maximum (map (\ (UV i _ _) -> i) uvs) + 1   covLen = 1 + div (maximum $ map ruleId rules) 32 -codeRule :: ([UE] -> [(UE, String)]) -> Rule -> String-codeRule topo rule = +codeRule :: Config -> ([UE] -> [(UE, String)]) -> Rule -> String+codeRule config topo rule =    "/* " ++ show rule ++ " */\n" ++-  "void r" ++ show (ruleId rule) ++ "(void) {\n" ++-  concatMap (declareUE  "  ") ues ++-  concatMap (codeUE ues "  ") ues +++  "void __r" ++ show (ruleId rule) ++ "(void) {\n" +++  concatMap (declareUE config     "  ") ues +++  concatMap (codeUE    config ues "  ") ues ++   "  if (" ++ id (ruleEnable rule) ++ ") {\n" ++   concatMap codeAction (ruleActions rule) ++   "    __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord ++ "] | (1 << " ++ covBit ++ ");\n" ++@@ -145,11 +188,11 @@ 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 +++  concatMap (\ r -> "    __r" ++ show (ruleId r) ++ "();  /* " ++ show r ++ " */\n") rules ++   "  }\n"  e :: Int -> String-e i = "e" ++ show i+e i = "__" ++ show i  v :: UV -> String v (UV i _ (Local _)) = e i

@@ -15,8 +15,8 @@ import Language.Atom.Verify ()  -- | Compiles an atom description to C.-compile :: Name -> Atom () -> IO ()-compile name atom = do+compile :: Name -> Config -> Atom () -> IO ()+compile name config atom = do   r <- elaborate name atom   case r of     Nothing -> putStrLn "ERROR: Design rule checks failed." >> exitWith (ExitFailure 1)@@ -33,5 +33,5 @@           -}           putStrLn "Starting code generation..."           hFlush stdout-          writeC name schedule uvs+          writeC name config schedule uvs 

@@ -14,9 +14,11 @@   , var   , var'   , addName+  , get+  , put   ) where -import Control.Monad.State hiding (join)+import Control.Monad.Trans import Data.List import Data.Maybe import Data.Word@@ -89,22 +91,42 @@   ids = zip (map ruleId rules) [0..]  buildAtom :: Global -> Name -> Atom a -> IO (a, (Global, AtomDB))-buildAtom g name atom = do-  runStateT atom $ (g { gId = gId g + 1 }, AtomDB-    { atomId        = gId g-    , atomName      = name-    , atomNames     = []-    , atomEnable    = ubool True-    , atomSubs      = []-    , atomPeriod    = gPeriod g-    , atomAssigns   = []-    , atomActions   = []-    })+buildAtom g name (Atom f) = f (g { gId = gId g + 1 }, AtomDB+  { atomId        = gId g+  , atomName      = name+  , atomNames     = []+  , atomEnable    = ubool True+  , atomSubs      = []+  , atomPeriod    = gPeriod g+  , atomAssigns   = []+  , atomActions   = []+  }) +-- | The Atom monad holds variable and rule declarations.+data Atom a = Atom ((Global, AtomDB) -> IO (a, (Global, AtomDB))) --- | The 'Atom' container holds top level IO, 'Var', and 'Rule' definitions.-type Atom = StateT (Global, AtomDB) IO+instance Monad Atom where+  return a = Atom (\ s -> return (a, s))+  (Atom f1) >>= f2 = Atom f3+    where+    f3 s = do+      (a, s) <- f1 s+      let Atom f4 = f2 a+      f4 s +instance MonadIO Atom where+  liftIO io = Atom f+    where+    f s = do+      a <- io+      return (a, s)++get :: Atom (Global, AtomDB)+get = Atom (\ s -> return (s, s))++put :: (Global, AtomDB) -> Atom ()+put s = Atom (\ _ -> return ((), s))+ -- | A Relation is used for relative performance constraints between 'Action's. -- data Relation = Higher UID | Lower UID deriving (Show, Eq) @@ -169,15 +191,21 @@  ruleGraph :: Name -> [Rule] -> [UV] -> IO () ruleGraph name rules uvs = do-  putStrLn $ "Writinig rule graph (" ++ name ++ ".dot)..."+  putStrLn $ "Writing rule graph (" ++ name ++ ".dot)..."   writeFile (name ++ ".dot") g   --system $ "dot -o " ++ name ++ ".png -Tpng " ++ name ++ ".dot"   return ()   where+  adminUVs =+    [ UV (-1) "__clock" (External Word64)+    , UV (-2) "__coverage_index" (External Word32)+    , UV (-3) "__coverage[__coverage_index]" (External Word32)+    ]+   g = unlines     [ "digraph " ++ name ++ "{"     , concat [ "  r" ++ show (ruleId r) ++ " [label = \"" ++ show r ++ "\" shape = ellipse];\n" | r <- rules ]-    , concat [ "  v" ++ show i ++ " [label = \"" ++ n ++ "\" shape = box];\n" | (UV i n _) <- uvs ]+    , concat [ "  v" ++ show i ++ " [label = \"" ++ n ++ "\" shape = box];\n" | (UV i n _) <- adminUVs ++ uvs ]     , concat [ "  r" ++ show (ruleId r) ++ " -> v" ++ show i ++ "\n" | r <- rules,  (UV i _ _, _) <- ruleAssigns r ]     , concat [ "  v" ++ show i ++ " -> r" ++ show (ruleId r) ++ "\n" | r <- rules,  (UV i _ _) <- ruleUVRefs r ]     , "}"

@@ -8,29 +8,59 @@  -- | Invoke the atom compiler. compileExample :: IO ()-compileExample = compile "example" example+compileExample = compile "example" defaults { cPreCode = preCode, cPostCode = postCode } example --- | Example design introduces a unsigned 16-bit variable,---   and declares two rules: one to increment the variable,---   one to reset the variable back to zero when it hits 100.+preCode :: String+preCode = unlines+  [ "#include <stdlib.h>"+  , "#include <stdio.h>"+  , "unsigned long int a;"+  , "unsigned long int b;"+  , "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 %i and %i...\\n\", a, b);"+  , "  while(running) {"+  , "    example();"+  , "    printf(\"iteration:  a = %i  b = %i\\n\", a, b);"+  , "  }"+  , "  printf(\"GCD result: %i\\n\", a);"+  , "  return 0;"+  , "}"+  ]+++-- | An example design that computes the greatest common divisor. example :: Atom ()-example = period 2 $ do   -- Set execution period as a factor of 2 of the base rate.+example = do -  -- A local state variable.-  count <- word64 "count" 0+  -- External reference to value A.+  a <- word32' "a" -  -- An external variable.-  reset <- bool' "reset"+  -- External reference to value B.+  b <- word32' "b" -  -- A rule to increment the count.-  atom "increment" $ do-    cond $ value count <. 100-    count <== value count + 1+  -- The external running flag.+  running <- bool' "running" -  -- A rule to reset the count.-  atom "reset" $ do-    cond $ value count ==. 100-    cond $ value reset-    count <== 0+  -- A rule to modify A.+  atom "a_minus_b" $ do+    cond $ value a >. value b+    a <== value a - value b++  -- A rule to modify B.+  atom "b_minus_a" $ do+    cond $ value b >. value a+    b <== value b - value a++  -- A rule to clear the running flag.+  atom "stop" $ do+    cond $ value a ==. value b+    running <== false  

@@ -57,7 +57,7 @@   , nextCoverage   ) where -import Control.Monad.State hiding (join)+import Control.Monad.Trans import Data.Int import Data.List import Data.Word@@ -68,8 +68,7 @@  infixr 1 <== --- | A Atom captures declarations including inputs, outputs, variables, and assertions---   and actions including guard conditions and variable assignments.+-- | The Atom monad captures variable and transition rule declarations. type Atom = E.Atom  -- | Creates a hierarical node, where each node could be a atomic rule.

@@ -1,3 +1,10 @@+atom 0.0.3    05/05/2009++- Set build-depends: process >= 1.0.1.1 for readProcess+- Traded e<n> variable names for __<n> in generated C code.+- Made Atom a monad.  Removed use of Control.Monad.State.+- Added Config type to configure C code generation.+ atom 0.0.2    04/26/2009  - Disabled Yices bounded model checking.  Removed search depth compile argument.

@@ -1,5 +1,5 @@ Name:           atom-Version:        0.0.2+Version:        0.0.3 Synopsis:       A DSL for embedded hard realtime applications. Description:    Atom is a Haskell DSL for designing hard realtime embedded programs.                 Based on conditional term rewriting, atom will compile@@ -16,7 +16,7 @@   RELEASE-NOTES  Library-  Build-Depends:   base, mtl, process+  Build-Depends:   base, mtl, process >= 1.0.1.1   Exposed-Modules:     Language.Atom,     Language.Atom.Code,