Permalink
Browse files

first atom commit

  • Loading branch information...
0 parents commit 3551040551a1eee8ebe610d49f0929ce2122e9be @tomahawkins tomahawkins committed Feb 23, 2010
27 LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) Tom Hawkins 2007-2010
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
@@ -0,0 +1,24 @@
+{- |
+ Atom is a Haskell DSL for designing hard realtime embedded software.
+ Based on guarded atomic actions (similar to STM), Atom enables highly
+ concurrent programming without the need for mutex locking.
+ In addition, Atom performs compile-time task scheduling and generates code
+ with deterministic execution time and constant memory use, simplifying the
+ process of timing verification and memory consumption in hard realtime
+ applications. Without mutex locking and run-time task scheduling,
+ Atom eliminates the need and overhead of RTOSs for many embedded applications.
+-}
+
+module Language.Atom
+ ( module Language.Atom.Code
+ , 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,25 @@
+module Language.Atom.Analysis
+ ( topo
+ , ruleComplexity
+ ) where
+
+import Language.Atom.Elaboration
+import Language.Atom.Expressions
+
+-- | Topologically sorts a list of expressions and subexpressions.
+topo :: [UE] -> [(UE, String)]
+topo ues = reverse ues'
+ where
+ start = 0
+ (_, 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 . allUEs
+
@@ -0,0 +1,236 @@
+-- | Atom C code generation.
+module Language.Atom.Code
+ ( Config (..)
+ , writeC
+ , defaults
+ , cType
+ , RuleCoverage
+ ) where
+
+import Data.List
+import Data.Maybe
+import Text.Printf
+
+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.
+ , cStateName :: String -- ^ Name of state variable structure. Default: state
+ , 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 assertions and functional coverage.
+ , cAssertName :: String -- ^ Name of assertion function. Type: void assert(int, bool, uint64_t);
+ , cCoverName :: String -- ^ Name of coverage function. Type: void cover(int, bool, uint64_t);
+ }
+
+-- | Default C code configuration parameters (default function name, no pre/post code, ANSI C types).
+defaults :: Config
+defaults = Config
+ { cFuncName = ""
+ , cStateName = "state"
+ , cCode = \ _ _ _ -> ("", "")
+ , cRuleCoverage = True
+ , cAssert = True
+ , cAssertName = "assert"
+ , cCoverName = "cover"
+ }
+
+showConst :: Const -> String
+showConst c = case c of
+ CBool True -> "true"
+ CBool False -> "false"
+ 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 a ++ "F"
+ CDouble a -> show a
+
+
+-- | C99 type naming rules.
+cType :: Type -> String
+cType t = case t of
+ Bool -> "bool"
+ 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) = d ++ cType (typeOf ue) ++ " " ++ n ++ " = " ++ basic operands ++ ";\n"
+ where
+ operands = map (fromJust . flip lookup ues) $ ueUpstream ue
+ basic :: [String] -> String
+ basic operands = concat $ case ue of
+ UVRef (UV _ n _) -> [cStateName config, ".", n]
+ UVRef (UVArray (UA _ n _) _) -> [cStateName config, ".", n, "[", a, "]"]
+ UVRef (UVArray (UAExtern n _) _) -> [n, "[", a, "]"]
+ UVRef (UVExtern n _) -> [n]
+ UCast _ _ -> ["(", cType (typeOf ue), ") ", a]
+ UConst c -> [showConst c]
+ UAdd _ _ -> [a, " + ", b]
+ USub _ _ -> [a, " - ", b]
+ UMul _ _ -> [a, " * ", b]
+ UDiv _ _ -> [a, " / ", b]
+ UMod _ _ -> [a, " % ", b]
+ UNot _ -> ["! ", a]
+ UAnd _ -> intersperse " && " operands
+ UBWNot _ -> ["~ ", a]
+ UBWAnd _ _ -> [a, " & ", b]
+ UBWOr _ _ -> [a, " | ", b]
+ UShift _ n -> (if n >= 0 then [a, " << ", show n] else [a, " >> ", show (negate n)])
+ UEq _ _ -> [a, " == ", b]
+ ULt _ _ -> [a, " < " , b]
+ UMux _ _ _ -> [a, " ? " , b, " : ", c]
+ UF2B _ -> ["*((", ct Word32, " *) &(", a, "))"]
+ UD2B _ -> ["*((", ct Word64, " *) &(", a, "))"]
+ UB2F _ -> ["*((", ct Float , " *) &(", a, "))"]
+ UB2D _ -> ["*((", ct Double, " *) &(", a, "))"]
+ where
+ ct = cType
+ a = head operands
+ b = operands !! 1
+ c = operands !! 2
+
+type RuleCoverage = [(Name, Int, Int)]
+
+writeC :: Name -> Config -> StateHierarchy -> [Rule] -> Schedule -> [Name] -> [Name] -> [(Name, Type)] -> IO RuleCoverage
+writeC name config state rules schedule assertionNames coverageNames probeNames = do
+ writeFile (name ++ ".c") c
+ writeFile (name ++ ".h") h
+ return [ (ruleName r, div (ruleId r) 32, mod (ruleId r) 32) | r <- rules' ]
+ where
+ (preCode, postCode) = cCode config assertionNames coverageNames probeNames
+ c = unlines
+ [ "#include <stdbool.h>"
+ , "#include <stdint.h>"
+ , ""
+ , preCode
+ , ""
+ , "static " ++ cType Word64 ++ " __global_clock = 0;"
+ , codeIf (cRuleCoverage config) $ "static const " ++ cType Word32 ++ " __coverage_len = " ++ show covLen ++ ";"
+ , codeIf (cRuleCoverage config) $ "static " ++ cType Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ (concat $ intersperse ", " $ replicate covLen "0") ++ "};"
+ , codeIf (cRuleCoverage config) $ "static " ++ cType Word32 ++ " __coverage_index = 0;"
+ , declState True $ StateHierarchy (cStateName config) [state]
+ , concatMap (codeRule config) rules'
+ , codeAssertionChecks config assertionNames coverageNames rules
+ , "void " ++ funcName ++ "() {"
+ , concatMap (codePeriodPhase config) schedule
+ , " __global_clock = __global_clock + 1;"
+ , "}"
+ , ""
+ , postCode
+ ]
+
+ h = unlines
+ [ "#include <stdbool.h>"
+ , "#include <stdint.h>"
+ , ""
+ , "void " ++ funcName ++ "();"
+ , ""
+ , declState False $ StateHierarchy (cStateName config) [state]
+ ]
+
+ funcName = if null (cFuncName config) then name else cFuncName config
+
+ rules' :: [Rule]
+ rules' = concat [ r | (_, _, r) <- schedule ]
+
+ covLen = 1 + div (maximum $ map ruleId rules') 32
+
+codeIf :: Bool -> String -> String
+codeIf a b = if a then b else ""
+
+declState :: Bool -> StateHierarchy -> String
+declState define a = (if define then "" else "extern ") ++ init (init (f1 "" a)) ++ (if define then " =\n" ++ f2 "" a else "") ++ ";\n"
+ where
+ f1 i a = case a of
+ StateHierarchy name items -> i ++ "struct { /* " ++ name ++ " */\n" ++ concatMap (f1 (" " ++ i)) items ++ i ++ "} " ++ name ++ ";\n"
+ StateVariable name c -> i ++ cType (typeOf c) ++ " " ++ name ++ ";\n"
+ StateArray name c -> i ++ cType (typeOf $ head c) ++ " " ++ name ++ "[" ++ show (length c) ++ "];\n"
+
+ f2 i a = case a of
+ StateHierarchy name items -> i ++ "{ /* " ++ name ++ " */\n" ++ intercalate ",\n" (map (f2 (" " ++ i)) items) ++ "\n" ++ i ++ "}"
+ StateVariable name c -> i ++ "/* " ++ name ++ " */ " ++ showConst c
+ StateArray name c -> i ++ "/* " ++ name ++ " */ {" ++ intercalate ", " (map showConst c) ++ "}"
+
+codeRule :: Config -> Rule -> String
+codeRule config rule@(Rule _ _ _ _ _ _ _) =
+ "/* " ++ show rule ++ " */\n" ++
+ "static void __r" ++ show (ruleId rule) ++ "() {\n" ++
+ concatMap (codeUE config ues " ") ues ++
+ " if (" ++ id (ruleEnable rule) ++ ") {\n" ++
+ concatMap codeAction (ruleActions rule) ++
+ codeIf (cRuleCoverage config) (" __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord ++ "] | (1 << " ++ covBit ++ ");\n") ++
+ " }\n" ++
+ concatMap codeAssign (ruleAssigns rule) ++
+ "}\n\n"
+ where
+ ues = topo $ allUEs rule
+ id ue = fromJust $ lookup ue ues
+
+ codeAction :: (([String] -> String), [UE]) -> String
+ codeAction (f, args) = " " ++ f (map id args) ++ ";\n"
+
+ covWord = show $ div (ruleId rule) 32
+ covBit = show $ mod (ruleId rule) 32
+
+ codeAssign :: (UV, UE) -> String
+ codeAssign (uv, ue) = concat [" ", lh, " = ", id ue, ";\n"]
+ where
+ lh = case uv of
+ UV _ n _ -> concat [cStateName config, ".", n]
+ UVArray (UA _ n _) index -> concat [cStateName config, ".", n, "[", id index, "]"]
+ UVArray (UAExtern n _) index -> concat [n, "[", id index, "]"]
+ UVExtern n _ -> n
+
+codeRule _ _ = ""
+
+codeAssertionChecks :: Config -> [Name] -> [Name] -> [Rule] -> String
+codeAssertionChecks config assertionNames coverageNames rules = codeIf (cAssert config) $
+ "static void __assertion_checks() {\n" ++
+ concatMap (codeUE config ues " ") ues ++
+ concat [ " if (" ++ id enable ++ ") " ++ cAssertName config ++ "(" ++ assertionId name ++ ", " ++ id check ++ ", __global_clock);\n" | Assert name enable check <- rules ] ++
+ concat [ " if (" ++ id enable ++ ") " ++ cCoverName config ++ "(" ++ coverageId name ++ ", " ++ id check ++ ", __global_clock);\n" | Cover name enable check <- rules ] ++
+ "}\n\n"
+ where
+ ues = topo $ concat [ [a, b] | Assert _ a b <- rules ] ++ concat [ [a, b] | Cover _ a b <- rules ]
+ 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
+
+codePeriodPhase :: Config -> (Int, Int, [Rule]) -> String
+codePeriodPhase config (period, phase, rules) = unlines
+ [ printf " {"
+ , printf " static %s __scheduling_clock = %i;" (cType clockType) phase
+ , printf " if (__scheduling_clock == 0) {"
+ , intercalate "\n" $ map callRule rules
+ , printf " __scheduling_clock = %i;" (period - 1)
+ , printf " }"
+ , printf " else {"
+ , printf " __scheduling_clock = __scheduling_clock - 1;"
+ , printf " }"
+ , printf " }"
+ ]
+ where
+ clockType | period < 2 ^ 8 = Word8
+ | period < 2 ^ 16 = Word16
+ | otherwise = Word32
+ callRule r = concat [" ", codeIf (cAssert config) "__assertion_checks(); ", "__r", show (ruleId r), "(); /* ", show r, " */"]
+
Oops, something went wrong.

0 comments on commit 3551040

Please sign in to comment.