atom 1.0.8 → 1.0.9

raw patch · 9 files changed

+853/−373 lines, 9 filesdep +bimapdep +containersdep −uniplatedep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bimap, containers

Dependencies removed: uniplate

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• Language/Atom/Analysis.hs +8/−7
• Language/Atom/Code.hs +205/−146
• Language/Atom/Compile.hs +12/−9
• Language/Atom/Elaboration.hs +175/−87
• Language/Atom/Expressions.hs +4/−64
• Language/Atom/Language.hs +49/−35
• Language/Atom/Scheduling.hs +19/−19
• Language/Atom/UeMap.hs +375/−0
• atom.cabal +6/−6

@@ -4,22 +4,23 @@   ) where  import Language.Atom.Elaboration-import Language.Atom.Expressions+import Language.Atom.UeMap  -- | Topologically sorts a list of expressions and subexpressions.-topo :: [UE] -> [(UE, String)]-topo ues = reverse ues'+topo :: UeMap -> [Hash] -> [(Hash, String)]+topo mp ues = reverse ues'   where   start = 0   (_, ues') = foldl collect (start, []) ues-  collect :: (Int, [(UE, String)]) -> UE -> (Int, [(UE, String)])+  collect :: (Int, [(Hash, String)]) -> Hash -> (Int, [(Hash, 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+  collect (n, ues) ue = (n' + 1, (ue, e n') : ues') +    where (n', ues') = foldl collect (n, ues) $ ueUpstream ue mp  e :: Int -> String e i = "__" ++ show i  -- | Number of UE's computed in rule.-ruleComplexity :: Rule -> Int-ruleComplexity = length . topo . allUEs+ruleComplexity :: UeMap -> Rule -> Int+ruleComplexity mp = length . (topo mp) . allUEs 

@@ -13,13 +13,14 @@ import Data.Maybe import Text.Printf import Data.Word--import Data.Generics.Uniplate.Data+import qualified Data.Bimap as M  import Language.Atom.Analysis import Language.Atom.Elaboration-import Language.Atom.Expressions-import Language.Atom.Scheduling+import Language.Atom.Expressions hiding (typeOf)+import qualified Language.Atom.Expressions as E+import Language.Atom.Scheduling +import Language.Atom.UeMap  -- | C code configuration parameters. data Config = Config@@ -44,7 +45,7 @@   }  -- | Data associated with sampling a hardware clock.  For the clock to work--- correctly, you MUST assign @__global_clock@ the current time (accoring to +-- correctly, you MUST assign @__global_clock@ the current time (accoring to -- @clockName@) the first time you enter the main Atom-generated function -- calling your rules. data Clock = Clock@@ -54,7 +55,7 @@                                 -- @clockType clockName(void)@.   , clockType  :: Type          -- ^ Clock type.  Assumed to be one of Word8,                                 -- Word16, Word32, or Word64.  It is permissible-                                -- for the clock to rollover.  +                                -- for the clock to rollover.   , delta      :: Integer       -- ^ Number of ticks in a phase.  Must be greater than 0.   , delay      :: String        -- ^ C function to delay/sleep.  The function is                                 -- assumed to have the prototype @void@@ -114,87 +115,75 @@   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"+codeUE :: UeMap -> Config -> [(Hash, String)] -> String -> (Hash, String) -> String+codeUE mp config ues d (ue, n) = +  d ++ cType (typeOf ue mp) ++ " " ++ n ++ " = " ++ basic ++ ";\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, "))"]+  operands = map (fromJust . flip lookup ues) $ ueUpstream ue mp+  basic :: String+  basic = concat $ case getUE ue mp of+    MUVRef (MUV _ n _)                 -> [cStateName config, ".", n]+    MUVRef (MUVArray (UA _ n _) _)     -> [cStateName config, ".", n, "[", a, "]"]+    MUVRef (MUVArray (UAExtern n _) _) -> [n, "[", a, "]"]+    MUVRef (MUVExtern n _)             -> [n]+    MUCast _ _            -> ["(", cType (typeOf ue mp), ") ", a]+    MUConst c             -> [showConst c]+    MUAdd _ _             -> [a, " + ", b]+    MUSub _ _             -> [a, " - ", b]+    MUMul _ _             -> [a, " * ", b]+    MUDiv _ _             -> [a, " / ", b]+    MUMod _ _             -> [a, " % ", b]+    MUNot _               -> ["! ", a]+    MUAnd _               -> intersperse " && " operands+    MUBWNot _             -> ["~ ", a]+    MUBWAnd _ _           -> [a, " & ", b]+    MUBWOr  _ _           -> [a, " | ", b]+    MUShift _ n           -> (if n >= 0 then [a, " << ", show n] else [a, " >> ", show (negate n)])+    MUEq  _ _             -> [a, " == ", b]+    MULt  _ _             -> [a, " < " , b]+    MUMux _ _ _           -> [a, " ? " , b, " : ", c]+    MUF2B _               -> ["*((", ct Word32, " *) &(", a, "))"]+    MUD2B _               -> ["*((", ct Word64, " *) &(", a, "))"]+    MUB2F _               -> ["*((", ct Float , " *) &(", a, "))"]+    MUB2D _               -> ["*((", ct Double, " *) &(", a, "))"] -- math.h:-    UPi                  -> [ "M_PI" ]-    UExp   _             -> [ "exp",   f, " ( ", a, " )"]-    ULog   _             -> [ "log",   f, " ( ", a, " )"]-    USqrt  _             -> [ "sqrt",  f, " ( ", a, " )"]-    UPow   _ _           -> [ "pow",   f, " ( ", a, ", ", b, " )"]-    USin   _             -> [ "sin",   f, " ( ", a, " )"]-    UAsin  _             -> [ "asin",  f, " ( ", a, " )"]-    UCos   _             -> [ "cos",   f, " ( ", a, " )"]-    UAcos  _             -> [ "acos",  f, " ( ", a, " )"]-    USinh  _             -> [ "sinh",  f, " ( ", a, " )"]-    UCosh  _             -> [ "cosh",  f, " ( ", a, " )"]-    UAsinh _             -> [ "asinh", f, " ( ", a, " )"]-    UAcosh _             -> [ "acosh", f, " ( ", a, " )"]-    UAtan  _             -> [ "atan",  f, " ( ", a, " )"]-    UAtanh _             -> [ "atanh", f, " ( ", a, " )"]+    MUPi                  -> [ "M_PI" ]+    MUExp   _             -> [ "exp",   f, " ( ", a, " )"]+    MULog   _             -> [ "log",   f, " ( ", a, " )"]+    MUSqrt  _             -> [ "sqrt",  f, " ( ", a, " )"]+    MUPow   _ _           -> [ "pow",   f, " ( ", a, ", ", b, " )"]+    MUSin   _             -> [ "sin",   f, " ( ", a, " )"]+    MUAsin  _             -> [ "asin",  f, " ( ", a, " )"]+    MUCos   _             -> [ "cos",   f, " ( ", a, " )"]+    MUAcos  _             -> [ "acos",  f, " ( ", a, " )"]+    MUSinh  _             -> [ "sinh",  f, " ( ", a, " )"]+    MUCosh  _             -> [ "cosh",  f, " ( ", a, " )"]+    MUAsinh _             -> [ "asinh", f, " ( ", a, " )"]+    MUAcosh _             -> [ "acosh", f, " ( ", a, " )"]+    MUAtan  _             -> [ "atan",  f, " ( ", a, " )"]+    MUAtanh _             -> [ "atanh", f, " ( ", a, " )"]     where       ct = cType       a = head operands       b = operands !! 1       c = operands !! 2-      f = case ( typeOf ue ) of+      f = case ( typeOf ue mp) of             Float     -> "f"             Double    -> ""             _         -> error "unhandled float type"  type RuleCoverage = [(Name, Int, Int)] -containMathHFunctions rules = any isMathHCall ues-       where ues            = rules >>= allUEs >>= universe-             isMathHCall fc = case fc of-                                UPi        -> True-                                UExp   _   -> True-                                ULog   _   -> True-                                USqrt  _   -> True-                                UPow   _ _ -> True-                                USin   _   -> True-                                UAsin  _   -> True-                                UCos   _   -> True-                                UAcos  _   -> True-                                USinh  _   -> True-                                UCosh  _   -> True-                                UAsinh _   -> True-                                UAcosh _   -> True-                                UAtan  _   -> True-                                UAtanh _   -> True-                                _          -> False+-- containMathHFunctions :: [Rule] -> Bool+-- containMathHFunctions rules = +--   any math rules+--   where math rule = case rule of+--                       Rule _ _ _ _ _ _ _ b -> b+--                       _                    -> False -writeC :: Name -> Config -> StateHierarchy -> [Rule] -> Schedule -> [Name] +writeC :: Name -> Config -> StateHierarchy -> [Rule] -> Schedule -> [Name]        -> [Name] -> [(Name, Type)] -> IO RuleCoverage-writeC name config state rules schedule assertionNames coverageNames probeNames = do+writeC name config state rules (mp, 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' ]@@ -203,22 +192,33 @@   c = unlines     [ "#include <stdbool.h>"     , "#include <stdint.h>"-    , codeIf ( containMathHFunctions rules ) "#include <math.h>"+    , codeIf (M.fold (\_ e ans -> isMathHCall e || ans ) False (snd mp)) +             "#include <math.h>"     , ""     , preCode     , ""     , "static " ++ globalType ++ " " ++ globalClk ++ " = 0;"-    , codeIf (cRuleCoverage config) $ "static const " ++ cType Word32 +    , ""+    , case hardwareClock config of+        Nothing -> ""+        Just _  -> "static " ++ globalType ++ " " ++ phaseStartTime ++ ";"+    , ""+    , codeIf (cRuleCoverage config) $ "static const " ++ cType Word32                  ++ " __coverage_len = " ++ show covLen ++ ";"-    , codeIf (cRuleCoverage config) $ "static " ++ cType Word32 -                 ++ " __coverage[" ++ 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+    , codeIf (cRuleCoverage config) +             ("static " ++ cType Word32 ++ " __coverage_index = 0;")+    , declState True (StateHierarchy (cStateName config) [state])+    , concatMap (codeRule mp config) rules'+    , codeAssertionChecks mp config assertionNames coverageNames rules     , "void " ++ funcName ++ "() {"     , swOrHwClock+    , unlines [ swOrHwClock+              , codePeriodPhases+              , "  " ++ globalClk ++ " = " ++ globalClk ++ " + 1;"+              ]     , "}"     , ""     , postCode@@ -226,32 +226,84 @@    codePeriodPhases = concatMap (codePeriodPhase config) schedule -  swOrHwClock = +  swOrHwClock =     case hardwareClock config of-      Nothing      -> unlines [codePeriodPhases, "  " ++ globalClk ++ " = " ++ globalClk ++ " + 1;"]-      Just clkData -> unlines +      Nothing      -> ""+      Just clkData -> unlines         [ ""-        , codePeriodPhases-        , "  // In the following we sample the hardware clock, waiting for the next phase."-        , ""         , "  " ++ declareConst phaseConst clkDelta-        , "  " ++ declareConst maxConst maxVal-        , "  " ++ globalType ++ " " ++ setTime+        , "  " ++ declareConst maxConst   maxVal+        , "  static " ++ globalType ++ " " ++ lastPhaseStartTime ++ ";"+        , "  static " ++ globalType ++ " " ++ lastTime ++ ";"+        , "  static bool __first_call = true;"+        , "  " ++ globalType ++ " " ++ currentTime ++ ";"         , ""-        , errCheck -        , "  " ++ setTime ++ " // Update the current time."-        , "  // Wait until the phase has expired.  If the current time hasn't"-        , "  // overflowed, execute the first branch; otherwise, the second."-        , "  if (" ++ currentTime ++ " >= " ++ globalClk ++ ") {"-        , "    " ++ delayFn ++ "(" ++ phaseConst ++ " - (" ++ currentTime-                   ++ " - " ++ globalClk ++ "));" +        , "  /* save the current time */"+        , "  " ++ setTime+        , ""+        , "  /* initialize static variables on the first call */"+        , "  if ( __first_call ) {"+        , "    " ++ lastPhaseStartTime ++ " = " ++ phaseStartTime ++ ";"+        , "    " ++ lastTime ++ " = " ++ currentTime ++ ";"+        , "    __first_call = false;"         , "  }"-        , "  else {"-        , "    " ++ delayFn ++ "(" ++ phaseConst ++ " - (" ++ currentTime ++ " + (" -                 ++ maxConst ++ " - " ++ globalClk ++ ")));"+        , ""+        , "  /* wait for the amount left for the phase start time to be reached,"+        , "     handle roll-overs of the system timer and the phase start time */"+        , "  if ( " ++ phaseStartTime ++ " >= " ++ lastPhaseStartTime ++ " ) {"+        , "    /* phase start time did not roll over */"+        , "    if ( " ++ currentTime ++ " >= " ++ lastTime ++ " ) {"+        , "      /* system time and the phase start time did not roll over */"+        , "      if ( " ++ phaseStartTime ++ " >= " ++ currentTime ++ " ) {"+        , "        " ++ delayFn ++ " ( " ++ phaseStartTime ++ " - " ++ currentTime ++ " );"+        , "      } else {"+        , "        /* we are late */"+        , "        " ++ errHandler+        , "      }"+        , "    } else {"+        , "      /* system time rolled over, the start time of the"+        , "         phase did not, i.e. we are not late if currentTime"+        , "         is already in between lastPhaseStartTime and phaseStartTime */"+        , "      if ( ( " ++ currentTime ++ " >= " ++ lastPhaseStartTime ++ " )"+        , "             && ( " ++ phaseStartTime ++ " >= " ++ currentTime ++ " ) ) {"+        , "        " ++ delayFn ++ " ( " ++ phaseStartTime ++ " - " ++ currentTime ++ " );"+        , "      } else {"+        , "        /* we are late */"+        , "        " ++ errHandler+        , "      }"+        , "    }"+        , "  } else {"+        , "    /* phase start time rolled over */"+        , "    if ( " ++ currentTime ++ " >= " ++ lastTime ++ " ) {"+        , "      /* current time did not yet roll over */"+        , "      if ( " ++ currentTime ++ " >= " ++ phaseStartTime ++ " ) {"+        , "        " ++ delayFn ++ " ( ( " ++ maxConst+                         ++ " - ( " ++ currentTime+                             ++ " - " ++ phaseStartTime ++ " ) + 1 )" ++ " );"+        , "      } else {"+        , "        /* this should not happen, since " ++ phaseConst ++ " should be"+        , "           smaller than " ++ maxConst ++ " and " ++ lastTime ++ " should"+        , "           be smaller than or equal to " ++ currentTime ++ " */"+        , "        " ++ errHandler+        , "      }"+        , "    } else {"+        , "      /* current time and phase start time rolled over"+        , "         equal to the first case */"+        , "      if ( " ++ phaseStartTime ++ " >= " ++ currentTime ++ " ) {"+        , "        " ++ delayFn ++ " ( " ++ phaseStartTime ++ " - " ++ currentTime ++ " );"+        , "      } else {"+        , "        /* we are late */"+        , "        " ++ errHandler+        , "      }"+        , "    }"         , "  }"         , ""-        , "  " ++ setGlobalClk clkData+        , ""+        , "  /* update to the next phase start time */"+        , "  " ++ lastPhaseStartTime ++ " = " ++ phaseStartTime ++ ";"+        , "  " ++ phaseStartTime ++ " = " ++ phaseStartTime ++ " + "+               ++ phaseConst ++ ";"+        , "  " ++ lastTime ++ " = " ++ currentTime ++ ";"         ]         where           delayFn = delay clkData@@ -266,8 +318,9 @@                                    ++ " = " ++ showConst (constType c) ++ ";"           setTime     = currentTime ++ " = " ++ clockName clkData ++ "();"           maxConst    = "__max"-          phaseConst = "__phase_len"+          phaseConst  = "__phase_len"           currentTime = "__curr_time"+          lastTime    = "__last_time"           clkDelta | d <= 0                        = error $ "The delta "                                  ++ show d@@ -283,23 +336,10 @@                    | otherwise                        = d             where d = delta clkData-          errCheck =+          errHandler =             case err clkData of               Nothing    -> ""-              Just errF  -> unlines-                [ "  // An error check for when the phase has already expired."-                , "  // The first disjunct is for when the current time has not overflowed,"-                , "  // and the second for when it has."-                , "  if (   ((" ++ currentTime ++ " >= " ++ globalClk ++ ") && (" -                                ++ currentTime ++ " - " ++ globalClk -                                ++ " > " ++ phaseConst ++ "))" -                , "      || (("-                             ++ currentTime ++ " < " ++ globalClk ++ ") && ((" ++ maxConst -                             ++ " - " ++ globalClk ++ ") + " ++ currentTime ++ " > " -                             ++ phaseConst ++ "))) {"-                , "    " ++ errF ++ "();"-                , "  }"-                ]+              Just errF  -> errF ++ " ();"           constType :: Integer -> Const           constType c = case clockType clkData of                           Word8  -> CWord8  (fromInteger c :: Word8)@@ -307,14 +347,14 @@                           Word32 -> CWord32 (fromInteger c :: Word32)                           Word64 -> CWord64 (fromInteger c :: Word64)                           _      -> clkTypeErr-                                               +   h = unlines     [ "#include <stdbool.h>"     , "#include <stdint.h>"     , ""     , "void " ++ funcName ++ "();"     , ""-    , declState False $ StateHierarchy (cStateName config) [state]+    , declState False (StateHierarchy (cStateName config) [state])     ]    globalType = cType (case hardwareClock config of@@ -325,7 +365,6 @@                                           Word32 -> Word32                                           Word64 -> Word64                                           _      -> clkTypeErr)-   clkTypeErr :: a   clkTypeErr = error "Clock type must be one of Word8, Word16, Word32, Word64." @@ -336,68 +375,88 @@    covLen = 1 + div (maximum $ map ruleId rules') 32 -  setGlobalClk clkData = globalClk ++ " = " ++ clockName clkData ++ "();"+  phaseStartTime     = "__phase_start_time"+  lastPhaseStartTime = "__last_phase_start_time" + 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"+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"+    StateHierarchy name items -> +         i ++ "struct {  /* " ++ name ++ " */\n" +      ++ concatMap (f1 ("  " ++ i)) items ++ i ++ "} " ++ name ++ ";\n"+    StateVariable  name c     -> i ++ cType (E.typeOf c) ++ " " ++ name ++ ";\n"+    StateArray     name c     -> +      i ++ cType (E.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 ++ "}"+    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 ++ " */\n" ++ i ++ "{ " ++ intercalate ("\n" ++ i ++ ", ") (map showConst c) ++ "\n" ++ i ++ "}"+    StateArray     name c     -> +         i ++ "/* " ++ name ++ " */\n" ++ i ++ "{ " +      ++ intercalate ("\n" ++ i ++ ", ") (map showConst c) ++ "\n" ++ i ++ "}" -codeRule :: Config -> Rule -> String-codeRule config rule@(Rule _ _ _ _ _ _ _) =+codeRule :: UeMap -> Config -> Rule -> String+codeRule mp config rule@(Rule _ _ _ _ _ _ _) =   "/* " ++ show rule ++ " */\n" ++   "static void __r" ++ show (ruleId rule) ++ "() {\n" ++-  concatMap (codeUE config ues "  ") ues +++  concatMap (codeUE mp 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"+  codeIf (cRuleCoverage config) +         ( "    __coverage[" ++ covWord ++ "] = __coverage[" ++ covWord +          ++ "] | (1 << " ++ covBit ++ ");\n") +  ++ "  }\n" ++ concatMap codeAssign (ruleAssigns rule) ++ "}\n\n"   where-  ues = topo $ allUEs rule+  ues = topo mp $ allUEs rule   id ue = fromJust $ lookup ue ues -  codeAction :: (([String] -> String), [UE]) -> String+  codeAction :: (([String] -> String), [Hash]) -> 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 :: (MUV, Hash) -> 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+      MUV _ n _                     -> concat [cStateName config, ".", n]+      MUVArray (UA _ n _)     index -> +        concat [cStateName config, ".", n, "[", id index, "]"]+      MUVArray (UAExtern n _) index -> concat [n, "[", id index, "]"]+      MUVExtern n _                 -> n -codeRule _ _ = ""+codeRule _ _ _ = ""  globalClk :: String globalClk = "__global_clock" -codeAssertionChecks :: Config -> [Name] -> [Name] -> [Rule] -> String-codeAssertionChecks config assertionNames coverageNames rules = codeIf (cAssert config) $+codeAssertionChecks :: UeMap -> Config -> [Name] -> [Name] -> [Rule] -> String+codeAssertionChecks mp 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 ++ ", " ++ globalClk ++ ");\n" | Assert name enable check <- rules ] ++-  concat [ "  if (" ++ id enable ++ ") " ++ cCoverName  config ++ "(" ++ coverageId  name ++ ", " ++ id check ++ ", " ++ globalClk ++ ");\n" | Cover  name enable check <- rules ] +++  concatMap (codeUE mp config ues "  ") ues +++  concat [     "  if (" ++ id enable ++ ") " ++ cAssertName config +            ++ "(" ++ assertionId name ++ ", " ++ id check ++ ", " +            ++ globalClk ++ ");\n"                                 +          | Assert name enable check <- rules ] +++  concat [     "  if (" ++ id enable ++ ") " ++ cCoverName  config +            ++ "(" ++ coverageId  name ++ ", " ++ id check ++ ", " +            ++ globalClk ++ ");\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 ]+  ues = topo mp $    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

@@ -12,25 +12,28 @@ import Language.Atom.Code import Language.Atom.Scheduling import Language.Atom.Elaboration+import Language.Atom.UeMap (emptyMap) 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 () +        -> IO (Schedule, RuleCoverage, [Name], [Name], [(Name, Type)]) compile name config atom = do-  r <- elaborate name atom-  case r of+  res <- elaborate emptyMap name atom+  case res 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+    Just (st,(state, rules, assertionNames, coverageNames, probeNames)) -> do+      let schedule' = schedule rules st+      ruleCoverage <- writeC name config state rules schedule' assertionNames+                             coverageNames probeNames       when (isJust $ hardwareClock config) (putStrLn hwClockWarning)       return (schedule', ruleCoverage, assertionNames, coverageNames, probeNames)  hwClockWarning :: String hwClockWarning = unlines  [ ""- , "*** Atom WARNING: you are configuring to use a harware clock.  Please remember to assign" - , "    the current time (accoring to your clockName field in Clock) the first time you"- , "    enter the main Atom-generated function calling your rules."+ , "*** Atom WARNING: you are configuring to use a harware clock.  Please remember to set"+ , "    the \"__phase_start_time\" variable to the time at which the first phase should be"+ , "    run before you enter the main Atom-generated function the first time."  , ""  ]

@@ -1,5 +1,6 @@ module Language.Atom.Elaboration   (+--    UeStateT   -- * Atom monad and container.     Atom   , AtomDB     (..)@@ -28,8 +29,12 @@ import Data.Function (on) import Data.List import Data.Char-import Language.Atom.Expressions+import qualified Control.Monad.State.Strict as S +import Language.Atom.Expressions hiding (typeOf)+import Language.Atom.UeMap++ type UID = Int  -- | A name.@@ -46,7 +51,7 @@   , gVarId   :: Int   , gArrayId :: Int   , gState   :: [StateHierarchy]-  , gProbes  :: [(String, UE)]+  , gProbes  :: [(String, Hash)]   , gPeriod  :: Int   , gPhase   :: Phase   }@@ -55,35 +60,36 @@   { atomId          :: Int   , atomName        :: Name   , atomNames       :: [Name]      -- Names used at this level.-  , atomEnable      :: UE          -- Enabling condition.+  , atomEnable      :: Hash        -- Enabling condition.   , atomSubs        :: [AtomDB]    -- Sub atoms.   , atomPeriod      :: Int   , atomPhase       :: Phase-  , atomAssigns     :: [(UV, UE)]-  , atomActions     :: [([String] -> String, [UE])]-  , atomAsserts     :: [(Name, UE)]-  , atomCovers      :: [(Name, UE)]+  , atomAssigns     :: [(MUV, Hash)]+  , atomActions     :: [([String] -> String, [Hash])]+  , atomAsserts     :: [(Name, Hash)]+  , atomCovers      :: [(Name, Hash)]   }  data Rule   = Rule     { ruleId        :: Int     , ruleName      :: Name-    , ruleEnable    :: UE-    , ruleAssigns   :: [(UV, UE)]-    , ruleActions   :: [([String] -> String, [UE])]+    , ruleEnable    :: Hash+    , ruleAssigns   :: [(MUV, Hash)]+    , ruleActions   :: [([String] -> String, [Hash])]     , rulePeriod    :: Int     , rulePhase     :: Phase+--    , mathH         :: Bool -- Contains a math.h call?     }   | Assert     { ruleName      :: Name-    , ruleEnable    :: UE-    , ruleAssert    :: UE+    , ruleEnable    :: Hash+    , ruleAssert    :: Hash     }   | Cover     { ruleName      :: Name-    , ruleEnable    :: UE-    , ruleCover     :: UE+    , ruleEnable    :: Hash+    , ruleCover     :: Hash     }  data StateHierarchy@@ -96,57 +102,109 @@ 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+elaborateRules:: Hash -> AtomDB -> UeState [Rule]+elaborateRules parentEnable atom = +  if isRule +    then do r <- rule+            rs <- rules +            return $ r : rs +    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)+  enable :: UeState Hash+  enable = do+    st <- S.get+    let (h,st') = newUE (uand (recoverUE st parentEnable)+                              (recoverUE st (atomEnable atom)))+                         st+    S.put st'+    return h+  rule :: UeState Rule+  rule = do +    h <- enable +    assigns <- S.foldM (\prs pr -> do pr' <- enableAssign pr                                      +                                      return $ pr' : prs) [] +                       (atomAssigns atom)+--    st <- S.get+    return $ Rule+      { ruleId        = atomId   atom+      , ruleName      = atomName atom+      , ruleEnable    = h+      , ruleAssigns   = assigns+      , ruleActions   = atomActions atom+      , rulePeriod    = atomPeriod  atom+      , rulePhase     = atomPhase   atom+      }+  assert :: (Name, Hash) -> UeState Rule+  assert (name, ue) = do +    h <- enable +    return $ Assert+      { ruleName      = name+      , ruleEnable    = h+      , ruleAssert    = ue+      }+  cover :: (Name, Hash) -> UeState Rule+  cover (name, ue) = do +    h <- enable +    return $ Cover+      { ruleName      = name+      , ruleEnable    = h+      , ruleCover     = ue+      }+  rules :: UeState [Rule]+  rules = do+    asserts <- S.foldM (\rs e -> do r <- assert e+                                    return $ r:rs+                       ) [] (atomAsserts atom) +    covers  <- S.foldM (\rs e -> do r <- cover e+                                    return $ r:rs+                       ) [] (atomCovers atom) +    rules'  <- S.foldM (\rs db -> do en <- enable+                                     r <- elaborateRules en db+                                     return $ r:rs+                       ) [] (atomSubs atom)+    return $ asserts ++ covers ++ concat rules'+  enableAssign :: (MUV, Hash) -> UeState (MUV, Hash)+  enableAssign (uv, ue) = do +    e <- enable+    h <- maybeUpdate (MUVRef uv)+    st <- S.get +    let (h',st') = newUE (umux (recoverUE st e) +                               (recoverUE st ue) +                               (recoverUE st h))+                         st+    S.put st'+    return (uv, h')  reIdRules :: Int -> [Rule] -> [Rule] reIdRules _ [] = [] reIdRules i (a:b) = case a of   Rule _ _ _ _ _ _ _ -> a { ruleId = i } : reIdRules (i + 1) b-  _                  -> a                : reIdRules  i      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    = []-  })+buildAtom :: UeMap -> Global -> Name -> Atom a -> IO (a, AtomSt)+buildAtom st g name (Atom f) = do+  let (h,st') = newUE (ubool True) st+--  S.put st' +  f (st', (g { gRuleId = gRuleId g + 1 }, AtomDB+                 { atomId        = gRuleId g+                 , atomName      = name+                 , atomNames     = []+                 , atomEnable    = h +                 , atomSubs      = []+                 , atomPeriod    = gPeriod g+                 , atomPhase     = gPhase  g+                 , atomAssigns   = []+                 , atomActions   = []+                 , atomAsserts   = []+                 , atomCovers    = []+                 }))+--  S.return db +type AtomSt = (UeMap, (Global, AtomDB))+ -- | The Atom monad holds variable and rule declarations.-data Atom a = Atom ((Global, AtomDB) -> IO (a, (Global, AtomDB)))+data Atom a = Atom (AtomSt -> IO (a, AtomSt))  instance Monad Atom where   return a = Atom (\ s -> return (a, s))@@ -164,35 +222,58 @@       a <- io       return (a, s) -get :: Atom (Global, AtomDB)+get :: Atom AtomSt get = Atom (\ s -> return (s, s)) -put :: (Global, AtomDB) -> Atom ()+put :: AtomSt -> 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) +-- XXX elaborate is a bit hacky since we're threading state through this+-- function, but I don't want to go change all the UeState monads to UeStateT+-- monads. -- | 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  = MinPhase 0 } name atom-  let rules = reIdRules 0 $ elaborateRules (ubool True) atomDB+elaborate :: UeMap -> Name -> Atom () +          -> IO (Maybe ( UeMap+                       , (  StateHierarchy, [Rule], [Name], [Name]+                          , [(Name, Type)])+                       ))+elaborate st name atom = do+  (_, (st0, (g, atomDB))) <- buildAtom st Global { gRuleId = 0+                                                 , gVarId = 0+                                                 , gArrayId = 0+                                                 , gState = []+                                                 , gProbes = []+                                                 , gPeriod = 1+                                                 , gPhase  = MinPhase 0 +                                                 } +                                       name atom +  let (h,st1) = newUE (ubool True) st0+      (getRules,st2) = S.runState (elaborateRules h atomDB) st1+      rules = reIdRules 0 (reverse getRules)       coverageNames  = [ name | Cover  name _ _ <- rules ]       assertionNames = [ name | Assert name _ _ <- rules ]-      probeNames = [ (n, typeOf a) | (n, a) <- gProbes g ]-  if (null rules)+      probeNames = [ (n, typeOf a st2) | (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+      mapM_ (checkEnable st2) rules       ok <- mapM checkAssignConflicts rules-      return (if and ok then Just (trimState $ StateHierarchy name $ gState g, rules, assertionNames, coverageNames, probeNames) else Nothing)+      return (if and ok +                then Just ( st2+                          , (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+  StateHierarchy name items -> +    StateHierarchy name $ filter f $ map trimState items    a -> a   where   f (StateHierarchy _ []) = False@@ -200,16 +281,21 @@   -- | 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 ()+checkEnable :: UeMap -> Rule -> IO ()+checkEnable st rule +  | ruleEnable rule == (fst $ newUE (ubool False) st) = +      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.+-- | 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 _ _ _ _ _ _ _) =+checkAssignConflicts rule@(Rule _ _ _ _ _ _ _) =    if length vars /= length vars'     then do-      putStrLn $ "ERROR: Rule " ++ show rule ++ " contains multiple assignments to the same variable(s)."+      putStrLn $ "ERROR: Rule " +                   ++ show rule +                   ++ " contains multiple assignments to the same variable(s)."       return False     else do       return True@@ -246,10 +332,10 @@ var :: Expr a => Name -> a -> Atom (V a) var name init = do   name' <- addName name-  (g, atom) <- get+  (st, (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)+  put (st, (g { gVarId = gVarId g + 1, gState = gState g ++ [StateVariable name c] }, atom))   return $ V uv  -- | Generic external variable declaration.@@ -261,10 +347,10 @@ array name [] = error $ "ERROR: arrays can not be empty: " ++ name array name init = do   name' <- addName name-  (g, atom) <- get+  (st, (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)+  put (st, (g { gArrayId = gArrayId g + 1, gState = gState g ++ [StateArray name c] }, atom))   return $ A ua  -- | Generic external array declaration.@@ -273,12 +359,12 @@  addName :: Name -> Atom Name addName name = do-  (g, atom) <- get+  (st, (g, atom)) <- get   checkName name   if elem name (atomNames atom)     then error $ "ERROR: Name \"" ++ name ++ "\" not unique in " ++ show atom ++ "."     else do-      put (g, atom { atomNames = name : atomNames atom })+      put (st, (g, atom { atomNames = name : atomNames atom }))       return $ atomName atom ++ "." ++ name  -- still accepts some misformed names@@ -319,13 +405,13 @@ -}  -- | All the variables that directly and indirectly control the value of an expression.-allUVs :: [Rule] -> UE -> [UV]-allUVs rules ue = fixedpoint next $ nearestUVs ue+allUVs :: UeMap -> [Rule] -> Hash -> [MUV]+allUVs st rules ue = fixedpoint next $ nearestUVs ue st   where   assigns = concat [ ruleAssigns r | r@(Rule _ _ _ _ _ _ _) <- rules ]-  previousUVs :: UV -> [UV]-  previousUVs uv = concat [ nearestUVs ue | (uv', ue) <- assigns, uv == uv' ]-  next :: [UV] -> [UV]+  previousUVs :: MUV -> [MUV]+  previousUVs uv = concat [ nearestUVs ue st | (uv', ue) <- assigns, uv == uv' ]+  next :: [MUV] -> [MUV]   next uvs = sort $ nub $ uvs ++ concatMap previousUVs uvs  fixedpoint :: Eq a => (a -> a) -> a -> a@@ -333,14 +419,16 @@                | otherwise = fixedpoint f $ f a  -- | All primary expressions used in a rule.-allUEs :: Rule -> [UE]+allUEs :: Rule -> [Hash] allUEs rule = ruleEnable rule : ues   where-  index :: UV -> [UE]-  index (UVArray _ ue) = [ue]+  index :: MUV -> [Hash]+  index (MUVArray _ ue) = [ue]   index _ = []   ues = case rule of-    Rule _ _ _ _ _ _ _ -> concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ] ++ concat (snd (unzip (ruleActions rule)))+    Rule _ _ _ _ _ _ _ -> +         concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ] +      ++ concat (snd (unzip (ruleActions rule)))     Assert _ _ a       -> [a]     Cover  _ _ a       -> [a] 

@@ -19,9 +19,10 @@   , bytes   , ue   , uv-  , ueUpstream-  , nearestUVs-  , arrayIndices+--  , ueUpstream+--  , isMathHCall+--  , nearestUVs+--  , arrayIndices   , NumE   , IntegralE   , FloatingE@@ -708,67 +709,6 @@ (!.) :: (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]--- math.h:-  UPi         -> []-  UExp   a    -> [a]-  ULog   a    -> [a]-  USqrt  a    -> [a]-  UPow   a b  -> [a, b]-  USin   a    -> [a]-  UAsin  a    -> [a]-  UCos   a    -> [a]-  UAcos  a    -> [a]-  USinh  a    -> [a]-  UCosh  a    -> [a]-  UAsinh a    -> [a]-  UAcosh a    -> [a]-  UAtan  a    -> [a]-  UAtanh 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

@@ -66,10 +66,12 @@ import Control.Monad.Trans import Data.Int import Data.Word+import Data.List (foldl')  import Language.Atom.Elaboration hiding (Atom) import qualified Language.Atom.Elaboration as E import Language.Atom.Expressions+import Language.Atom.UeMap hiding (typeOf)  infixr 1 <== @@ -80,9 +82,10 @@ 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] })+  (st1, (g1, parent)) <- get+  (a, (st2, (g2, child))) <- liftIO $ buildAtom st1 g1 { gState = [] } name' design+  put (st2, ( 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.@@ -92,30 +95,30 @@ 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)+  (st, (g, a)) <- get+  put (st, (g { gPeriod = n }, a))   r <- atom-  (g', a) <- get-  put (g' { gPeriod = gPeriod g }, a)+  (st', (g', a)) <- get+  put (st', (g' { gPeriod = gPeriod g }, a))   return r  -- | Returns the execution period of the current scope. getPeriod :: Atom Int getPeriod = do-  (g, _) <- get+  (_, (g, _)) <- get   return $ gPeriod g  phase' :: (Int -> Phase) -> Int -> Atom a -> Atom a phase' _ n _ | n < 0 = error $ "ERROR: phase " ++ show n ++ " must be at least 0." phase' phType n atom = do-  (g, a) <- get+  (st, (g, a)) <- get   if (n >= gPeriod g)      then error $ "ERROR: phase " ++ show n ++ " must be less than the current period "                ++ show (gPeriod g) ++ "."-    else do put (g { gPhase = phType n }, a)+    else do put (st, (g { gPhase = phType n }, a))             r <- atom-            (g', a) <- get-            put (g' { gPhase = gPhase g }, a)+            (st', (g', a)) <- get+            put (st', (g' { gPhase = gPhase g }, a))             return r     -- XXX     -- else do put (g { gPhase = n }, a)@@ -138,7 +141,7 @@ -- | Returns the phase of the current scope. getPhase :: Atom Int getPhase = do-  (g, _) <- get+  (_, (g, _)) <- get   return $ case gPhase g of              MinPhase ph   -> ph              ExactPhase ph -> ph@@ -146,7 +149,7 @@ -- | Returns the current atom hierarchical path. path :: Atom String path = do-  (_, atom) <- get+  (_, (_, atom)) <- get   return $ atomName atom  -- | Local boolean variable declaration.@@ -240,8 +243,11 @@ -- | Declares an action. action :: ([String] -> String) -> [UE] -> Atom () action f ues = do-  (g, a) <- get-  put (g, a { atomActions = atomActions a ++ [(f, ues)] })+  (st, (g, a)) <- get+  let (st', hashes) = foldl' (\(accSt,hs) ue -> let (h,accSt') = newUE ue accSt in+                                                (accSt',h:hs))+                             (st,[]) ues+  put (st', (g, a { atomActions = atomActions a ++ [(f, hashes)] }))  -- | Calls an external C function of type 'void f(void)'. call :: Name -> Atom ()@@ -250,18 +256,19 @@ -- | Declares a probe. probe :: Expr a => Name -> E a -> Atom () probe name a = do-  (g, atom) <- get+  (st, (g, atom)) <- get+  let (h,st') = newUE (ue a) st   if any (\ (n, _) -> name == n) $ gProbes g     then error $ "ERROR: Duplicated probe name: " ++ name-    else put (g { gProbes = (name, ue a) : gProbes g }, atom)-+    else put (st', (g { gProbes = (name, h) : gProbes g }, atom))  -- | Fetches all declared probes to current design point. probes :: Atom [(String, UE)] probes = do-  (g, _) <- get-  return $ gProbes g-+  (st, (g, _)) <- get+  let (strs,hs) = unzip (gProbes g)+  let g' = zip strs (map (recoverUE st) hs)+  return g'  -- | Increments a NumE 'V'. incr :: (Assign a, NumE a) => V a -> Atom ()@@ -276,8 +283,10 @@   -- | 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 })+    (st, (g, atom)) <- get+    let (h,st0) = newUE (ue e) st+    let (muv,st1) = newUV (uv v) st0+    put (st1, (g, atom { atomAssigns = (muv, h) : atomAssigns atom }))  instance Assign Bool instance Assign Int8@@ -292,12 +301,14 @@ 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.+-- 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) })+  (st, (g, atom)) <- get+  let ae = recoverUE st (atomEnable atom)+  let (h,st') = newUE (uand ae (ue c)) st+  put (st', (g, atom { atomEnable = h}))  -- | Reference to the 64-bit free running clock. clock :: E Word64@@ -310,15 +321,17 @@   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.+-- | 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+  (st, (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 })+  let (chk,st') = newUE (ue check) st+  put (st', (g, atom { atomAsserts = (name, chk) : atomAsserts atom }))  -- | Implication assertions.  Creates an implicit coverage point for the precondition. assertImply :: Name -> E Bool -> E Bool -> Atom ()@@ -331,8 +344,9 @@ --   Coverage names should be globally unique. cover :: Name -> E Bool -> Atom () cover name check = do-  (g, atom) <- get+  (st, (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 })+  let (chk,st') = newUE (ue check) st+  put (st', (g, atom { atomCovers = (name, chk) : atomCovers atom })) 

