Permalink
Browse files

Map works.

  • Loading branch information...
1 parent feacaea commit 764794d75c22344d6c5af057035ad62c771e2d1f @leepike leepike committed Feb 25, 2011
Showing with 157 additions and 190 deletions.
  1. +7 −6 Language/Atom/Analysis.hs
  2. +110 −143 Language/Atom/Code.hs
  3. +3 −3 Language/Atom/Compile.hs
  4. +12 −14 Language/Atom/Elaboration.hs
  5. +20 −20 Language/Atom/Scheduling.hs
  6. +2 −3 Language/Atom/UeMap.hs
  7. +3 −1 atom.cabal
View
@@ -8,19 +8,20 @@ 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
View

Large diffs are not rendered by default.

Oops, something went wrong.
View
@@ -8,11 +8,11 @@ module Language.Atom.Compile
import System.Exit
import Control.Monad (when)
import Data.Maybe (isJust)
-import qualified Control.Monad.State as S
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.
@@ -23,8 +23,8 @@ compile name config atom = do
case res of
Nothing -> putStrLn "ERROR: Design rule checks failed." >> exitWith (ExitFailure 1)
Just (st,(state, rules, assertionNames, coverageNames, probeNames)) -> do
- let schedule' = schedule rules
- ruleCoverage <- writeC st name config state rules schedule' assertionNames
+ 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)
@@ -79,7 +79,7 @@ data Rule
, ruleActions :: [([String] -> String, [Hash])]
, rulePeriod :: Int
, rulePhase :: Phase
- , mathH :: Bool -- Contains a math.h call?
+-- , mathH :: Bool -- Contains a math.h call?
}
| Assert
{ ruleName :: Name
@@ -114,17 +114,16 @@ elaborateRules parentEnable atom =
enable :: UeState Hash
enable = do
st <- S.get
- let (h,st') = newUE (uand (recoverUE st parentEnable)
- (recoverUE st (atomEnable atom)))
+ 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
+ assigns <- S.foldM (\prs pr -> do pr' <- enableAssign pr
return $ pr' : prs) [] (atomAssigns atom)
- r <- rule
st <- S.get
return $ Rule
{ ruleId = atomId atom
@@ -134,7 +133,6 @@ elaborateRules parentEnable atom =
, ruleActions = atomActions atom
, rulePeriod = atomPeriod atom
, rulePhase = atomPhase atom
- , mathH = any isMathHCall (map (flip getUE st) (allUEs r))
}
assert :: (Name, Hash) -> UeState Rule
assert (name, ue) = do
@@ -168,8 +166,8 @@ elaborateRules parentEnable atom =
enableAssign :: (MUV, Hash) -> UeState (MUV, Hash)
enableAssign (uv, ue) = do
e <- enable
- st <- S.get
h <- maybeUpdate (MUVRef uv)
+ st <- S.get
let (h',st') = newUE (umux (recoverUE st e)
(recoverUE st ue)
(recoverUE st h))
@@ -180,7 +178,7 @@ elaborateRules parentEnable atom =
reIdRules :: Int -> [Rule] -> [Rule]
reIdRules _ [] = []
reIdRules i (a:b) = case a of
- Rule _ _ _ _ _ _ _ _ -> a { ruleId = i } : reIdRules (i + 1) b
+ Rule _ _ _ _ _ _ _ -> a { ruleId = i } : reIdRules (i + 1) b
_ -> a : reIdRules i b
buildAtom :: UeMap -> Global -> Name -> Atom a -> IO (a, AtomSt)
@@ -253,19 +251,19 @@ elaborate st name atom = do
name atom
let (h,st1) = newUE (ubool True) st0
(getRules,st2) = S.runState (elaborateRules h atomDB) st1
- rules = reIdRules 0 getRules
+ rules = reIdRules 0 (reverse getRules)
coverageNames = [ name | Cover name _ _ <- rules ]
assertionNames = [ name | Assert name _ _ <- rules ]
probeNames = [ (n, typeOf a st2) | (n, a) <- gProbes g ]
- if (null rules)
+ if (null rules)
then do
putStrLn "ERROR: Design contains no rules. Nothing to do."
return Nothing
else do
mapM_ (checkEnable st) rules
ok <- mapM checkAssignConflicts rules
return (if and ok
- then Just (st2
+ then Just ( st2
, (trimState $ StateHierarchy name
$ gState g, rules, assertionNames
, coverageNames, probeNames))
@@ -290,7 +288,7 @@ checkEnable st rule
-- | 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 "
@@ -408,7 +406,7 @@ ruleGraph name rules uvs = do
allUVs :: UeMap -> [Rule] -> Hash -> [MUV]
allUVs st rules ue = fixedpoint next $ nearestUVs ue st
where
- assigns = concat [ ruleAssigns r | r@(Rule _ _ _ _ _ _ _ _) <- rules ]
+ assigns = concat [ ruleAssigns r | r@(Rule _ _ _ _ _ _ _) <- rules ]
previousUVs :: MUV -> [MUV]
previousUVs uv = concat [ nearestUVs ue st | (uv', ue) <- assigns, uv == uv' ]
next :: [MUV] -> [MUV]
@@ -426,7 +424,7 @@ allUEs rule = ruleEnable rule : ues
index (MUVArray _ ue) = [ue]
index _ = []
ues = case rule of
- Rule _ _ _ _ _ _ _ _ ->
+ Rule _ _ _ _ _ _ _ ->
concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ]
++ concat (snd (unzip (ruleActions rule)))
Assert _ _ a -> [a]
@@ -5,17 +5,19 @@ module Language.Atom.Scheduling
, 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' ]
+ rules = [ r | r@(Rule _ _ _ _ _ _ _) <- rules' ]
-- Algorithm for assigning rules to phases for a given period
-- (assuming they aren't given an exact phase):
@@ -42,7 +44,7 @@ schedule rules' = concatMap spread periods
-- 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 @@ schedule rules' = concatMap spread periods
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 @@ reportUsage i node@(Usage name n subs) = printf " %6i %6i %s\n" (totalCompl
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]
View
@@ -142,7 +142,7 @@ type UeState a = State UeMap a
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."
+ 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
@@ -155,8 +155,7 @@ emptyMap = (0, M.empty)
-- | Create the sharing map.
share :: UE -> UeState Hash
-share e =
- case e of
+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))
View
@@ -36,7 +36,8 @@ library
base >= 4.0 && < 5,
mtl >= 1.1.0.1 && < 1.2,
process >= 1.0.1.1 && < 1.2,
- syb >= 0.1.0.0
+ syb >= 0.1.0.0,
+ containers >= 0.4
exposed-modules:
Language.Atom
@@ -50,6 +51,7 @@ library
Language.Atom.Language
Language.Atom.Scheduling
Language.Atom.Unit
+ Language.Atom.UeMap
extensions: GADTs, DeriveDataTypeable

0 comments on commit 764794d

Please sign in to comment.