atom 0.0.4 → 0.0.5
raw patch · 14 files changed
+137/−103 lines, 14 filesdep ~basedep ~mtldep ~processsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, mtl, process
API changes (from Hackage documentation)
Files
- LICENSE +2/−0
- Language/Atom.hs +5/−4
- Language/Atom/Code.hs +32/−30
- Language/Atom/Common.hs +8/−9
- Language/Atom/Compile.hs +0/−1
- Language/Atom/Elaboration.hs +7/−6
- Language/Atom/Example.hs +0/−1
- Language/Atom/Expressions.hs +12/−11
- Language/Atom/Language.hs +4/−5
- Language/Atom/Scheduling.hs +3/−4
- RELEASE-NOTES +6/−0
- Setup.hs +0/−2
- Setup.lhs +8/−0
- atom.cabal +50/−30
LICENSE view
@@ -1,5 +1,7 @@ Copyright (c) Tom Hawkins 2007-2009 +Contributions from John Van Enk, Brian Lewis+ All rights reserved. Redistribution and use in source and binary forms, with or without
Language/Atom.hs view
@@ -1,7 +1,8 @@-{- | Atom is a Haskell DSL for designing hard realtime embedded programs.- Based on conditional term rewriting, atom will compile- a collection of atomic state transition rules- to a C program with constant memory use and deterministic execution time.+{- |+ Atom is a Haskell DSL for designing hard realtime embedded programs. Based+ on conditional term rewriting, atom will compile a collection of atomic state+ transition rules to a C program with constant memory use and deterministic+ execution time. -} module Language.Atom
Language/Atom/Code.hs view
@@ -38,7 +38,7 @@ showConst :: Const -> String showConst c = case c of- CBool c -> if c then "1" else "0" + CBool c -> if c then "1" else "0" CInt8 c -> show c CInt16 c -> show c CInt32 c -> show c@@ -85,31 +85,32 @@ where operands = map (fromJust . flip lookup ues) $ ueUpstream ue basic :: [String] -> String- basic operands = case ue of- UVRef (UV (Array ua@(UA _ n _) _)) -> arrayIndex config ua a ++ " /* " ++ n ++ " */ "- UVRef (UV (External n _)) -> n- UCast _ _ -> "(" ++ cType config (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 _ -> drop 4 $ concat [ " && " ++ a | a <- operands ]- UBWNot _ -> "~ " ++ a- UBWAnd _ _ -> a ++ " & " ++ b- UBWOr _ _ -> a ++ " | " ++ b- UShift _ n -> (if n >= 0 then a ++ " << " ++ show n else a ++ " >> " ++ show (0 - n))- 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 ++ "))"+ basic operands = concat $ case ue of+ UVRef (UV (Array ua@(UA _ n _) _)) -> [arrayIndex config ua a, " /* ", n, " */ "]+ UVRef (UV (External n _)) -> [n]+ UCast _ _ -> ["(", cType config (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- a = operands !! 0+ ct = cType config+ a = head operands b = operands !! 1 c = operands !! 2 @@ -125,9 +126,9 @@ [ cPreCode config , "static " ++ cType config Word64 ++ " __clock = 0;" , "static const " ++ cType config Word32 ++ " __coverage_len = " ++ show covLen ++ ";"- , "static " ++ cType config Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ drop 2 (concat $ replicate covLen ", 0") ++ "};"+ , "static " ++ cType config Word32 ++ " __coverage[" ++ show covLen ++ "] = {" ++ (concat $ intersperse ", " $ replicate covLen "0") ++ "};" , "static " ++ cType config Word32 ++ " __coverage_index = 0;"- , memoryInit config Word8 init8 ++ memoryInit config Word16 init16 ++ memoryInit config Word32 init32 ++ memoryInit config Word64 init64+ , 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) {" , concatMap codePeriod $ zip [1..] periods@@ -136,6 +137,8 @@ , cPostCode config ] + mi = memoryInit config+ rules = concat $ concat periods cov = unlines@@ -178,7 +181,7 @@ 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 topo rule = "/* " ++ show rule ++ " */\n" ++ "static void __r" ++ show (ruleId rule) ++ "(void) {\n" ++ concatMap (codeUE config ues " ") ues ++@@ -237,5 +240,4 @@ -- | Number of UE's computed in rule. ruleComplexity :: Rule -> Int-ruleComplexity rule = length $ topo 0 $ allUEs rule-+ruleComplexity = length . topo 0 . allUEs
Language/Atom/Common.hs view
@@ -34,7 +34,7 @@ startTimer :: Timer -> E Word64 -> Atom () startTimer (Timer t) time = t <== clock + time --- | True when a timer has completed.+-- | 'True' when a timer has completed. timerDone :: Timer -> E Bool timerDone (Timer t) = value t <=. clock @@ -70,7 +70,7 @@ -- | 1-D lookup table. X values out of table range are clipped at end Y values.--- Input table must be monitonically increasing in X.+-- Input table must be monotonically increasing in X. lookupTable :: FloatingE a => [(E a, E a)] -> E a -> E a lookupTable table x = mux (x >=. x1) y1 $ foldl f y0 table' where@@ -83,8 +83,9 @@ interp = (x - x0) * slope + y0 --- | Hysteresis returns true when then input exceeds max and false when--- the input is less than min. The state is held when the input is between min and max.+-- | Hysteresis returns 'True' when the input exceeds @max@ and 'False' when+-- the input is less than @min@. The state is held when the input is between+-- @min@ and @max@. -- -- > hysteresis name min max input hysteresis :: OrdE a => E a -> E a -> E a -> Atom (E Bool)@@ -112,7 +113,7 @@ writeChannel (Channel _ hasData) = do when $ not_ $ value hasData hasData <== true- + -- | Read data from a 'Channel'. A read will only suceed if the 'Channel' has data to be read. readChannel :: Channel a -> Action a readChannel (Channel a hasData) = do@@ -240,7 +241,7 @@ sum <- double 0 (high,low) <- priority- + rule "update" sum <== value sum + input low@@ -276,7 +277,7 @@ -- | Create 'ValidData' given the data and validity condition. validData :: a -> E Bool -> ValidData a-validData = ValidData +validData = ValidData -- | Get a valid data. Action is disabled if data is invalid. getValidData :: ValidData a -> Action a@@ -290,5 +291,3 @@ whenInvalid :: ValidData a -> Action () whenInvalid (ValidData _ v) = cond $ not_ v -}--
Language/Atom/Compile.hs view
@@ -27,4 +27,3 @@ putStrLn "Starting code generation..." hFlush stdout writeC name config schedule init-
Language/Atom/Elaboration.hs view
@@ -20,6 +20,7 @@ ) where import Control.Monad.Trans+import Data.Function (on) import Data.List import Data.Maybe import Data.Word@@ -31,7 +32,7 @@ -- | A name. type Name = String --- | A heirarchical name.+-- | A hierarchical name. type Path = [Name] data Global = Global@@ -65,10 +66,10 @@ } instance Show AtomDB where show = atomName-instance Eq AtomDB where a == b = atomId a == atomId b+instance Eq AtomDB where (==) = (==) `on` atomId instance Ord AtomDB where compare a b = compare (atomId a) (atomId b) instance Show Rule where show = ruleName-instance Eq Rule where a == b = ruleId a == ruleId b+instance Eq Rule where (==) = (==) `on` ruleId instance Ord Rule where compare a b = compare (ruleId a) (ruleId b) elaborateRules:: UE -> AtomDB -> [Rule]@@ -133,12 +134,12 @@ -- | A Relation is used for relative performance constraints between 'Action's. -- data Relation = Higher UID | Lower UID deriving (Show, Eq) --- | Given a top level name and design, elabortes design and returns a design database.+-- | 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 = do putStrLn "Starting atom elaboration..." hFlush stdout- (_, (g, atomDB)) <- buildAtom (Global { gId = 0, gInit8 = [], gInit16 = [], gInit32 = [], gInit64 = [], gProbes = [], gPeriod = 1 }) name atom+ (_, (g, atomDB)) <- buildAtom Global { gId = 0, gInit8 = [], gInit16 = [], gInit32 = [], gInit64 = [], gProbes = [], gPeriod = 1 } name atom let rules = reIdRules $ elaborateRules (ubool True) atomDB mapM_ checkEnable rules ok <- checkAssignConflicts atomDB@@ -151,7 +152,7 @@ | otherwise = return () checkAssignConflicts :: AtomDB -> IO Bool-checkAssignConflicts atom = do+checkAssignConflicts atom = if length vars /= length vars' then do putStrLn $ "ERROR: Atom " ++ show atom ++ " contains multiple assignments to the same variable(s)."
Language/Atom/Example.hs view
@@ -63,4 +63,3 @@ atom "stop" $ do cond $ value a ==. value b running <== false-
Language/Atom/Expressions.hs view
@@ -67,6 +67,7 @@ ) where import Data.Bits+import Data.Function (on) import Data.Int import Data.List import Data.Ratio@@ -137,7 +138,7 @@ | EWord64 (E Word64) | EFloat (E Float) | EDouble (E Double)- + data Variable = VBool (V Bool) | VInt8 (V Int8)@@ -150,8 +151,8 @@ | VWord64 (V Word64) | VFloat (V Float) | VDouble (V Double) deriving Eq- + -- | Variables updated by state transition rules. data V a = V UV deriving Eq @@ -195,7 +196,7 @@ show _ = error "Show (E a) not implemented" instance Expr a => Eq (E a) where- a == b = ue a == ue b+ (==) = (==) `on` ue -- | An untyped term. data UE@@ -451,13 +452,13 @@ negate a = 0 - a abs a = mux (a <. 0) (negate a) a signum a = mux (a ==. 0) 0 $ mux (a <. 0) (-1) 1- fromInteger i = Const $ fromInteger i+ fromInteger = Const . fromInteger instance (OrdE a, NumE a, Num a, Fractional a) => Fractional (E a) where (Const a) / (Const b) = Const $ a / b a / b = Div a b recip a = 1 / a- fromRational r = Const $ (fromInteger (numerator r)) / (fromInteger (denominator r))+ fromRational r = Const $ fromInteger (numerator r) / fromInteger (denominator r) {- instance (Num a, Fractional a, Floating a, FloatingE a) => Floating (E a) where@@ -495,8 +496,8 @@ shift (Const a) n = Const $ shift a n shift a n = Shift a n rotate = error "E rotate not supported."- bitSize a = width a- isSigned a = signed a+ bitSize = width+ isSigned = signed -- | True term. true :: E Bool@@ -593,17 +594,17 @@ -- | Returns the value of a 'V'. value :: V a -> E a-value a = VRef a+value = VRef -- | Conditional expression. ----- > mux test onTrue ofFalse+-- > mux test onTrue onFalse mux :: Expr a => E Bool -> E a -> E a -> E a mux = Mux -- | Array index to variable. (!) :: (Expr a, IntegralE b) => A a -> E b -> V a-(A ua) ! e = V $ UV $ Array ua $ ue e+(!) (A ua) = V . UV . Array ua . ue -- | Array index to expression. (!.) :: (Expr a, IntegralE b) => A a -> E b -> E a@@ -714,7 +715,7 @@ f _ = [] -- collect, sort, and return-reduceAnd terms = UAnd $ sort $ nub $ terms+reduceAnd terms = UAnd $ sort $ nub terms uor :: UE -> UE -> UE uor a b = unot (uand (unot a) (unot b))
Language/Atom/Language.hs view
@@ -67,7 +67,7 @@ -- | 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.+-- | Creates a hierarchical node, where each node could be a atomic rule. atom :: Name -> Atom a -> Atom a atom name design = do name <- addName name@@ -96,7 +96,7 @@ (g, _) <- get return $ gPeriod g --- | Returns the current atom heirarchical path.+-- | Returns the current atom hierarchical path. path :: Atom String path = do (_, atom) <- get@@ -241,7 +241,7 @@ instance Assign Double -- | Adds an enabling condition to an atom subtree of rules.--- This condition must be true before any rules in heirarchy+-- This condition must be true before any rules in hierarchy -- are allowed to execute. cond :: E Bool -> Atom () cond c = do@@ -255,6 +255,5 @@ -- | Rule coverage information. (current coverage index, coverage data) nextCoverage :: Atom (E Word32, E Word32) nextCoverage = do- action (\_ -> "__coverage_index = (__coverage_index + 1) % __coverage_len") []+ 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)-
Language/Atom/Scheduling.hs view
@@ -37,10 +37,10 @@ reportSchedule :: [[[Rule]]] -> String-reportSchedule s = "Rule Scheduling Report\n\n Period Cycle Exprs Rule\n ------ ----- ----- ----\n" ++ (concatMap reportPeriod) (zip [1..] s) +++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" ++- "Heirarchical Expression Count\n\n" +++ "Hierarchical Expression Count\n\n" ++ " Total Local Rule\n" ++ " ------ ------ ----\n" ++ reportUsage "" (usage $ concat $ concat s) ++@@ -65,7 +65,7 @@ totalComplexity (Usage _ n subs) = n + sum (map totalComplexity subs) usage :: [Rule] -> Usage-usage rules = head $ foldl insertUsage [] $ map usage' rules+usage = head . foldl insertUsage [] . map usage' usage' :: Rule -> Usage usage' rule = f $ split $ ruleName rule@@ -83,4 +83,3 @@ insertUsage [] u = [u] insertUsage (a@(Usage n1 i1 s1) : rest) b@(Usage n2 i2 s2) | n1 == n2 = Usage n1 (max i1 i2) (sort $ foldl insertUsage s1 s2) : rest | otherwise = a : insertUsage rest b-
RELEASE-NOTES view
@@ -1,3 +1,9 @@+atom 0.0.5 06/03/2009++- Fixed GHC seg fault issue related to Prelude.negate.+- C config types for float and double casts (John Van Enk).+- Improvements to docs, atom.cabal, and suggestions from hlint (Brian Lewis).+ atom 0.0.4 05/19/2009 - Made local variables static in generated C.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,8 @@+#! /usr/bin/env runhaskell++> module Main (main) where+>+> import Distribution.Simple (defaultMain)+>+> main :: IO ()+> main = defaultMain
atom.cabal view
@@ -1,33 +1,53 @@-Name: atom-Version: 0.0.4-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- a collection of atomic state transition rules- to a C program with constant memory use and deterministic execution time.-License: BSD3-License-File: LICENSE-Author: Tom Hawkins-Maintainer: tomahawkins@gmail.com-Category: Language-Build-Type: Simple-Cabal-Version: >= 1.2.3-Extra-Source-Files:+name: atom+version: 0.0.5++category: Language++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 a collection of atomic+ state transition rules to a C program with constant memory use and+ deterministic execution time.++author: Tom Hawkins <tomahawkins@gmail.com>+maintainer: Tom Hawkins <tomahawkins@gmail.com>++license: BSD3+license-file: LICENSE++homepage: http://patch-tag.com/r/atom/home++build-type: Simple+cabal-version: >= 1.6++extra-source-files: RELEASE-NOTES -Library- Build-Depends: base, mtl, process >= 1.0.1.1- Exposed-Modules:- Language.Atom,- Language.Atom.Code,- Language.Atom.Common,- Language.Atom.Compile,- Language.Atom.Elaboration,- Language.Atom.Example,- Language.Atom.Expressions,- Language.Atom.Language,- Language.Atom.Scheduling- extensions: GADTs- ghc-options: -W- Other-Modules: +library+ build-depends:+ base >= 4 && < 5,+ mtl >= 1.1.0.1 && < 1.2,+ process >= 1.0.1.1 && < 1.2 + exposed-modules:+ Language.Atom+ Language.Atom.Code+ Language.Atom.Common+ Language.Atom.Compile+ Language.Atom.Elaboration+ Language.Atom.Example+ Language.Atom.Expressions+ Language.Atom.Language+ Language.Atom.Scheduling++ extensions: GADTs++ if impl(ghc > 6.8)+ ghc-options: -fwarn-tabs+ ghc-options: -W++source-repository head+ type: darcs+ location: http://patch-tag.com/r/atom/pullrepo