Skip to content

Commit

Permalink
Removed build warnings.
Browse files Browse the repository at this point in the history
  • Loading branch information
Lee Pike committed Nov 11, 2011
1 parent 1b3a0d9 commit 76882c8
Show file tree
Hide file tree
Showing 11 changed files with 166 additions and 163 deletions.
6 changes: 3 additions & 3 deletions Language/Atom/Analysis.hs
View file
Expand Up @@ -13,9 +13,9 @@ topo mp ues = reverse ues'
start = 0
(_, ues') = foldl collect (start, []) ues
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 mp
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 mp

e :: Int -> String
e i = "__" ++ show i
Expand Down
80 changes: 40 additions & 40 deletions Language/Atom/Code.hs
View file
Expand Up @@ -123,18 +123,18 @@ cType t = case t of
Double -> "double"

codeUE :: UeMap -> Config -> [(Hash, String)] -> String -> (Hash, String) -> String
codeUE mp config ues d (ue, n) =
d ++ cType (typeOf ue mp) ++ " " ++ n ++ " = " ++ basic ++ ";\n"
codeUE mp config ues d (ue', n) =
d ++ cType (typeOf ue' mp) ++ " " ++ n ++ " = " ++ basic ++ ";\n"
where
operands = map (fromJust . flip lookup ues) $ ueUpstream ue mp
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]
basic = concat $ case getUE ue' mp of
MUVRef (MUV _ k _) -> [cStateName config, ".", k]
MUVRef (MUVArray (UA _ k _) _) -> [cStateName config, ".", k, "[", a, "]"]
MUVRef (MUVArray (UAExtern k _) _) -> [k, "[", a, "]"]
MUVRef (MUVExtern k _) -> [k]
MUCast _ _ -> ["(", cType (typeOf ue' mp), ") ", a]
MUConst c_ -> [showConst c_]
MUAdd _ _ -> [a, " + ", b]
MUSub _ _ -> [a, " - ", b]
MUMul _ _ -> [a, " * ", b]
Expand Down Expand Up @@ -176,7 +176,7 @@ codeUE mp config ues d (ue, n) =
a = head operands
b = operands !! 1
c = operands !! 2
f = case ( typeOf ue mp) of
f = case ( typeOf ue' mp) of
Float -> "f"
Double -> ""
_ -> error "unhandled float type"
Expand All @@ -192,7 +192,7 @@ type RuleCoverage = [(Name, Int, Int)]

writeC :: Name -> Config -> StateHierarchy -> [Rule] -> Schedule -> [Name]
-> [Name] -> [(Name, Type)] -> IO RuleCoverage
writeC name config state rules (mp, 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' ]
Expand Down Expand Up @@ -234,7 +234,7 @@ writeC name config state rules (mp, schedule) assertionNames coverageNames probe
, postCode
]

codePeriodPhases = concatMap (codePeriodPhase config) schedule
codePeriodPhases = concatMap (codePeriodPhase config) schedule'

swOrHwClock =
case hardwareClock config of
Expand Down Expand Up @@ -324,8 +324,8 @@ writeC name config state rules (mp, schedule) assertionNames coverageNames probe
Word32 -> toInteger (maxBound :: Word32)
Word64 -> toInteger (maxBound :: Word64)
_ -> clkTypeErr
declareConst varName c = globalType ++ " const " ++ varName
++ " = " ++ showConst (constType c) ++ ";"
declareConst varName c' = globalType ++ " const " ++ varName
++ " = " ++ showConst (constType c') ++ ";"
setTime = currentTime ++ " = " ++ clockName clkData ++ "();"
maxConst = "__max"
phaseConst = "__phase_len"
Expand All @@ -351,11 +351,11 @@ writeC name config state rules (mp, schedule) assertionNames coverageNames probe
Nothing -> ""
Just errF -> errF ++ " ();"
constType :: Integer -> Const
constType c = case clockType clkData of
Word8 -> CWord8 (fromInteger c :: Word8)
Word16 -> CWord16 (fromInteger c :: Word16)
Word32 -> CWord32 (fromInteger c :: Word32)
Word64 -> CWord64 (fromInteger c :: Word64)
constType c' = case clockType clkData of
Word8 -> CWord8 (fromInteger c' :: Word8)
Word16 -> CWord16 (fromInteger c' :: Word16)
Word32 -> CWord32 (fromInteger c' :: Word32)
Word64 -> CWord64 (fromInteger c' :: Word64)
_ -> clkTypeErr

h = unlines
Expand Down Expand Up @@ -385,7 +385,7 @@ writeC name config state rules (mp, schedule) assertionNames coverageNames probe
funcName = if null (cFuncName config) then name else cFuncName config

rules' :: [Rule]
rules' = concat [ r | (_, _, r) <- schedule ]
rules' = concat [ r | (_, _, r) <- schedule' ]

covLen = 1 + div (maximum $ map ruleId rules') 32

Expand All @@ -397,9 +397,9 @@ 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 ->
Expand All @@ -423,30 +423,30 @@ codeRule mp config rule@(Rule _ _ _ _ _ _ _) =
"/* " ++ show rule ++ " */\n" ++
"static void __r" ++ show (ruleId rule) ++ "() {\n" ++
concatMap (codeUE mp config ues " ") ues ++
" if (" ++ id (ruleEnable rule) ++ ") {\n" ++
" 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 mp $ allUEs rule
id ue = fromJust $ lookup ue ues
id' ue' = fromJust $ lookup ue' ues

codeAction :: (([String] -> String), [Hash]) -> String
codeAction (f, args) = " " ++ f (map id args) ++ ";\n"
codeAction (f, args) = " " ++ f (map id' args) ++ ";\n"

covWord = show $ div (ruleId rule) 32
covBit = show $ mod (ruleId rule) 32

codeAssign :: (MUV, Hash) -> String
codeAssign (uv, ue) = concat [" ", lh, " = ", id ue, ";\n"]
codeAssign (uv', ue') = concat [" ", lh, " = ", id' ue', ";\n"]
where
lh = case uv of
lh = case uv' of
MUV _ n _ -> concat [cStateName config, ".", n]
MUVArray (UA _ n _) index ->
concat [cStateName config, ".", n, "[", id index, "]"]
MUVArray (UAExtern n _) index -> concat [n, "[", id index, "]"]
concat [cStateName config, ".", n, "[", id' index, "]"]
MUVArray (UAExtern n _) index -> concat [n, "[", id' index, "]"]
MUVExtern n _ -> n

codeRule _ _ _ = ""
Expand All @@ -459,19 +459,19 @@ codeAssertionChecks mp config assertionNames coverageNames rules =
codeIf (cAssert config) $
"static void __assertion_checks() {\n" ++
concatMap (codeUE mp config ues " ") ues ++
concat [ " if (" ++ id enable ++ ") " ++ cAssertName config
++ "(" ++ assertionId name ++ ", " ++ id check ++ ", "
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 ++ ", "
concat [ " if (" ++ id' enable ++ ") " ++ cCoverName config
++ "(" ++ coverageId name ++ ", " ++ id' check ++ ", "
++ globalClk ++ ");\n"
| Cover name enable check <- rules ] ++
"}\n\n"
where
ues = topo mp $ concat [ [a, b] | Assert _ a b <- rules ]
++ concat [ [a, b] | Cover _ a b <- rules ]
id ue = fromJust $ lookup ue ues
id' ue' = fromJust $ lookup ue' ues
assertionId :: Name -> String
assertionId name = show $ fromJust $ elemIndex name assertionNames
coverageId :: Name -> String
Expand All @@ -480,7 +480,7 @@ codeAssertionChecks mp config assertionNames coverageNames rules =
codePeriodPhase :: Config -> (Int, Int, [Rule]) -> String
codePeriodPhase config (period, phase, rules) = unlines
[ printf " {"
, printf " static %s __scheduling_clock = %i;" (cType clockType) phase
, 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)
Expand All @@ -491,8 +491,8 @@ codePeriodPhase config (period, phase, rules) = unlines
, printf " }"
]
where
clockType | period < 2 ^ 8 = Word8
| period < 2 ^ 16 = Word16
| otherwise = Word32
clockType' | period < 2 ^ (8 :: Word8) = Word8
| period < 2 ^ (16 :: Word16) = Word16
| otherwise = Word32
callRule r = concat [" ", codeIf (cAssert config) "__assertion_checks(); ", "__r", show (ruleId r), "(); /* ", show r, " */"]

48 changes: 24 additions & 24 deletions Language/Atom/Common.hs
View file
Expand Up @@ -29,8 +29,8 @@ data Timer = Timer (V Word64)
-- | Creates a new timer.
timer :: Name -> Atom Timer
timer name = do
timer <- word64 name 0
return $ Timer timer
timer' <- word64 name 0
return $ Timer timer'

-- | Starts a Timer. A timer can be restarted at any time.
startTimer :: Timer -> E Word64 -> Atom ()
Expand All @@ -48,9 +48,9 @@ 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)
last' <- bool "last" False
last' <== a
return $ a &&. not_ (value last')

-- | One-shot on a falling transition.
oneShotFall :: E Bool -> Atom (E Bool)
Expand All @@ -59,22 +59,22 @@ 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"
debounce name onTime offTime init' a = atom name $ do
lst <- bool "last" init'
out <- bool "out" init'
timer' <- timer "timer"
atom "on" $ do
cond $ a &&. not_ (value last)
startTimer timer onTime
last <== a
cond $ a &&. not_ (value lst)
startTimer timer' onTime
lst <== a
atom "off" $ do
cond $ not_ a &&. value last
startTimer timer offTime
last <== a
cond $ not_ a &&. value lst
startTimer timer' offTime
lst <== a
atom "set" $ do
cond $ a ==. value last
cond $ timerDone timer
out <== value last
cond $ a ==. value lst
cond $ timerDone timer'
out <== value lst
return $ value out


Expand All @@ -86,10 +86,10 @@ lookupTable table x = mux (x >=. x1) y1 $ foldl f y0 table'
(_, y0) = head table
(x1, y1) = last table
table' = zip (init table) (tail table)
f a ((x0,y0),(x1,y1)) = mux (x >=. x0) interp a
f a ((a0,b0),(a1,b1)) = mux (x >=. a0) interp a
where
slope = (y1 - y0) / (x1 - x0)
interp = (x - x0) * slope + y0
slope = (b1 - b0) / (a1 - a0)
interp = (x - a0) * slope + b0

-- | Linear extrapolation and interpolation on a line with 2 points.
-- The two x points must be different to prevent a divide-by-zero.
Expand All @@ -107,11 +107,11 @@ linear (x1, y1) (x2, y2) a = slope * a + inter
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)
s <== (mux (u >. max') true $ mux (u <. min') false $ value s)
return $ value s
where
min = min_ a b
max = max_ a b
min' = min_ a b
max' = max_ a b

{-
Expand Down
4 changes: 2 additions & 2 deletions Language/Atom/Compile.hs
View file
Expand Up @@ -18,8 +18,8 @@ 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
res <- elaborate emptyMap name atom
compile name config atom' = do
res <- elaborate emptyMap name atom'
case res of
Nothing -> putStrLn "ERROR: Design rule checks failed." >> exitWith (ExitFailure 1)
Just (st,(state, rules, assertionNames, coverageNames, probeNames)) -> do
Expand Down

0 comments on commit 76882c8

Please sign in to comment.