Permalink
Browse files

first atom commit

  • Loading branch information...
0 parents commit 3551040551a1eee8ebe610d49f0929ce2122e9be @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.
24 Language/Atom.hs
@@ -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
25 Language/Atom/Analysis.hs
@@ -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
+
236 Language/Atom/Code.hs
@@ -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, " */"]
+
309 Language/Atom/Common.hs
@@ -0,0 +1,309 @@
+-- | Common Atom functions.
+module Language.Atom.Common
+ (
+ -- * Timers
+ Timer
+ , timer
+ , startTimer
+ , startTimerIf
+ , timerDone
+ -- * One Shots
+ , oneShotRise
+ , oneShotFall
+ -- * Debouncing
+ , debounce
+ -- * Lookup Tables
+ , lookupTable
+ , linear
+ -- * Hysteresis
+ , hysteresis
+ ) where
+
+import Data.Word
+
+import Language.Atom.Language
+
+-- | A Timer.
+data Timer = Timer (V Word64)
+
+-- | Creates a new timer.
+timer :: Name -> Atom Timer
+timer name = do
+ timer <- word64 name 0
+ return $ Timer timer
+
+-- | Starts a Timer. A timer can be restarted at any time.
+startTimer :: Timer -> E Word64 -> Atom ()
+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
+timerDone (Timer t) = value t <=. clock
+
+
+-- | One-shot on a rising transition.
+oneShotRise :: E Bool -> Atom (E Bool)
+oneShotRise a = do
+ last <- bool "last" False
+ last <== a
+ return $ a &&. not_ (value last)
+
+-- | One-shot on a falling transition.
+oneShotFall :: E Bool -> Atom (E Bool)
+oneShotFall = oneShotRise . not_
+
+
+-- | Debounces a boolean given an on and off time (ticks) and an initial state.
+debounce :: Name -> E Word64 -> E Word64 -> Bool -> E Bool -> Atom (E Bool)
+debounce name onTime offTime init a = atom name $ do
+ last <- bool "last" init
+ out <- bool "out" init
+ timer <- timer "timer"
+ atom "on" $ do
+ cond $ a &&. not_ (value last)
+ startTimer timer onTime
+ last <== a
+ atom "off" $ do
+ cond $ not_ a &&. value last
+ startTimer timer offTime
+ last <== a
+ atom "set" $ do
+ cond $ a ==. value last
+ cond $ timerDone timer
+ out <== value last
+ return $ value out
+
+
+-- | 1-D lookup table. X values out of table range are clipped at end Y values.
+-- 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
+ (_, y0) = head table
+ (x1, y1) = last table
+ table' = zip (init table) (tail table)
+ f a ((x0,y0),(x1,y1)) = mux (x >=. x0) interp a
+ where
+ slope = (y1 - y0) / (x1 - x0)
+ interp = (x - x0) * slope + y0
+
+-- | Linear extrapolation and interpolation on a line with 2 points.
+-- The two x points must be different to prevent a divide-by-zero.
+linear :: FloatingE a => (E a, E a) -> (E a, E a) -> E a -> E a
+linear (x1, y1) (x2, y2) a = slope * a + inter
+ where
+ slope = y2 - y1 / x2 - x1
+ inter = y1 - slope * x1
+
+-- | 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)
+hysteresis a b u = do
+ s <- bool "s" False
+ s <== (mux (u >. max) true $ mux (u <. min) false $ value s)
+ return $ value s
+ where
+ min = min_ a b
+ max = max_ a b
+
+{-
+
+-- | A channel is a uni-directional communication link that ensures one read for every write.
+data Channel a = Channel a (V Bool)
+
+-- | Creates a new channel, with a given name and data.
+channel :: a -> Atom (Channel a)
+channel a = do
+ hasData <- bool False
+ return $ Channel a hasData
+
+-- | Write data to a 'Channel'. A write will only suceed if the 'Channel' is empty.
+writeChannel :: Channel a -> Action ()
+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
+ when $ value hasData
+ hasData <== false
+ return a
+
+-- | Fades one signal to another.
+module Language.Atom.Common.Fader
+ ( Fader
+ , FaderInit (..)
+ , fader
+ , fadeToA
+ , fadeToB
+ , fadeToCenter
+ ) where
+
+import Language.Atom
+
+-- | Fader object.
+data Fader = Fader (V Int)
+
+-- | Fader initalization.
+data FaderInit = OnA | OnB | OnCenter
+
+toA = 0
+toB = 1
+toCenter = 2
+
+-- | Fader construction. Name, fade rate, fader init, and signal A and B.
+fader :: Name -> Double -> FaderInit -> E Double -> E Double -> Atom (Fader, E Double)
+fader name rate init a b = scope name $ do
+ --assert "positiveRate" $ rate >= 0
+
+ target <- int (case init of {OnA -> toA; OnB -> toB; OnCenter -> toCenter})
+ perA <- double (case init of {OnA -> 1; OnB -> 0; OnCenter -> 0.5})
+
+ rule "toA" $ do
+ when $ value target ==. intC toA
+ when $ value perA <. 1
+ perA <== mux (1 - value perA <. doubleC rate) 1 (value perA + doubleC rate)
+
+ rule "toB" $ do
+ when $ value target ==. intC toB
+ when $ value perA >. 0
+ perA <== mux (value perA <. doubleC rate) 0 (value perA - doubleC rate)
+
+ rule "toCenterFrom0" $ do
+ when $ value target ==. intC toCenter
+ when $ value perA <. 0.5
+ perA <== mux (0.5 - value perA <. doubleC rate) 0.5 (value perA + doubleC rate)
+
+ rule "toCenterFrom1" $ do
+ when $ value target ==. intC toCenter
+ when $ value perA >. 0.5
+ perA <== mux (value perA - 0.5 <. doubleC rate) 0.5 (value perA - doubleC rate)
+
+ return (Fader target, (a * value perA + b * (1 - value perA)) / 2)
+
+-- | Fade to signal A.
+fadeToA :: Fader -> Action ()
+fadeToA (Fader target) = target <== intC toA
+
+-- | Fade to signal B.
+fadeToB :: Fader -> Action ()
+fadeToB (Fader target) = target <== intC toB
+
+-- | Fade to center, ie average of signal A and B.
+fadeToCenter :: Fader -> Action ()
+fadeToCenter (Fader target) = target <== intC toCenter
+
+module Language.Atom.Common.Process
+ ( Process (..)
+ , process
+ ) where
+
+import Language.Atom
+
+data Process
+ = Par [Process]
+ | Seq [Process]
+ | Alt [Process]
+ | Rep Process
+ | Act Action
+
+process :: Name -> Process -> Atom ()
+
+-- | Time integrated threshold functions typically used in condition monitoring.
+module Language.Atom.Common.Threshold
+ ( boolThreshold
+ , floatingThreshold
+ ) where
+
+import Language.Atom
+
+
+-- | Boolean thresholding over time. Output is set when internal counter hits limit, and cleared when counter is 0.
+boolThreshold :: Name -> Int -> Bool -> E Bool -> Atom (E Bool)
+boolThreshold name num init input = scope name $ do
+ --assert "positiveNumber" $ num >= 0
+
+ state <- bool init
+ count <- int (if init then num else 0)
+
+ rule "update" $ do
+ when $ value count >. 0 &&. value count <. num
+ count <== value count + mux input 1 (-1)
+
+ rule "low" $ do
+ when $ value count ==. 0
+ state <== false
+
+ rule "high" $ do
+ when $ value count ==. intC num
+ state <== true
+
+ return $ value state
+
+-- | Integrating threshold. Output is set with integral reaches limit, and cleared when integral reaches 0.
+doubleThreshold :: Name -> Double -> E Double -> Atom (E Bool)
+doubleThreshold name lim input = scope name $ do
+ --assert "positiveLimit" $ lim >= 0
+
+ state <- bool False
+ sum <- double 0
+
+ (high,low) <- priority
+
+ rule "update"
+ sum <== value sum + input
+ low
+
+ rule "clear" $ do
+ when $ value sum <=. 0
+ state <== false
+ sum <== 0
+ high
+
+ rule "set" $ do
+ when $ value sum >=. doubleC lim
+ state <== true
+ sum <== doubleC lim
+ high
+
+ return $ value state
+
+-- | Capturing data that can either be valid or invalid.
+module Language.Atom.Common.ValidData
+ ( ValidData
+ , validData
+ , getValidData
+ , whenValid
+ , whenInvalid
+ ) where
+
+import Language.Atom
+
+-- | 'ValidData' captures the data and its validity condition.
+-- 'ValidData' is abstract to prevent rules from using invalid data.
+data ValidData a = ValidData a (E Bool)
+
+-- | Create 'ValidData' given the data and validity condition.
+validData :: a -> E Bool -> ValidData a
+validData = ValidData
+
+-- | Get a valid data. Action is disabled if data is invalid.
+getValidData :: ValidData a -> Action a
+getValidData (ValidData a v) = cond v >> return a
+
+-- | Action enabled if 'ValidData' is valid.
+whenValid :: ValidData a -> Action ()
+whenValid (ValidData _ v) = cond v
+
+-- | Action enabled if 'ValidData' is not valid.
+whenInvalid :: ValidData a -> Action ()
+whenInvalid (ValidData _ v) = cond $ not_ v
+-}
25 Language/Atom/Compile.hs
@@ -0,0 +1,25 @@
+-- | Atom compilation.
+module Language.Atom.Compile
+ ( compile
+ , reportSchedule
+ , Schedule
+ ) where
+
+import System.Exit
+
+import Language.Atom.Code
+import Language.Atom.Scheduling
+import Language.Atom.Elaboration
+import Language.Atom.Language hiding (Atom)
+
+-- | Compiles an atom description to C.
+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 (state, rules, assertionNames, coverageNames, probeNames) -> do
+ let schedule' = schedule rules
+ ruleCoverage <- writeC name config state rules schedule' assertionNames coverageNames probeNames
+ return (schedule', ruleCoverage, assertionNames, coverageNames, probeNames)
+
331 Language/Atom/Elaboration.hs
@@ -0,0 +1,331 @@
+module Language.Atom.Elaboration
+ (
+ -- * Atom monad and container.
+ Atom
+ , AtomDB (..)
+ , Global (..)
+ , Rule (..)
+ , StateHierarchy (..)
+ , buildAtom
+ -- * Type Aliases and Utilities
+ , UID
+ , Name
+ , Path
+ , elaborate
+ , var
+ , var'
+ , array
+ , array'
+ , addName
+ , get
+ , put
+ , allUVs
+ , allUEs
+ ) where
+
+import Control.Monad.Trans
+import Data.Function (on)
+import Data.List
+import Language.Atom.Expressions
+
+type UID = Int
+
+-- | A name.
+type Name = String
+
+-- | A hierarchical name.
+type Path = [Name]
+
+data Global = Global
+ { gRuleId :: Int
+ , gVarId :: Int
+ , gArrayId :: Int
+ , gState :: [StateHierarchy]
+ , gProbes :: [(String, UE)]
+ , gPeriod :: Int
+ , gPhase :: Int
+ }
+
+data AtomDB = AtomDB
+ { atomId :: Int
+ , atomName :: Name
+ , atomNames :: [Name] -- Names used at this level.
+ , atomEnable :: UE -- Enabling condition.
+ , atomSubs :: [AtomDB] -- Sub atoms.
+ , atomPeriod :: Int
+ , atomPhase :: Int
+ , atomAssigns :: [(UV, UE)]
+ , atomActions :: [([String] -> String, [UE])]
+ , atomAsserts :: [(Name, UE)]
+ , atomCovers :: [(Name, UE)]
+ }
+
+data Rule
+ = Rule
+ { ruleId :: Int
+ , ruleName :: Name
+ , ruleEnable :: UE
+ , ruleAssigns :: [(UV, UE)]
+ , ruleActions :: [([String] -> String, [UE])]
+ , rulePeriod :: Int
+ , rulePhase :: Int
+ }
+ | Assert
+ { ruleName :: Name
+ , ruleEnable :: UE
+ , ruleAssert :: UE
+ }
+ | Cover
+ { ruleName :: Name
+ , ruleEnable :: UE
+ , ruleCover :: UE
+ }
+
+data StateHierarchy
+ = StateHierarchy Name [StateHierarchy]
+ | StateVariable Name Const
+ | StateArray Name [Const]
+
+instance Show AtomDB where show = atomName
+instance Eq AtomDB where (==) = (==) `on` atomId
+instance Ord AtomDB where compare a b = compare (atomId a) (atomId b)
+instance Show Rule where show = ruleName
+
+elaborateRules:: UE -> AtomDB -> [Rule]
+elaborateRules parentEnable atom = if isRule then rule : rules else rules
+ where
+ isRule = not $ null (atomAssigns atom) && null (atomActions atom)
+ enable = uand parentEnable $ atomEnable atom
+ rule = Rule
+ { ruleId = atomId atom
+ , ruleName = atomName atom
+ , ruleEnable = enable
+ , ruleAssigns = map enableAssign $ atomAssigns atom
+ , ruleActions = atomActions atom
+ , rulePeriod = atomPeriod atom
+ , rulePhase = atomPhase atom
+ }
+ assert (name, ue) = Assert
+ { ruleName = name
+ , ruleEnable = enable
+ , ruleAssert = ue
+ }
+ cover (name, ue) = Cover
+ { ruleName = name
+ , ruleEnable = enable
+ , ruleCover = ue
+ }
+ rules = map assert (atomAsserts atom) ++ map cover (atomCovers atom) ++ concatMap (elaborateRules enable) (atomSubs atom)
+ enableAssign :: (UV, UE) -> (UV, UE)
+ enableAssign (uv, ue) = (uv, umux enable ue $ UVRef uv)
+
+reIdRules :: Int -> [Rule] -> [Rule]
+reIdRules _ [] = []
+reIdRules i (a:b) = case a of
+ Rule _ _ _ _ _ _ _ -> a { ruleId = i } : reIdRules (i + 1) b
+ _ -> a : reIdRules i b
+
+buildAtom :: Global -> Name -> Atom a -> IO (a, (Global, AtomDB))
+buildAtom g name (Atom f) = f (g { gRuleId = gRuleId g + 1 }, AtomDB
+ { atomId = gRuleId g
+ , atomName = name
+ , atomNames = []
+ , atomEnable = ubool True
+ , atomSubs = []
+ , atomPeriod = gPeriod g
+ , atomPhase = gPhase g
+ , atomAssigns = []
+ , atomActions = []
+ , atomAsserts = []
+ , atomCovers = []
+ })
+
+-- | The Atom monad holds variable and rule declarations.
+data Atom a = Atom ((Global, AtomDB) -> IO (a, (Global, AtomDB)))
+
+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)
+
+-- | Given a top level name and design, elaborates design and returns a design database.
+elaborate :: Name -> Atom () -> IO (Maybe (StateHierarchy, [Rule], [Name], [Name], [(Name, Type)]))
+elaborate name atom = do
+ (_, (g, atomDB)) <- buildAtom Global { gRuleId = 0, gVarId = 0, gArrayId = 0, gState = [], gProbes = [], gPeriod = 1, gPhase = 0 } name atom
+ let rules = reIdRules 0 $ elaborateRules (ubool True) atomDB
+ coverageNames = [ name | Cover name _ _ <- rules ]
+ assertionNames = [ name | Assert name _ _ <- rules ]
+ probeNames = [ (n, typeOf a) | (n, a) <- gProbes g ]
+ if (null rules)
+ then do
+ putStrLn "ERROR: Design contains no rules. Nothing to do."
+ return Nothing
+ else do
+ mapM_ checkEnable rules
+ ok <- mapM checkAssignConflicts rules
+ return (if and ok then Just (trimState $ StateHierarchy name $ gState g, rules, assertionNames, coverageNames, probeNames) else Nothing)
+
+trimState :: StateHierarchy -> StateHierarchy
+trimState a = case a of
+ StateHierarchy name items -> StateHierarchy name $ filter f $ map trimState items
+ a -> a
+ where
+ f (StateHierarchy _ []) = False
+ f _ = True
+
+
+-- | 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 ()
+
+-- | 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@(Rule _ _ _ _ _ _ _) =
+ if length vars /= length vars'
+ then do
+ putStrLn $ "ERROR: Rule " ++ show rule ++ " contains multiple assignments to the same variable(s)."
+ return False
+ else do
+ return True
+ where
+ vars = fst $ unzip $ ruleAssigns rule
+ vars' = nub vars
+checkAssignConflicts _ = return True
+
+{-
+-- | 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
+ name' <- addName name
+ (g, atom) <- get
+ let uv = UV (gVarId g) name' c
+ c = constant init
+ put (g { gVarId = gVarId g + 1, gState = gState g ++ [StateVariable name c] }, atom)
+ return $ V uv
+
+-- | Generic external variable declaration.
+var' :: Name -> Type -> V a
+var' name t = V $ UVExtern name t
+
+-- | Generic array declaration.
+array :: Expr a => Name -> [a] -> Atom (A a)
+array name [] = error $ "ERROR: arrays can not be empty: " ++ name
+array name init = do
+ name' <- addName name
+ (g, atom) <- get
+ let ua = UA (gArrayId g) name' c
+ c = map constant init
+ put (g { gArrayId = gArrayId g + 1, gState = gState g ++ [StateArray name c] }, atom)
+ return $ A ua
+
+-- | Generic external array declaration.
+array' :: Expr a => Name -> Type -> A a
+array' name t = A $ UAExtern name t
+
+addName :: Name -> Atom Name
+addName name = do
+ (g, atom) <- get
+ if elem name (atomNames atom)
+ then error $ "ERROR: Name \"" ++ name ++ "\" not unique in " ++ show atom ++ "."
+ else do
+ put (g, atom { atomNames = name : atomNames atom })
+ return $ atomName atom ++ "." ++ name
+
+{-
+ruleGraph :: Name -> [Rule] -> [UV] -> IO ()
+ruleGraph name rules uvs = do
+ 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 _) <- 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 ]
+ , "}"
+ ]
+
+ ruleUVRefs r = nub $ concatMap uvSet ues
+ 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 = concat [ ruleAssigns r | r@(Rule _ _ _ _ _ _ _) <- 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 : ues
+ where
+ index :: UV -> [UE]
+ index (UVArray _ ue) = [ue]
+ index _ = []
+ ues = case rule of
+ Rule _ _ _ _ _ _ _ -> concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ] ++ concat (snd (unzip (ruleActions rule)))
+ Assert _ _ a -> [a]
+ Cover _ _ a -> [a]
+
72 Language/Atom/Example.hs
@@ -0,0 +1,72 @@
+-- | An example atom design.
+module Language.Atom.Example
+ ( compileExample
+ , example
+ ) where
+
+import Language.Atom
+
+-- | Invoke the atom compiler.
+compileExample :: IO ()
+compileExample = do
+ (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 ()
+example = do
+
+ -- External reference to value A.
+ let a = word32' "a"
+
+ -- External reference to value B.
+ let b = word32' "b"
+
+ -- The external running flag.
+ let running = bool' "running"
+
+ -- 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
+
911 Language/Atom/Expressions.hs
@@ -0,0 +1,911 @@
+module Language.Atom.Expressions
+ (
+ -- * Types
+ E (..)
+ , V (..)
+ , UE (..)
+ , UV (..)
+ , A (..)
+ , UA (..)
+ , Expr (..)
+ , Expression (..)
+ , Variable (..)
+ , Type (..)
+ , Const (..)
+ , Width (..)
+ , TypeOf (..)
+ , bytes
+ , ue
+ , uv
+ , ueUpstream
+ , nearestUVs
+ , arrayIndices
+ , NumE
+ , IntegralE
+ , FloatingE
+ , EqE
+ , OrdE
+ -- * Constants
+ , true
+ , false
+ -- * Variable Reference and Assignment
+ , value
+ -- * Logical Operations
+ , not_
+ , (&&.)
+ , (||.)
+ , and_
+ , or_
+ , any_
+ , all_
+ , imply
+ -- * Equality and Comparison
+ , (==.)
+ , (/=.)
+ , (<.)
+ , (<=.)
+ , (>.)
+ , (>=.)
+ , min_
+ , minimum_
+ , max_
+ , maximum_
+ , limit
+ -- * Arithmetic Operations
+ , div_
+ , div0_
+ , mod_
+ , mod0_
+ -- * Conditional Operator
+ , mux
+ -- * Array Indexing
+ , (!)
+ , (!.)
+ -- * Smart constructors for untyped expressions.
+ , ubool
+ , unot
+ , uand
+ , uor
+ , ueq
+ , umux
+ ) where
+
+import Data.Bits
+import Data.Function (on)
+import Data.Int
+import Data.List
+import Data.Ratio
+import Data.Word
+
+--infixl 7 /., %.
+--infixl 6 +., -.
+--infixr 5 ++.
+infixl 9 !, !.
+infix 4 ==., /=., <., <=., >., >=.
+infixl 3 &&. --, ^. -- , &&&, $&, $&&
+infixl 2 ||. -- , |||, $$, $:, $|
+--infixr 1 -- <==, <-- -- , |->, |=>, -->
+
+-- | The type of a 'E'.
+data Type
+ = Bool
+ | Int8
+ | Int16
+ | Int32
+ | Int64
+ | Word8
+ | Word16
+ | Word32
+ | Word64
+ | Float
+ | Double
+ deriving (Show, Read, Eq, Ord)
+
+data Const
+ = CBool Bool
+ | CInt8 Int8
+ | CInt16 Int16
+ | CInt32 Int32
+ | CInt64 Int64
+ | CWord8 Word8
+ | CWord16 Word16
+ | CWord32 Word32
+ | CWord64 Word64
+ | CFloat Float
+ | CDouble Double
+ deriving (Eq, Ord)
+
+instance Show Const where
+ show c = case c of
+ CBool True -> "1"
+ CBool False -> "0"
+ CInt8 c -> show c
+ CInt16 c -> show c
+ CInt32 c -> show c
+ CInt64 c -> show c
+ CWord8 c -> show c
+ CWord16 c -> show c
+ CWord32 c -> show c
+ CWord64 c -> show c
+ CFloat c -> show c
+ CDouble c -> show c
+
+data Expression
+ = EBool (E Bool)
+ | EInt8 (E Int8)
+ | EInt16 (E Int16)
+ | EInt32 (E Int32)
+ | EInt64 (E Int64)
+ | EWord8 (E Word8)
+ | EWord16 (E Word16)
+ | EWord32 (E Word32)
+ | EWord64 (E Word64)
+ | EFloat (E Float)
+ | EDouble (E Double)
+
+data Variable
+ = VBool (V Bool)
+ | VInt8 (V Int8)
+ | VInt16 (V Int16)
+ | VInt32 (V Int32)
+ | VInt64 (V Int64)
+ | VWord8 (V Word8)
+ | VWord16 (V Word16)
+ | VWord32 (V Word32)
+ | VWord64 (V Word64)
+ | VFloat (V Float)
+ | VDouble (V Double) deriving Eq
+
+
+-- | Variables updated by state transition rules.
+data V a = V UV deriving Eq
+
+-- | Untyped variables.
+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]
+ | UAExtern String Type
+ deriving (Show, Eq, Ord)
+
+-- | A typed expression.
+data E a where
+ VRef :: V a -> E a
+ Const :: a -> E a
+ Cast :: (NumE a, NumE b) => E a -> E b
+ Add :: NumE a => E a -> E a -> E a
+ Sub :: NumE a => E a -> E a -> E a
+ Mul :: NumE a => E a -> E a -> E a
+ Div :: NumE a => E a -> E a -> E a
+ Mod :: IntegralE a => E a -> E a -> E a
+ Not :: E Bool -> E Bool
+ And :: E Bool -> E Bool -> E Bool
+ BWNot :: IntegralE a => E a -> E a
+ BWAnd :: IntegralE a => E a -> E a -> E a
+ BWOr :: IntegralE a => E a -> E a -> E a
+ Shift :: IntegralE a => E a -> Int -> E a
+ Eq :: EqE a => E a -> E a -> E Bool
+ Lt :: OrdE a => E a -> E a -> E Bool
+ Mux :: E Bool -> E a -> E a -> E a
+ F2B :: E Float -> E Word32
+ 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"
+
+instance Expr a => Eq (E a) where
+ (==) = (==) `on` ue
+
+-- | An untyped term.
+data UE
+ = UVRef UV
+ | UConst Const
+ | UCast Type UE
+ | UAdd UE UE
+ | USub UE UE
+ | UMul UE UE
+ | UDiv UE UE
+ | UMod UE UE
+ | UNot UE
+ | UAnd [UE]
+ | UBWNot UE
+ | UBWAnd UE UE
+ | UBWOr UE UE
+ | UShift UE Int
+ | UEq UE UE
+ | ULt UE UE
+ | UMux UE UE UE
+ | UF2B UE
+ | UD2B UE
+ | UB2F UE
+ | UB2D UE
+ deriving (Show, Eq, Ord)
+
+class Width a where
+ width :: a -> Int
+
+bytes :: Width a => a -> Int
+bytes a = div (width a) 8 + if mod (width a) 8 == 0 then 0 else 1
+
+instance Width Type where
+ width t = case t of
+ Bool -> 1
+ Int8 -> 8
+ Int16 -> 16
+ Int32 -> 32
+ Int64 -> 64
+ Word8 -> 8
+ Word16 -> 16
+ Word32 -> 32
+ Word64 -> 64
+ Float -> 32
+ Double -> 64
+
+instance Width Const where width = width . typeOf
+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
+
+instance TypeOf Const where
+ typeOf a = case a of
+ CBool _ -> Bool
+ CInt8 _ -> Int8
+ CInt16 _ -> Int16
+ CInt32 _ -> Int32
+ CInt64 _ -> Int64
+ CWord8 _ -> Word8
+ CWord16 _ -> Word16
+ CWord32 _ -> Word32
+ CWord64 _ -> Word64
+ CFloat _ -> Float
+ CDouble _ -> Double
+
+instance TypeOf UV where
+ typeOf a = case a of
+ 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 a = case a of
+ UA _ _ c -> typeOf $ head c
+ UAExtern _ t -> t
+
+instance TypeOf (A a) where
+ typeOf (A ua) = typeOf ua
+
+instance TypeOf UE where
+ typeOf t = case t of
+ UVRef uvar -> typeOf uvar
+ UCast t _ -> t
+ UConst c -> typeOf c
+ UAdd a _ -> typeOf a
+ USub a _ -> typeOf a
+ UMul a _ -> typeOf a
+ UDiv a _ -> typeOf a
+ UMod a _ -> typeOf a
+ UNot _ -> Bool
+ UAnd _ -> Bool
+ UBWNot a -> typeOf a
+ UBWAnd a _ -> typeOf a
+ UBWOr a _ -> typeOf a
+ UShift a _ -> typeOf a
+ UEq _ _ -> Bool
+ ULt _ _ -> Bool
+ UMux _ a _ -> typeOf a
+ UF2B _ -> Word32
+ UD2B _ -> Word64
+ UB2F _ -> Float
+ UB2D _ -> Double
+
+instance Expr a => TypeOf (E a) where
+ typeOf = eType
+
+
+class Eq a => Expr a where
+ eType :: E a -> Type
+ constant :: a -> Const
+ expression :: E a -> Expression
+ variable :: V a -> Variable
+ rawBits :: E a -> E Word64
+
+instance Expr Bool where
+ eType _ = Bool
+ constant = CBool
+ expression = EBool
+ variable = VBool
+ rawBits a = mux a 1 0
+
+instance Expr Int8 where
+ eType _ = Int8
+ constant = CInt8
+ expression = EInt8
+ variable = VInt8
+ rawBits = Cast
+
+instance Expr Int16 where
+ eType _ = Int16
+ constant = CInt16
+ expression = EInt16
+ variable = VInt16
+ rawBits = Cast
+
+instance Expr Int32 where
+ eType _ = Int32
+ constant = CInt32
+ expression = EInt32
+ variable = VInt32
+ rawBits = Cast
+
+instance Expr Int64 where
+ eType _ = Int64
+ constant = CInt64
+ expression = EInt64
+ variable = VInt64
+ rawBits = Cast
+
+instance Expr Word8 where
+ eType _ = Word8
+ constant = CWord8
+ expression = EWord8
+ variable = VWord8
+ rawBits = Cast
+
+instance Expr Word16 where
+ eType _ = Word16
+ constant = CWord16
+ expression = EWord16
+ variable = VWord16
+ rawBits = Cast
+
+instance Expr Word32 where
+ eType _ = Word32
+ constant = CWord32
+ expression = EWord32
+ variable = VWord32
+ rawBits = Cast
+
+instance Expr Word64 where
+ eType _ = Word64
+ constant = CWord64
+ expression = EWord64
+ variable = VWord64
+ rawBits = id
+
+instance Expr Float where
+ eType _ = Float
+ constant = CFloat
+ expression = EFloat
+ variable = VFloat
+ rawBits = Cast . F2B
+
+instance Expr Double where
+ eType _ = Double
+ constant = CDouble
+ expression = EDouble
+ variable = VDouble
+ rawBits = D2B
+
+
+class (Num a, Expr a, EqE a, OrdE a) => NumE a
+instance NumE Int8
+instance NumE Int16
+instance NumE Int32
+instance NumE Int64
+instance NumE Word8
+instance NumE Word16
+instance NumE Word32
+instance NumE Word64
+instance NumE Float
+instance NumE Double
+
+class (NumE a, Integral a) => IntegralE a where signed :: E a -> Bool
+instance IntegralE Int8 where signed _ = True
+instance IntegralE Int16 where signed _ = True
+instance IntegralE Int32 where signed _ = True
+instance IntegralE Int64 where signed _ = True
+instance IntegralE Word8 where signed _ = False
+instance IntegralE Word16 where signed _ = False
+instance IntegralE Word32 where signed _ = False
+instance IntegralE Word64 where signed _ = False
+
+class (Eq a, Expr a) => EqE a
+instance EqE Bool
+instance EqE Int8
+instance EqE Int16
+instance EqE Int32
+instance EqE Int64
+instance EqE Word8
+instance EqE Word16
+instance EqE Word32
+instance EqE Word64
+instance EqE Float
+instance EqE Double
+
+class (Eq a, Ord a, EqE a) => OrdE a
+instance OrdE Int8
+instance OrdE Int16
+instance OrdE Int32
+instance OrdE Int64
+instance OrdE Word8
+instance OrdE Word16
+instance OrdE Word32
+instance OrdE Word64
+instance OrdE Float
+instance OrdE Double
+
+class (RealFloat a, NumE a, OrdE a) => FloatingE a
+instance FloatingE Float
+instance FloatingE Double
+
+instance (Num a, NumE a, OrdE a) => Num (E a) where
+ (Const a) + (Const b) = Const $ a + b
+ a + b = Add a b
+ (Const a) - (Const b) = Const $ a - b
+ a - b = Sub a b
+ (Const a) * (Const b) = Const $ a * b
+ a * b = Mul a b
+ negate a = 0 - a
+ abs a = mux (a <. 0) (negate a) a
+ signum a = mux (a ==. 0) 0 $ mux (a <. 0) (-1) 1
+ 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)
+
+{-
+instance (Num a, Fractional a, Floating a, FloatingE a) => Floating (E a) where
+ pi = Const pi
+ exp (Const a) = Const $ exp a
+ exp a = Exp a
+ log (Const a) = Const $ log a
+ log a = Log a
+ sqrt (Const a) = Const $ sqrt a
+ sqrt a = Sqrt a
+ (**) (Const a) (Const b) = Const $ a ** b
+ (**) a b = Pow a b
+ sin (Const a) = Const $ sin a
+ sin a = Sin a
+ cos a = sqrt (1 - sin a ** 2)
+ sinh a = (exp a - exp (-a)) / 2
+ cosh a = (exp a + exp (-a)) / 2
+ asin (Const a) = Const $ asin a
+ asin a = Asin a
+ acos a = pi / 2 - asin a
+ atan a = asin (a / (sqrt (a ** 2 + 1)))
+ asinh a = log (a + sqrt (a ** 2 + 1))
+ acosh a = log (a + sqrt (a ** 2 - 1))
+ atanh a = 0.5 * log ((1 + a) / (1 - a))
+-}
+
+instance (Expr a, OrdE a, EqE a, IntegralE a, Bits a) => Bits (E a) where
+ (Const a) .&. (Const b) = Const $ a .&. b
+ a .&. b = BWAnd a b
+ complement (Const a) = Const $ complement a
+ complement a = BWNot a
+ (Const a) .|. (Const b) = Const $ a .|. b
+ a .|. b = BWOr a b
+ xor a b = (a .&. complement b) .|. (complement a .&. b)
+ shift (Const a) n = Const $ shift a n
+ shift a n = Shift a n
+ rotate a n | n >= width a = error "E rotates too far."
+ rotate (Const a) n = Const $ rotate a n
+ rotate a n | n > 0 = shift a n .|. shift a (width a - n) .&. Const (mask n)
+ | n < 0 = shift a n .&. Const (mask $ width a + n) .|. shift a (width a + n)
+ | otherwise = a
+ where
+ mask 0 = 0
+ mask n = shiftL (mask $ n - 1) 1 + 1
+ bitSize = width
+ isSigned = signed
+
+-- | True term.
+true :: E Bool
+true = Const True
+
+-- | False term.
+false :: E Bool
+false = Const False
+
+-- | Logical negation.
+not_ :: E Bool -> E Bool
+not_ = Not
+
+-- | Logical AND.
+(&&.) :: E Bool -> E Bool -> E Bool
+(&&.) = And
+
+-- | Logical OR.
+(||.) :: E Bool -> E Bool -> E Bool
+(||.) a b = not_ $ not_ a &&. not_ b
+
+-- | The conjunction of a E Bool list.
+and_ :: [E Bool] -> E Bool
+and_ = foldl (&&.) true
+
+-- | The disjunction of a E Bool list.
+or_ :: [E Bool] -> E Bool
+or_ = foldl (||.) false
+
+-- | True iff the predicate is true for all elements.
+all_ :: (a -> E Bool) -> [a] -> E Bool
+all_ f a = and_ $ map f a
+
+-- | True iff the predicate is true for any element.
+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 => E a -> E a -> E Bool
+(==.) = Eq
+
+-- | Not equal.
+(/=.) :: EqE a => E a -> E a -> E Bool
+a /=. b = not_ (a ==. b)
+
+-- | Less than.
+(<.) :: OrdE a => E a -> E a -> E Bool
+(<.) = Lt
+
+-- | Greater than.
+(>.) :: OrdE a => E a -> E a -> E Bool
+a >. b = b <. a
+
+-- | Less than or equal.
+(<=.) :: OrdE a => E a -> E a -> E Bool
+a <=. b = not_ (a >. b)
+
+-- | Greater than or equal.
+(>=.) :: OrdE a => E a -> E a -> E Bool
+a >=. b = not_ (a <. b)
+
+-- | Returns the minimum of two numbers.
+min_ :: OrdE a => E a -> E a -> E a
+min_ a b = mux (a <=. b) a b
+
+-- | Returns the minimum of a list of numbers.
+minimum_ :: OrdE a => [E a] -> E a
+minimum_ = foldl1 min_
+
+-- | Returns the maximum of two numbers.
+max_ :: OrdE a => E a -> E a -> E a
+max_ a b = mux (a >=. b) a b
+
+-- | Returns the maximum of a list of numbers.
+maximum_ :: OrdE a => [E a] -> E a
+maximum_ = foldl1 max_
+
+-- | Limits between min and max.
+limit :: OrdE a => E a -> E a -> E a -> E a
+limit a b i = max_ min $ min_ max i
+ where
+ min = min_ a b
+ max = max_ a b
+
+-- | Division. If both the dividend and divisor are constants, a compile-time
+-- check is made for divide-by-zero. Otherwise, if the divisor ever evaluates
+-- to @0@, a runtime exception will occur, even if the division occurs within
+-- the scope of a 'cond' or 'mux' that tests for @0@ (because Atom generates
+-- deterministic-time code, every branch of a 'cond' or 'mux' is executed).
+div_ :: IntegralE a => E a -> E a -> E a
+div_ (Const a) (Const b) = Const $ a `div` b
+div_ a b = Div a b
+
+-- | Division, where the C code is instrumented with a runtime check to ensure
+-- the divisor does not equal @0@. If it is equal to @0@, the 3rd argument is a
+-- user-supplied non-zero divsor.
+div0_ :: IntegralE a => E a -> E a -> a -> E a
+div0_ _ _ 0 = error "The third argument to div0_ must be non-zero."
+div0_ a b c = div_ a $ mux (b ==. 0) (Const c) b
+
+-- | Modulo. If both the dividend and modulus are constants, a compile-time
+-- check is made for divide-by-zero. Otherwise, if the modulus ever evaluates
+-- to @0@, a runtime exception will occur, even if the division occurs within
+-- the scope of a 'cond' or 'mux' that tests for @0@ (because Atom generates
+-- deterministic-time code, every branch of a 'cond' or 'mux' is executed).
+mod_ :: IntegralE a => E a -> E a -> E a
+mod_ (Const a) (Const b) = Const $ a `mod` b
+mod_ a b = Mod a b
+
+-- | Modulus, where the C code is instrumented with a runtime check to ensure
+-- the modulus does not equal @0@. If it is equal to @0@, the 3rd argument is
+-- a user-supplied non-zero divsor.
+mod0_ :: IntegralE a => E a -> E a -> a -> E a
+mod0_ _ _ 0 = error "The third argument to mod0_ must be non-zero."
+mod0_ a b c = mod_ a $ mux (b ==. 0) (Const c) b
+
+-- | Returns the value of a 'V'.
+value :: V a -> E a
+value = VRef
+
+-- | Conditional expression. Note, both branches are evaluated!
+--
+-- > 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) = V . UVArray ua . ue
+
+-- | Array index to expression.
+(!.) :: (Expr a, IntegralE b) => A a -> E b -> E a
+a !. i = value $ a ! i
+
+
+
+-- | The list of UEs adjacent upstream of a UE.
+ueUpstream :: UE -> [UE]
+ueUpstream t = case t of
+ UVRef (UV _ _ _) -> []
+ UVRef (UVArray _ a) -> [a]
+ UVRef (UVExtern _ _) -> []
+ UCast _ a -> [a]
+ UConst _ -> []
+ UAdd a b -> [a, b]
+ USub a b -> [a, b]
+ UMul a b -> [a, b]
+ UDiv a b -> [a, b]
+ UMod a b -> [a, b]
+ UNot a -> [a]
+ UAnd a -> a
+ UBWNot a -> [a]
+ UBWAnd a b -> [a, b]
+ UBWOr a b -> [a, b]
+ UShift a _ -> [a]
+ UEq a b -> [a, b]
+ ULt a b -> [a, b]
+ UMux a b c -> [a, b, c]
+ UF2B a -> [a]
+ UD2B a -> [a]
+ 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@(UVArray _ i)) = [uv] ++ f i
+ 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 (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
+ Const a -> UConst $ constant a
+ Cast a -> UCast tt (ue a)
+ Add a b -> UAdd (ue a) (ue b)
+ Sub a b -> USub (ue a) (ue b)
+ Mul a b -> UMul (ue a) (ue b)
+ Div a b -> UDiv (ue a) (ue b)
+ Mod a b -> UMod (ue a) (ue b)
+ Not a -> unot (ue a)
+ And a b -> uand (ue a) (ue b)
+ BWNot a -> UBWNot (ue a)
+ BWAnd a b -> UBWAnd (ue a) (ue b)
+ BWOr a b -> UBWOr (ue a) (ue b)
+ Shift a b -> UShift (ue a) b
+ Eq a b -> ueq (ue a) (ue b)
+ Lt a b -> ult (ue a) (ue b)
+ Mux a b c -> umux (ue a) (ue b) (ue c)
+ F2B a -> UF2B (ue a)
+ D2B a -> UD2B (ue a)
+ B2F a -> UB2F (ue a)
+ B2D a -> UB2D (ue a)
+ Retype a -> a
+ where
+ tt = eType t
+
+uv :: V a -> UV
+uv (V v) = v
+
+-- XXX A future smart constructor for numeric type casting.
+-- ucast :: Type -> UE -> UE
+
+ubool :: Bool -> UE
+ubool = UConst . CBool
+
+unot :: UE -> UE
+unot (UConst (CBool a)) = ubool $ not a
+unot (UNot a) = a
+unot a = UNot a
+
+uand :: UE -> UE -> UE
+uand a b | a == b = a
+uand a@(UConst (CBool False)) _ = a
+uand _ a@(UConst (CBool False)) = a
+uand (UConst (CBool True)) a = a
+uand a (UConst (CBool True)) = a
+uand (UAnd a) (UAnd b) = reduceAnd $ a ++ b
+uand (UAnd a) b = reduceAnd $ b : a
+uand a (UAnd b) = reduceAnd $ a : b
+uand a b = reduceAnd [a, b]
+
+reduceAnd :: [UE] -> UE
+
+-- a && not a
+reduceAnd terms | not $ null [ e | e <- terms, e' <- map unot terms, e == e' ] = ubool False
+
+-- a == x && a == y && x /= y
+reduceAnd terms | or [ f a b | a <- terms, b <- terms ] = ubool False
+ where
+ f :: UE -> UE -> Bool
+ f (UEq a b) (UEq x y) | a == x = yep $ ueq b y
+ | a == y = yep $ ueq b x
+ | b == x = yep $ ueq a y
+ | b == y = yep $ ueq a x
+ f _ _ = False
+ yep :: UE -> Bool
+ yep (UConst (CBool False)) = True
+ yep _ = False
+
+-- a && b && not (a && b)
+reduceAnd terms | not $ null [ e | e <- terms, not $ null $ f e, all (flip elem terms) $ f e ] = ubool False
+ where
+ f :: UE -> [UE]
+ f (UNot (UAnd a)) = a
+ f _ = []
+
+-- collect, sort, and return
+reduceAnd terms = UAnd $ sort $ nub terms
+
+uor :: UE -> UE -> UE
+uor a b = unot (uand (unot a) (unot b))
+
+ueq :: UE -> UE -> UE
+ueq a b | a == b = ubool True
+ueq (UConst (CBool a)) (UConst (CBool b)) = ubool $ a == b
+ueq (UConst (CInt8 a)) (UConst (CInt8 b)) = ubool $ a == b
+ueq (UConst (CInt16 a)) (UConst (CInt16 b)) = ubool $ a == b
+ueq (UConst (CInt32 a)) (UConst (CInt32 b)) = ubool $ a == b
+ueq (UConst (CInt64 a)) (UConst (CInt64 b)) = ubool $ a == b
+ueq (UConst (CWord8 a)) (UConst (CWord8 b)) = ubool $ a == b
+ueq (UConst (CWord16 a)) (UConst (CWord16 b)) = ubool $ a == b
+ueq (UConst (CWord32 a)) (UConst (CWord32 b)) = ubool $ a == b
+ueq (UConst (CWord64 a)) (UConst (CWord64 b)) = ubool $ a == b
+ueq (UConst (CFloat a)) (UConst (CFloat b)) = ubool $ a == b
+ueq (UConst (CDouble a)) (UConst (CDouble b)) = ubool $ a == b
+ueq a b = UEq a b
+
+ult :: UE -> UE -> UE
+ult a b | a == b = ubool False
+ult (UConst (CBool a)) (UConst (CBool b)) = ubool $ a < b
+ult (UConst (CInt8 a)) (UConst (CInt8 b)) = ubool $ a < b
+ult (UConst (CInt16 a)) (UConst (CInt16 b)) = ubool $ a < b
+ult (UConst (CInt32 a)) (UConst (CInt32 b)) = ubool $ a < b
+ult (UConst (CInt64 a)) (UConst (CInt64 b)) = ubool $ a < b
+ult (UConst (CWord8 a)) (UConst (CWord8 b)) = ubool $ a < b
+ult (UConst (CWord16 a)) (UConst (CWord16 b)) = ubool $ a < b
+ult (UConst (CWord32 a)) (UConst (CWord32 b)) = ubool $ a < b
+ult (UConst (CWord64 a)) (UConst (CWord64 b)) = ubool $ a < b
+ult (UConst (CFloat a)) (UConst (CFloat b)) = ubool $ a < b
+ult (UConst (CDouble a)) (UConst (CDouble b)) = ubool $ a < b
+ult a b = ULt a b
+
+umux :: UE -> UE -> UE -> UE
+umux _ t f | t == f = f
+umux b t f | typeOf t == Bool = uor (uand b t) (uand (unot b) f)
+umux (UConst (CBool b)) t f = if b then t else f
+umux (UNot b) t f = umux b f t
+umux b1 (UMux b2 t _) f | b1 == b2 = umux b1 t f
+umux b1 t (UMux b2 _ f) | b1 == b2 = umux b1 t f
+umux b t f = UMux b t f
+
+{-
+-- | Balances mux trees in expression. Reduces critical path at cost of additional logic.
+balance :: UE -> UE
+balance ue = case ue of
+ UVRef _ -> ue
+ UCast t a -> UCast t (balance a)
+ UConst _ -> ue
+ UAdd a b -> UAdd (balance a) (balance b)
+ USub a b -> USub (balance a) (balance b)
+ UMul a b -> UMul (balance a) (balance b)
+ UDiv a b -> UDiv (balance a) (balance b)
+ UMod a b -> UMod (balance a) (balance b)
+ UNot a -> UNot (balance a)
+ UAnd a -> UAnd (map balance a)
+ UBWNot a -> UBWNot (balance a)
+ UBWAnd a b -> UBWAnd (balance a) (balance b)
+ UBWOr a b -> UBWOr (balance a) (balance b)
+ UShift a n -> UShift (balance a) n
+ UEq a b -> UEq (balance a) (balance b)
+ ULt a b -> ULt (balance a) (balance b)
+ UMux a t f -> rotate $ umux a t' f'
+ where
+ t' = balance t
+ f' = balance f
+ depth :: UE -> Int
+ depth (UMux _ t f) = 1 + max (depth t) (depth f)
+ depth _ = 0
+ rotate :: UE -> UE
+ rotate ue = case ue of
+ UMux a1 t1@(UMux a2 t2 f2) f1 | depth t1 >= depth f1 + 2 -> umux (uand a1 a2) t2 (umux a1 f2 f1)
+ UMux a1 t1 f1@(UMux a2 t2 f2) | depth f1 >= depth t1 + 2 -> umux (uor a1 a2) (umux a1 t1 t2) f2
+ _ -> ue
+-}
+
+-- Idea analyzing a pair of comparisons with one common operand: take to other two operands and construct the appropriate
+-- expression and check never.
+-- never (a == x) && (a == y) => never (x == y)
+-- never (a == x) && (a < y) => never (x >= y)
+-- never (a == x) && (a /= y) => never (x == y)
+-- never (a == x) || (a == y) => never (x == y)
+{-
+isExclusiveCompare :: (ConstantCompare, ConstantCompare) -> Bool
+isExclusiveCompare a = case a of
+ (Equal a, Equal b) -> a /= b
+ (Equal a, NotEqual b) -> a == b
+ (Equal a, Less b) -> a >= b
+ (Equal a, LessEqual b) -> a > b
+ (Equal a, More b) -> a <= b
+ (Equal a, MoreEqual b) -> a < b
+
+ (NotEqual a, Equal b) -> a == b
+ (NotEqual _, _) -> False
+
+ (Less a, Equal b) -> a <= b
+ (Less a, More b) -> a <= b
+ (Less a, MoreEqual b) -> a <= b
+ (Less _, _) -> False
+
+ (LessEqual a, Equal b) -> a < b
+ (LessEqual a, More b) -> a <= b
+ (LessEqual a, MoreEqual b) -> a < b
+ (LessEqual _, _) -> False
+
+ (More a, Equal b) -> a >= b
+ (More a, Less b) -> a >= b
+ (More a, LessEqual b) -> a >= b
+ (More _, _) -> False
+
+ (MoreEqual a, Equal b) -> a > b
+ (MoreEqual a, Less b) -> a >= b
+ (MoreEqual a, LessEqual b) -> a > b
+ (MoreEqual _, _) -> False
+
+data ConstantCompare
+ = Equal TermConst
+ | NotEqual TermConst
+ | Less TermConst
+ | LessEqual TermConst
+ | More TermConst
+ | MoreEqual TermConst
+ deriving (Eq, Ord)
+-}
+
+--data NetList = NetList Int (IntMap UE)
319 Language/Atom/Language.hs
@@ -0,0 +1,319 @@
+-- | The Atom language.
+module Language.Atom.Language
+ (
+ module Language.Atom.Expressions
+ -- * Primary Language Containers
+ , Atom
+ -- * Hierarchical Rule Declarations
+ , atom
+ , period
+ , getPeriod
+ , phase
+ , getPhase
+ -- * Action Directives
+ , cond
+ , Assign (..)
+ , incr
+ , decr
+ -- * Variable Declarations
+ , var
+ , var'
+ , array
+ , array'
+ , bool
+ , bool'
+ , int8
+ , int8'
+ , int16
+ , int16'
+ , int32
+ , int32'
+ , int64
+ , int64'
+ , word8
+ , word8'
+ , word16
+ , word16'
+ , word32
+ , word32'
+ , word64
+ , word64'
+ , float
+ , float'
+ , double
+ , double'
+ -- * Custom Actions
+ , action
+ , call
+ -- * Probing
+ , probe
+ , probes
+ -- * Assertions and Functional Coverage
+ , assert
+ , cover
+ , assertImply
+ -- * Utilities
+ , Name
+ , liftIO
+ , path
+ , clock
+ -- * Code Coverage
+ , nextCoverage
+ ) where
+
+import Control.Monad
+import Control.Monad.Trans
+import Data.Int
+import Data.Word
+
+import Language.Atom.Elaboration hiding (Atom)
+import qualified Language.Atom.Elaboration as E
+import Language.Atom.Expressions
+
+infixr 1 <==
+
+-- | The Atom monad captures variable and transition rule declarations.
+type Atom = E.Atom
+
+-- | 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
+ (g1, parent) <- get
+ (a, (g2, child)) <- liftIO $ buildAtom g1 { gState = [] } name' design
+ put (g2 { gState = gState g1 ++ [StateHierarchy name $ gState g2] }, parent { atomSubs = atomSubs parent ++ [child] })
+ return a
+
+-- | Defines the period of execution of sub rules as a factor of the base rate of the system.
+-- Rule period is bound by the closest period assertion. For example:
+--
+-- > period 10 $ period 2 a -- Rules in 'a' have a period of 2, not 10.
+period :: Int -> Atom a -> Atom a
+period n _ | n <= 0 = error "ERROR: Execution period must be greater than 0."
+period n atom = do
+ (g, a) <- get
+ put (g { gPeriod = n }, a)
+ r <- atom
+ (g', a) <- get
+ put (g' { gPeriod = gPeriod g }, a)
+ return r
+
+-- | Returns the execution period of the current scope.
+getPeriod :: Atom Int
+getPeriod = do
+ (g, _) <- get
+ return $ gPeriod g
+
+-- | Defines the earliest phase within the period at which the rule should
+-- execute. The 'phase' must be at least zero and less than the current 'period'.
+phase :: Int -> Atom a -> Atom a
+phase n _ | n < 0 = error "ERROR: phase must be at least 0."
+phase n atom = do
+ (g, a) <- get
+ if (n >= gPeriod g)
+ then error "ERROR: phase must be less than the current phase."
+ else do put (g { gPhase = n }, a)
+ r <- atom
+ (g', a) <- get
+ put (g' { gPhase = gPhase g }, a)
+ return r
+
+-- | Returns the phase of the current scope.
+getPhase :: Atom Int
+getPhase = do
+ (g, _) <- get
+ return $ gPhase g
+
+-- | Returns the current atom hierarchical path.
+path :: Atom String
+path = do
+ (_, atom) <- get
+ return $ atomName atom
+
+-- | Local boolean variable declaration.
+bool :: Name -> Bool -> Atom (V Bool)
+bool = var
+
+-- | External boolean variable declaration.
+bool' :: Name -> V Bool
+bool' name = var' name Bool
+
+-- | Local int8 variable declaration.
+int8 :: Name -> Int8 -> Atom (V Int8)
+int8 = var
+
+-- | External int8 variable declaration.
+int8' :: Name -> V Int8
+int8' name = var' name Int8
+
+-- | Local int16 variable declaration.
+int16 :: Name -> Int16 -> Atom (V Int16)
+int16 = var
+
+-- | External int16 variable declaration.
+int16' :: Name -> V Int16
+int16' name = var' name Int16
+
+-- | Local int32 variable declaration.
+int32 :: Name -> Int32 -> Atom (V Int32)
+int32 = var
+
+-- | External int32 variable declaration.
+int32' :: Name -> V Int32
+int32' name = var' name Int32
+
+-- | Local int64 variable declaration.
+int64 :: Name -> Int64 -> Atom (V Int64)
+int64 = var
+
+-- | External int64 variable declaration.
+int64' :: Name -> V Int64
+int64' name = var' name Int64
+
+-- | Local word8 variable declaration.
+word8 :: Name -> Word8 -> Atom (V Word8)
+word8 = var
+
+-- | External word8 variable declaration.
+word8' :: Name -> V Word8
+word8' name = var' name Word8
+
+-- | Local word16 variable declaration.
+word16 :: Name -> Word16 -> Atom (V Word16)
+word16 = var
+
+-- | External word16 variable declaration.
+word16' :: Name -> V Word16
+word16' name = var' name Word16
+
+-- | Local word32 variable declaration.
+word32 :: Name -> Word32 -> Atom (V Word32)
+word32 = var
+
+-- | External word32 variable declaration.
+word32' :: Name -> V Word32
+word32' name = var' name Word32
+
+-- | Local word64 variable declaration.
+word64 :: Name -> Word64 -> Atom (V Word64)
+word64 = var
+
+-- | External word64 variable declaration.
+word64' :: Name -> V Word64
+word64' name = var' name Word64
+
+-- | Local float variable declaration.
+float :: Name -> Float -> Atom (V Float)
+float = var
+
+-- | External float variable declaration.
+float' :: Name -> V Float
+float' name = var' name Float
+
+-- | Local double variable declaration.
+double :: Name -> Double -> Atom (V Double)
+double = var
+
+-- | External double variable declaration.
+double' :: Name -> V Double
+double' name = var' name Double
+
+-- | Declares an action.
+action :: ([String] -> String) -> [UE] -> Atom ()
+action f ues = do
+ (g, a) <- get
+ put (g, a { atomActions = atomActions a ++ [(f, ues)] })
+
+-- | Calls an external C function of type 'void f(void)'.
+call :: Name -> Atom ()
+call n = action (\ _ -> n ++ "()") []
+
+-- | Declares a probe.
+probe :: Expr a => Name -> E a -> Atom ()
+probe name a = do
+ (g, atom) <- get
+ if any (\ (n, _) -> name == n) $ gProbes g
+ then error $ "ERROR: Duplicated probe name: " ++ name
+ else put (g { gProbes = (name, ue a) : gProbes g }, atom)
+
+
+-- | Fetches all declared probes to current design point.
+probes :: Atom [(String, UE)]
+probes = do
+ (g, _) <- get
+ return $ gProbes g
+
+
+-- | Increments a NumE 'V'.
+incr :: (Assign a, NumE a) => V a -> Atom ()
+incr a = a <== value a + 1
+
+-- | Decrements a NumE 'V'.
+decr :: (Assign a, NumE a) => V a -> Atom ()
+decr a = a <== value a - 1
+
+
+class Expr a => Assign a where
+ -- | Assign an 'E' to a 'V'.
+ (<==) :: V a -> E a -> Atom ()
+ v <== e = do
+ (g, atom) <- get
+ put (g, atom { atomAssigns = (uv v, ue e) : atomAssigns atom })
+
+instance Assign Bool
+instance Assign Int8
+instance Assign Int16
+instance Assign Int32
+instance Assign Int64
+instance Assign Word8
+instance Assign Word16
+instance Assign Word32
+instance Assign Word64
+instance Assign Float
+instance Assign Double
+
+-- | Adds an enabling condition to an atom subtree of rules.
+-- This condition must be true before any rules in hierarchy
+-- are allowed to execute.
+cond :: E Bool -> Atom ()
+cond c = do
+ (g, atom) <- get
+ put (g, atom { atomEnable = uand (atomEnable atom) (ue c) })
+
+-- | Reference to the 64-bit free running clock.
+clock :: E Word64
+clock = value $ word64' "__global_clock"
+
+-- | 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 $ word32' "__coverage_index", value $ word32' "__coverage[__coverage_index]")
+
+
+-- | An assertions checks that an E Bool is true. Assertions are checked between the execution of every rule.
+-- Parent enabling conditions can disable assertions, but period and phase constraints do not.
+-- Assertion names should be globally unique.
+assert :: Name -> E Bool -> Atom ()
+assert name check = do
+ (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
+
+-- | A functional coverage point tracks if an event has occured (true).
+-- Coverage points are checked at the same time as assertions.
+-- Coverage names should be globally unique.
+cover :: Name -> E Bool -> Atom ()
+cover name check = do
+ (g, atom) <- get
+ let names = fst $ unzip $ atomCovers atom
+ when (elem name names) (liftIO $ putStrLn $ "WARNING: Coverage name already used: " ++ name)
+ put (g, atom { atomCovers = (name, ue check) : atomCovers atom })
+
132 Language/Atom/Scheduling.hs
@@ -0,0 +1,132 @@
+-- | Atom rule scheduling.
+module Language.Atom.Scheduling
+ ( schedule
+ , Schedule
+ , reportSchedule
+ ) where
+
+import Data.List
+import Language.Atom.Analysis
+import Language.Atom.Elaboration
+import Text.Printf
+
+type Schedule = [(Int, Int, [Rule])] -- (period, phase, rules)
+
+schedule :: [Rule] -> Schedule
+schedule rules' = concatMap spread periods
+ where
+ rules = [ r | r@(Rule _ _ _ _ _ _ _) <- rules' ]
+
+ -- Algorithm for assigning rules to phases for a given period:
+
+ -- 1. List the rules by their offsets, highest first.
+
+ -- 2. If the list is empty, stop.
+
+ -- 3. Otherwise, take the head of the list and assign its phase as follows:
+ -- find the set of phases containing the minimum number of rules such that
+ -- they are at least as large as the rule's offset. Then take the smallest
+ -- of those phases.
+
+ -- 4. Go to (2).
+
+ -- Algorithm properties: for each period,
+
+ -- A. Each rule is scheduled no earlier than its offset.
+
+ -- B. The phase with the most rules is the minimum of all possible schedules
+ -- that satisfy (A).
+
+ -- XXX Check if this is true.
+ -- C. The sum of the difference between between each rule's offset and it's
+ -- scheduled phase is the minimum of all schedules satisfying (A) and (B).
+
+ spread :: (Int, [Rule]) -> Schedule
+ spread (period, rules) =
+ placeRules (replicate period []) orderedByPhase
+
+ where
+ orderedByPhase :: [Rule]
+ orderedByPhase =
+ sortBy (\r0 r1 -> compare (rulePhase r1) (rulePhase r0)) rules
+
+ placeRules :: [[Rule]] -> [Rule] -> [(Int, Int, [Rule])]
+ placeRules ls [] =
+ filter (\(_,_,rls) -> not (null rls)) $ zip3 (repeat period) [0..(period-1)] ls
+ placeRules ls (r:rst) = placeRules (insertAt (lub r ls) r ls) rst
+
+ lub :: Rule -> [[Rule]] -> Int
+ lub r ls = let minI = rulePhase r
+ lub' i [] = i -- unreachable. Included to prevent missing
+ -- cases ghc warnings.
+ lub' i ls | (head ls) == minimum ls = i
+ | otherwise = lub' (i+1) (tail ls)
+ in lub' minI (drop minI $ map length ls)
+
+ insertAt :: Int -> Rule -> [[Rule]] -> [[Rule]]
+ insertAt i r ls = (take i ls) ++ ((r:(ls !! i)):(drop (i+1) ls))
+
+ periods = foldl grow [] [ (rulePeriod r, r) | r <- rules ]
+
+ 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)
+
+
+
+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 ]
+
+
+reportPeriod :: (Int, Int, [Rule]) -> String