@@ -5,15 +5,17 @@   , reportSchedule   ) where +import Text.Printf import Data.List+ import Language.Atom.Analysis import Language.Atom.Elaboration-import Text.Printf+import Language.Atom.UeMap -type Schedule = [(Int, Int, [Rule])]  -- (period, phase, rules)+type Schedule = (UeMap, [(Int, Int, [Rule])])  -- (period, phase, rules) -schedule :: [Rule] -> Schedule-schedule rules' = concatMap spread periods+schedule :: [Rule] -> UeMap -> Schedule+schedule rules' mp = (mp, concatMap spread periods)   where   rules = [ r | r@(Rule _ _ _ _ _ _ _) <- rules' ] @@ -42,7 +44,7 @@     -- 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 :: (Int, [Rule]) -> [(Int, Int, [Rule])]   spread (period, rules) =      placeRules (placeExactRules (replicate period []) exactRules)                orderedByPhase@@ -88,32 +90,30 @@   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+reportSchedule (mp, schedule) = concat   [ "Rule Scheduling Report\n\n"   , "Period  Phase  Exprs  Rule\n"   , "------  -----  -----  ----\n"-  , concatMap reportPeriod schedule+  , concatMap (reportPeriod mp) schedule   , "               -----\n"-  , printf "               %5i\n" $ sum $ map ruleComplexity rules+  , printf "               %5i\n" $ sum $ map (ruleComplexity mp) rules   , "\n"   , "Hierarchical Expression Count\n\n"   , "  Total   Local     Rule\n"   , "  ------  ------    ----\n"-  , reportUsage "" $ usage rules+  , reportUsage "" $ usage mp rules   , "\n"   ]   where   rules = concat $ [ r | (_, _, r) <- schedule ]  -reportPeriod :: (Int, Int, [Rule]) -> String-reportPeriod (period, phase, rules) = concatMap reportRule rules+reportPeriod :: UeMap -> (Int, Int, [Rule]) -> String+reportPeriod mp (period, phase, rules) = concatMap reportRule rules   where   reportRule :: Rule -> String-  reportRule rule = printf "%6i  %5i  %5i  %s\n" period phase (ruleComplexity rule) (show rule)+  reportRule rule = printf "%6i  %5i  %5i  %s\n" period phase (ruleComplexity mp rule) (show rule)   data Usage = Usage String Int [Usage] deriving Eq@@ -126,15 +126,15 @@ totalComplexity :: Usage -> Int totalComplexity (Usage _ n subs) = n + sum (map totalComplexity subs) -usage :: [Rule] -> Usage-usage = head . foldl insertUsage [] . map usage'+usage :: UeMap -> [Rule] -> Usage+usage mp = head . foldl insertUsage [] . map (usage' mp) -usage' :: Rule -> Usage-usage' rule = f $ split $ ruleName rule+usage' :: UeMap -> Rule -> Usage+usage' mp rule = f $ split $ ruleName rule   where   f :: [String] -> Usage   f [] = undefined-  f [name] = Usage name (ruleComplexity rule) []+  f [name] = Usage name (ruleComplexity mp rule) []   f (name:names) = Usage name 0 [f names]  split :: String -> [String]

@@ -0,0 +1,375 @@+-- | Sharing for UEs, based on IntMaps.  The idea is to share subexpressions of 'UE's.++module Language.Atom.UeMap +  ( UeElem (..)+  , MUV (..)+  , UeMap+  , emptyMap+  , Hash+  , typeOf+  , UeState+  , recoverUE+  , getUE+  , newUE+  , newUV+--  , share+  , maybeUpdate+  , ueUpstream+  , nearestUVs+  , arrayIndices+  , isMathHCall+  ) where++import Control.Monad.State.Strict+--import qualified Data.IntMap as M+import qualified Data.Bimap as M+import Data.List (nub)++import Language.Atom.Expressions hiding (typeOf)+import qualified Language.Atom.Expressions as E++type Hash = Int++-- | Untyped variables map.+data MUV+  = MUV Int String Const+  | MUVArray UA Hash+  | MUVExtern String Type+  deriving (Show, Eq, Ord)++-- | Transforms a 'UV' into a 'MUV', returning the possibly updated map.+newUV :: UV -> UeMap -> (MUV, UeMap)+newUV uv mp = +  case uv of+    UV i j k       -> (MUV i j k, mp)+    UVExtern i j   -> (MUVExtern i j, mp)+    UVArray arr ue -> let (h,mp') = newUE ue mp in+                      (MUVArray arr h, mp')++-- | Corresponds to 'UE's --- the elements in the sharing structure.+data UeElem+  = MUVRef !MUV+  | MUConst !Const+  | MUCast  !Type !Hash+  | MUAdd   !Hash !Hash+  | MUSub   !Hash !Hash+  | MUMul   !Hash !Hash+  | MUDiv   !Hash !Hash+  | MUMod   !Hash !Hash+  | MUNot   !Hash+  | MUAnd   [Hash]+  | MUBWNot !Hash+  | MUBWAnd !Hash !Hash+  | MUBWOr  !Hash !Hash+  | MUShift !Hash !Int+  | MUEq    !Hash !Hash+  | MULt    !Hash !Hash+  | MUMux   !Hash !Hash !Hash+  | MUF2B   !Hash+  | MUD2B   !Hash+  | MUB2F   !Hash+  | MUB2D   !Hash+-- math.h:+  | MUPi+  | MUExp   !Hash+  | MULog   !Hash+  | MUSqrt  !Hash+  | MUPow   !Hash !Hash+  | MUSin   !Hash+  | MUAsin  !Hash+  | MUCos   !Hash+  | MUAcos  !Hash+  | MUSinh  !Hash+  | MUCosh  !Hash+  | MUAsinh !Hash+  | MUAcosh !Hash+  | MUAtan  !Hash+  | MUAtanh !Hash+  deriving (Show, Eq, Ord)++typeOf :: Hash -> UeMap -> Type+typeOf h mp = case getUE h mp of+    MUVRef (MUV _ _ a) -> E.typeOf a+    MUVRef (MUVArray a _) -> E.typeOf a+    MUVRef (MUVExtern _ t) -> t+    MUCast t _  -> t+    MUConst c   -> E.typeOf c+    MUAdd a _   -> typeOf' a+    MUSub a _   -> typeOf' a+    MUMul a _   -> typeOf' a+    MUDiv a _   -> typeOf' a+    MUMod a _   -> typeOf' a+    MUNot _     -> Bool+    MUAnd _     -> Bool+    MUBWNot a   -> typeOf' a+    MUBWAnd a _ -> typeOf' a+    MUBWOr  a _ -> typeOf' a+    MUShift a _ -> typeOf' a+    MUEq  _ _   -> Bool+    MULt  _ _   -> Bool+    MUMux _ a _ -> typeOf' a+    MUF2B _     -> Word32+    MUD2B _     -> Word64+    MUB2F _     -> Float+    MUB2D _     -> Double+-- math.h:+    MUPi        -> Double+    MUExp   a   -> typeOf' a+    MULog   a   -> typeOf' a+    MUSqrt  a   -> typeOf' a+    MUPow   a _ -> typeOf' a+    MUSin   a   -> typeOf' a+    MUAsin  a   -> typeOf' a+    MUCos   a   -> typeOf' a+    MUAcos  a   -> typeOf' a+    MUSinh  a   -> typeOf' a+    MUCosh  a   -> typeOf' a+    MUAsinh a   -> typeOf' a+    MUAcosh a   -> typeOf' a+    MUAtan  a   -> typeOf' a+    MUAtanh a   -> typeOf' a+  where +  typeOf' h' = typeOf h' mp++-- | An entry in the Map.+type UeMap = (Hash, M.Bimap Int UeElem)++-- | Wrapped in the State Monad.+type UeState a = State UeMap a++-- | Get the element associated with a 'Hash' value.  It's an error if the+-- element is not in the map.+getUE :: Hash -> UeMap -> UeElem+getUE h (_,mp) = +  case M.lookup h mp of+    Nothing -> error $ "Error looking up hash " ++ show h ++ " in the UE map\n" ++ show mp+    Just e -> e++-- | Put a new 'UE' in the map, unless it's already in there, and return the+-- hash pointing to the 'UE' and a new map.+newUE :: UE -> UeMap -> (Hash, UeMap)+newUE ue mp = runState (share ue) mp++emptyMap :: UeMap+emptyMap = (0, M.empty)++-- | Create the sharing map.+share :: UE -> UeState Hash+share e = case e of +  UVRef (UV i j k) -> maybeUpdate (MUVRef $ MUV i j k)+  UVRef (UVExtern i j) -> maybeUpdate (MUVRef $ MUVExtern i j)+  UVRef (UVArray arr a) -> unOp a (\x -> MUVRef (MUVArray arr x))+  UConst  a     -> maybeUpdate (MUConst a)+  UCast   t a   -> unOp a (MUCast t)+  UAdd    a b   -> binOp (a,b) MUAdd+  USub    a b   -> binOp (a,b) MUSub+  UMul    a b   -> binOp (a,b) MUMul+  UDiv    a b   -> binOp (a,b) MUDiv+  UMod    a b   -> binOp (a,b) MUMod+  UNot    a     -> unOp a MUNot+  UAnd    ls    -> listOp ls MUAnd+  UBWNot  a     -> unOp a MUBWNot+  UBWAnd  a b   -> binOp (a,b) MUBWAnd+  UBWOr   a b   -> binOp (a,b) MUBWOr+  UShift  a b   -> unOp a (\x -> MUShift x b)+  UEq     a b   -> binOp (a,b) MUEq+  ULt     a b   -> binOp (a,b) MULt+  UMux    a b c -> triOp (a,b,c) MUMux+  UF2B    a     -> unOp a MUF2B+  UD2B    a     -> unOp a MUD2B+  UB2F    a     -> unOp a MUB2F+  UB2D    a     -> unOp a MUB2D+-- math.h:+  UPi           -> maybeUpdate (MUPi)+  UExp    a     -> unOp a MUExp+  ULog    a     -> unOp a MULog+  USqrt   a     -> unOp a MUSqrt+  UPow    a b   -> binOp (a,b) MUPow+  USin    a     -> unOp a MUSin+  UAsin   a     -> unOp a MUAsin+  UCos    a     -> unOp a MUCos+  UAcos   a     -> unOp a MUAcos+  USinh   a     -> unOp a MUSinh+  UCosh   a     -> unOp a MUCosh+  UAsinh  a     -> unOp a MUAsinh+  UAcosh  a     -> unOp a MUAcosh+  UAtan   a     -> unOp a MUAtan+  UAtanh  a     -> unOp a MUAtanh++-- XXX I could combine some of the following functions (unOp, binOp, etc.) to+-- slightly reduce code...+unOp :: UE -> (Hash -> UeElem) -> UeState Hash+unOp e code = do+  h <- share e  +  maybeUpdate (code h)++binOp :: (UE, UE) -> (Hash -> Hash -> UeElem) -> UeState Hash+binOp (e0,e1) code = do+  h0 <- share e0  +  h1 <- share e1  +  maybeUpdate (code h0 h1)++triOp :: (UE, UE, UE) -> (Hash -> Hash -> Hash -> UeElem) -> UeState Hash+triOp (e0,e1,e2) code = do+  h0 <- share e0   +  h1 <- share e1  +  h2 <- share e2  +  maybeUpdate (code h0 h1 h2)++listOp :: [UE] -> ([Hash] -> UeElem) -> UeState Hash+listOp es code = do+  hashes <- foldM (\hashes e -> do h <- share e +                                   return (h:hashes)+                  ) [] es+  maybeUpdate (code hashes)++-- | Lookup an element in the map, and if it's in there, do nothing, but return+-- its hash value.  Otherwise, update the map and return the new hash value+-- for the inserted element.+maybeUpdate :: UeElem -> UeState Hash+maybeUpdate e = do+  st <- get+  let mp = snd st+  case M.lookupR e mp of+    Nothing -> do let hash = fst st + 1+                  put (hash, M.insert hash e mp)+                  return hash+    Just h -> return h++-- -- Lookup an elem, returning 'Nothing' if no hash exists in the map and 'Just'+-- -- the hash value otherwise.+-- getHash :: UeElem -> UeMap -> Maybe Hash+-- getHash e mp = M.lookupR e+++-- ((k,e'):_) | e == e' = Just k+-- getHash e (_:es) | otherwise = getHash e es+-- getHash _ [] = Nothing++-- | Get a 'UE' back out of the 'UeMap'.+recoverUE :: UeMap -> Hash -> UE+recoverUE st h = case getUE h st of+  MUVRef (MUV i j k)     -> UVRef (UV i j k)+  MUVRef (MUVArray i a)  -> UVRef (UVArray i (recover' a))+  MUVRef (MUVExtern i j) -> UVRef (UVExtern i j)+  MUCast t a   -> UCast   t (recover' a)+  MUConst a    -> UConst  a+  MUAdd a b    -> UAdd    (recover' a) (recover' b)+  MUSub a b    -> USub    (recover' a) (recover' b)+  MUMul a b    -> UMul    (recover' a) (recover' b)+  MUDiv a b    -> UDiv    (recover' a) (recover' b)+  MUMod a b    -> UMod    (recover' a) (recover' b)+  MUNot a      -> UNot (recover' a)+  MUAnd a      -> UAnd $ map recover' a+  MUBWNot a    -> UBWNot (recover' a)+  MUBWAnd a b  -> UBWAnd  (recover' a) (recover' b)+  MUBWOr  a b  -> UBWOr   (recover' a) (recover' b)+  MUShift a b  -> UShift  (recover' a) b+  MUEq  a b    -> UEq     (recover' a) (recover' b)+  MULt  a b    -> ULt     (recover' a) (recover' b)+  MUMux a b c  -> UMux (recover' a) (recover' b) (recover' c)+  MUF2B a      -> UF2B    (recover' a)+  MUD2B a      -> UD2B    (recover' a)+  MUB2F a      -> UB2F    (recover' a)+  MUB2D a      -> UB2D    (recover' a)+-- math.h:+  MUPi         -> UPi+  MUExp   a    -> UExp    (recover' a)+  MULog   a    -> ULog    (recover' a)+  MUSqrt  a    -> USqrt   (recover' a)+  MUPow   a b  -> UPow (recover' a) (recover' b)+  MUSin   a    -> USin    (recover' a)+  MUAsin  a    -> UAsin   (recover' a)+  MUCos   a    -> UCos    (recover' a)+  MUAcos  a    -> UAcos   (recover' a)+  MUSinh  a    -> USinh   (recover' a)+  MUCosh  a    -> UCosh   (recover' a)+  MUAsinh a    -> UAsinh  (recover' a)+  MUAcosh a    -> UAcosh  (recover' a)+  MUAtan  a    -> UAtan   (recover' a)+  MUAtanh a    -> UAtanh  (recover' a)+  where recover' h' = recoverUE st h'++-- | The list of Hashes to adjacent upstream of a UE.+ueUpstream :: Hash -> UeMap -> [Hash]+ueUpstream h t = case getUE h t of+  MUVRef (MUV _ _ _)     -> []+  MUVRef (MUVArray _ a)  -> [a]+  MUVRef (MUVExtern _ _) -> []+  MUCast _ a   -> [a]+  MUConst _    -> []+  MUAdd a b    -> [a, b]+  MUSub a b    -> [a, b]+  MUMul a b    -> [a, b]+  MUDiv a b    -> [a, b]+  MUMod a b    -> [a, b]+  MUNot a      -> [a]+  MUAnd a      -> a+  MUBWNot a    -> [a]+  MUBWAnd a b  -> [a, b]+  MUBWOr  a b  -> [a, b]+  MUShift a _  -> [a]+  MUEq  a b    -> [a, b]+  MULt  a b    -> [a, b]+  MUMux a b c  -> [a, b, c]+  MUF2B a      -> [a]+  MUD2B a      -> [a]+  MUB2F a      -> [a]+  MUB2D a      -> [a]+-- math.h:+  MUPi         -> []+  MUExp   a    -> [a]+  MULog   a    -> [a]+  MUSqrt  a    -> [a]+  MUPow   a b  -> [a, b]+  MUSin   a    -> [a]+  MUAsin  a    -> [a]+  MUCos   a    -> [a]+  MUAcos  a    -> [a]+  MUSinh  a    -> [a]+  MUCosh  a    -> [a]+  MUAsinh a    -> [a]+  MUAcosh a    -> [a]+  MUAtan  a    -> [a]+  MUAtanh a    -> [a]++-- | The list of all UVs that directly control the value of an expression.+nearestUVs :: Hash -> UeMap -> [MUV]+nearestUVs h mp = nub $ f h+  where+  f :: Hash -> [MUV]+  f hash = case getUE hash mp of+             (MUVRef uv@(MUVArray _ h')) -> [uv] ++ f h'+             (MUVRef uv)                 -> [uv]+             _                           -> concatMap f $ ueUpstream hash mp++-- | All array indexing subexpressions.+arrayIndices :: Hash -> UeMap -> [(UA, Hash)]+arrayIndices h mp = nub $ f h+  where+  f :: Hash -> [(UA, Hash)]+  f hash = case getUE hash mp of+             (MUVRef (MUVArray ua h')) -> (ua, h') : f h'+             _ -> concatMap f $ ueUpstream hash mp++-- XXX can put this back after making UE map---won't be expensive.+isMathHCall :: UeElem -> Bool+isMathHCall fc = +  case fc of+    MUPi        -> True+    MUExp   _   -> True+    MULog   _   -> True+    MUSqrt  _   -> True+    MUPow   _ _ -> True+    MUSin   _   -> True+    MUAsin  _   -> True+    MUCos   _   -> True+    MUAcos  _   -> True+    MUSinh  _   -> True+    MUCosh  _   -> True+    MUAsinh _   -> True+    MUAcosh _   -> True+    MUAtan  _   -> True+    MUAtanh _   -> True+    _          -> False+

@@ -1,5 +1,5 @@ name:    atom-version: 1.0.8+version: 1.0.9  category: Language, Embedded @@ -34,10 +34,11 @@ library     build-depends:         base       >= 4.0     && < 5,-        mtl        >= 1.1.0.1 && < 1.2,+        mtl        >= 1.1.0.1,         process    >= 1.0.1.1 && < 1.2,         syb        >= 0.1.0.0,-        uniplate   >= 1.5.0   && < 2.0+        containers >= 0.4,+        bimap      >= 0.2.4      exposed-modules:         Language.Atom@@ -51,12 +52,11 @@         Language.Atom.Language         Language.Atom.Scheduling         Language.Atom.Unit+        Language.Atom.UeMap      extensions: GADTs, DeriveDataTypeable -    if impl(ghc > 6.8)-          ghc-options: -fwarn-tabs-    ghc-options:       -W+    ghc-options: -Wall  source-repository head     type:     git