diff --git a/Language/Atom/Analysis.hs b/Language/Atom/Analysis.hs index 4201dcd..06b6810 100644 --- a/Language/Atom/Analysis.hs +++ b/Language/Atom/Analysis.hs @@ -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 diff --git a/Language/Atom/Code.hs b/Language/Atom/Code.hs index e83eb0e..d0b7679 100644 --- a/Language/Atom/Code.hs +++ b/Language/Atom/Code.hs @@ -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] @@ -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" @@ -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' ] @@ -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 @@ -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" @@ -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 @@ -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 @@ -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 -> @@ -423,7 +423,7 @@ 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 @@ -431,22 +431,22 @@ codeRule mp config rule@(Rule _ _ _ _ _ _ _) = ++ " }\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 _ _ _ = "" @@ -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 @@ -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) @@ -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, " */"] diff --git a/Language/Atom/Common.hs b/Language/Atom/Common.hs index d6a35b9..8927c00 100644 --- a/Language/Atom/Common.hs +++ b/Language/Atom/Common.hs @@ -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 () @@ -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) @@ -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 @@ -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. @@ -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 {- diff --git a/Language/Atom/Compile.hs b/Language/Atom/Compile.hs index 5759367..1d05c62 100644 --- a/Language/Atom/Compile.hs +++ b/Language/Atom/Compile.hs @@ -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 diff --git a/Language/Atom/Elaboration.hs b/Language/Atom/Elaboration.hs index 624d9e3..298d350 100644 --- a/Language/Atom/Elaboration.hs +++ b/Language/Atom/Elaboration.hs @@ -136,20 +136,20 @@ elaborateRules parentEnable atom = , rulePhase = atomPhase atom } assert :: (Name, Hash) -> UeState Rule - assert (name, ue) = do + assert (name, u) = do h <- enable return $ Assert { ruleName = name , ruleEnable = h - , ruleAssert = ue + , ruleAssert = u } cover :: (Name, Hash) -> UeState Rule - cover (name, ue) = do + cover (name, u) = do h <- enable return $ Cover { ruleName = name , ruleEnable = h - , ruleCover = ue + , ruleCover = u } rules :: UeState [Rule] rules = do @@ -165,16 +165,16 @@ elaborateRules parentEnable atom = ) [] (atomSubs atom) return $ asserts ++ covers ++ concat rules' enableAssign :: (MUV, Hash) -> UeState (MUV, Hash) - enableAssign (uv, ue) = do + enableAssign (uv', ue') = do e <- enable - h <- maybeUpdate (MUVRef uv) + h <- maybeUpdate (MUVRef uv') st <- S.get let (h',st') = newUE (umux (recoverUE st e) - (recoverUE st ue) + (recoverUE st ue') (recoverUE st h)) st S.put st' - return (uv, h') + return (uv', h') reIdRules :: Int -> [Rule] -> [Rule] reIdRules _ [] = [] @@ -211,9 +211,9 @@ instance Monad Atom where (Atom f1) >>= f2 = Atom f3 where f3 s = do - (a, s) <- f1 s + (a, s') <- f1 s let Atom f4 = f2 a - f4 s + f4 s' instance MonadIO Atom where liftIO io = Atom f @@ -253,8 +253,8 @@ elaborate st name atom = do 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 ] + coverageNames = [ name' | Cover name' _ _ <- rules ] + assertionNames = [ name' | Assert name' _ _ <- rules ] probeNames = [ (n, typeOf a st2) | (n, a) <- gProbes g ] if (null rules) then do @@ -274,7 +274,7 @@ trimState :: StateHierarchy -> StateHierarchy trimState a = case a of StateHierarchy name items -> StateHierarchy name $ filter f $ map trimState items - a -> a + a' -> a' where f (StateHierarchy _ []) = False f _ = True @@ -330,13 +330,13 @@ data UVLocality = Array UA UE | External String Type deriving (Show, Eq, Ord) -- | Generic local variable declaration. var :: Expr a => Name -> a -> Atom (V a) -var name init = do +var name init' = do name' <- addName name (st, (g, atom)) <- get - let uv = UV (gVarId g) name' c - c = constant init + let uv' = UV (gVarId g) name' c + c = constant init' put (st, (g { gVarId = gVarId g + 1, gState = gState g ++ [StateVariable name c] }, atom)) - return $ V uv + return $ V uv' -- | Generic external variable declaration. var' :: Name -> Type -> V a @@ -345,11 +345,11 @@ 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 +array name init' = do name' <- addName name (st, (g, atom)) <- get let ua = UA (gArrayId g) name' c - c = map constant init + c = map constant init' put (st, (g { gArrayId = gArrayId g + 1, gState = gState g ++ [StateArray name c] }, atom)) return $ A ua @@ -405,11 +405,11 @@ ruleGraph name rules uvs = do -- | All the variables that directly and indirectly control the value of an expression. allUVs :: UeMap -> [Rule] -> Hash -> [MUV] -allUVs st rules ue = fixedpoint next $ nearestUVs ue st +allUVs st rules ue' = fixedpoint next $ nearestUVs ue' st where assigns = concat [ ruleAssigns r | r@(Rule _ _ _ _ _ _ _) <- rules ] previousUVs :: MUV -> [MUV] - previousUVs uv = concat [ nearestUVs ue st | (uv', ue) <- assigns, uv == uv' ] + previousUVs u = concat [ nearestUVs ue_ st | (uv', ue_) <- assigns, u == uv' ] next :: [MUV] -> [MUV] next uvs = sort $ nub $ uvs ++ concatMap previousUVs uvs @@ -422,11 +422,11 @@ allUEs :: Rule -> [Hash] allUEs rule = ruleEnable rule : ues where index :: MUV -> [Hash] - index (MUVArray _ ue) = [ue] + index (MUVArray _ ue') = [ue'] index _ = [] ues = case rule of Rule _ _ _ _ _ _ _ -> - concat [ ue : index uv | (uv, ue) <- ruleAssigns rule ] + concat [ ue' : index uv' | (uv', ue') <- ruleAssigns rule ] ++ concat (snd (unzip (ruleActions rule))) Assert _ _ a -> [a] Cover _ _ a -> [a] diff --git a/Language/Atom/Expressions.hs b/Language/Atom/Expressions.hs index 83629e7..3164f7e 100644 --- a/Language/Atom/Expressions.hs +++ b/Language/Atom/Expressions.hs @@ -132,7 +132,7 @@ data Const deriving (Eq, Ord, Data, Typeable) instance Show Const where - show c = case c of + show c' = case c' of CBool True -> "1" CBool False -> "0" CInt8 c -> show c @@ -327,16 +327,16 @@ instance TypeOf Const where CDouble _ -> Double instance TypeOf UV where - typeOf a = case a of + 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 + typeOf (V uv') = typeOf uv' instance TypeOf UA where - typeOf a = case a of + typeOf a' = case a' of UA _ _ c -> typeOf $ head c UAExtern _ t -> t @@ -344,7 +344,7 @@ instance TypeOf (A a) where typeOf (A ua) = typeOf ua instance TypeOf UE where - typeOf t = case t of + typeOf t' = case t' of UVRef uvar -> typeOf uvar UCast t _ -> t UConst c -> typeOf c @@ -577,11 +577,11 @@ instance (Expr a, OrdE a, EqE a, IntegralE a, Bits a) => Bits (E a) where a .|. b = BWOr a b xor = BWXor - shiftL a b = error "shiftL undefined, for left-shifting use .<<." - shiftR a b = error "shiftR undefined, for right-shifting use .>>." + shiftL _ _ = error "shiftL undefined, for left-shifting use .<<." + shiftR _ _ = error "shiftR undefined, for right-shifting use .>>." - rotateL a n = error "rotateL undefined, for left-rotation use rol" - rotateR a n = error "rotateR undefined, for right-rotation use ror" + rotateL _ _ = error "rotateL undefined, for left-rotation use rol" + rotateR _ _ = error "rotateR undefined, for right-rotation use ror" bitSize = width isSigned = signed @@ -596,10 +596,12 @@ a .<<. n = BWShiftL a n a .>>. n = BWShiftR a n -- | Bitwise left-rotation. +rol :: (IntegralE a, IntegralE n, Bits a) => E a -> E n -> E a rol (Const a) (Const n) = Const $ rotateL a $ fromIntegral n rol a n = a .<<. n .|. a .>>. ( ( Const . fromIntegral . width ) a - n ) -- | Bitwise right-rotation. +ror :: (IntegralE a, IntegralE n, Bits a) => E a -> E n -> E a ror (Const a) (Const n) = Const $ rotateR a $ fromIntegral n ror a n = a .>>. n .|. a .<<. ( ( Const . fromIntegral . width ) a - n ) @@ -685,10 +687,10 @@ 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 +limit a b i = max_ min' $ min_ max' i where - min = min_ a b - max = max_ a b + 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 diff --git a/Language/Atom/Language.hs b/Language/Atom/Language.hs index 266c015..7794c79 100644 --- a/Language/Atom/Language.hs +++ b/Language/Atom/Language.hs @@ -94,12 +94,12 @@ atom name design = do -- > 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 +period n atom' = do (st, (g, a)) <- get put (st, (g { gPeriod = n }, a)) - r <- atom - (st', (g', a)) <- get - put (st', (g' { gPeriod = gPeriod g }, a)) + r <- atom' + (st', (g', a')) <- get + put (st', (g' { gPeriod = gPeriod g }, a')) return r -- | Returns the execution period of the current scope. @@ -110,15 +110,15 @@ getPeriod = do 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 +phase' phType n atom' = do (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 (st, (g { gPhase = phType n }, a)) - r <- atom - (st', (g', a)) <- get - put (st', (g' { gPhase = gPhase g }, a)) + r <- atom' + (st', (g', a')) <- get + put (st', (g' { gPhase = gPhase g }, a')) return r -- XXX -- else do put (g { gPhase = n }, a) @@ -149,8 +149,8 @@ getPhase = do -- | Returns the current atom hierarchical path. path :: Atom String path = do - (_, (_, atom)) <- get - return $ atomName atom + (_, (_, atom')) <- get + return $ atomName atom' -- | Local boolean variable declaration. bool :: Name -> Bool -> Atom (V Bool) @@ -244,7 +244,7 @@ double' name = var' name Double action :: ([String] -> String) -> [UE] -> Atom () action f ues = do (st, (g, a)) <- get - let (st', hashes) = foldl' (\(accSt,hs) ue -> let (h,accSt') = newUE ue accSt in + 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)] })) @@ -256,11 +256,11 @@ call n = action (\ _ -> n ++ "()") [] -- | Declares a probe. probe :: Expr a => Name -> E a -> Atom () probe name a = do - (st, (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 (st', (g { gProbes = (name, h) : 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)] @@ -283,10 +283,10 @@ class Expr a => Assign a where -- | Assign an 'E' to a 'V'. (<==) :: V a -> E a -> Atom () v <== e = do - (st, (g, atom)) <- get + (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 })) + put (st1, (g, atom' { atomAssigns = (muv, h) : atomAssigns atom' })) instance Assign Bool instance Assign Int8 @@ -305,10 +305,10 @@ instance Assign Double -- are allowed to execute. cond :: E Bool -> Atom () cond c = do - (st, (g, atom)) <- get - let ae = recoverUE st (atomEnable atom) + (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})) + put (st', (g, atom' { atomEnable = h})) -- | Reference to the 64-bit free running clock. clock :: E Word64 @@ -327,11 +327,11 @@ nextCoverage = do -- names should be globally unique. assert :: Name -> E Bool -> Atom () assert name check = do - (st, (g, atom)) <- get - let names = fst $ unzip $ atomAsserts atom + (st, (g, atom')) <- get + let names = fst $ unzip $ atomAsserts atom' when (elem name names) (liftIO $ putStrLn $ "WARNING: Assertion name already used: " ++ name) let (chk,st') = newUE (ue check) st - put (st', (g, atom { atomAsserts = (name, chk) : atomAsserts atom })) + 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 () @@ -344,9 +344,9 @@ assertImply name a b = do -- Coverage names should be globally unique. cover :: Name -> E Bool -> Atom () cover name check = do - (st, (g, atom)) <- get - let names = fst $ unzip $ atomCovers atom + (st, (g, atom')) <- get + let names = fst $ unzip $ atomCovers atom' when (elem name names) (liftIO $ putStrLn $ "WARNING: Coverage name already used: " ++ name) let (chk,st') = newUE (ue check) st - put (st', (g, atom { atomCovers = (name, chk) : atomCovers atom })) + put (st', (g, atom' { atomCovers = (name, chk) : atomCovers atom' })) diff --git a/Language/Atom/Scheduling.hs b/Language/Atom/Scheduling.hs index 4325fcc..c0df137 100644 --- a/Language/Atom/Scheduling.hs +++ b/Language/Atom/Scheduling.hs @@ -45,13 +45,13 @@ schedule rules' mp = (mp, concatMap spread periods) -- scheduled phase is the minimum of all schedules satisfying (A) and (B). spread :: (Int, [Rule]) -> [(Int, Int, [Rule])] - spread (period, rules) = + spread (period, rules_) = placeRules (placeExactRules (replicate period []) exactRules) orderedByPhase where (minRules,exactRules) = partition (\r -> case rulePhase r of MinPhase _ -> True - ExactPhase _ -> False) rules + ExactPhase _ -> False) rules_ placeExactRules :: [[Rule]] -> [Rule] -> [[Rule]] placeExactRules ls [] = ls placeExactRules ls (r:rst) = placeExactRules (insertAt (getPh r) r ls) @@ -75,8 +75,8 @@ schedule rules' mp = (mp, concatMap spread periods) lub r ls = let minI = getPh 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) + lub' i ls_ | (head ls_) == minimum ls_ = i + | otherwise = lub' (i+1) (tail ls_) in lub' minI (drop minI $ map length ls) -- Cons rule r onto the list at index i in ls. @@ -91,11 +91,11 @@ schedule rules' mp = (mp, concatMap spread periods) | otherwise = (a, bs) : grow rest (a', b) reportSchedule :: Schedule -> String -reportSchedule (mp, schedule) = concat +reportSchedule (mp, schedule_) = concat [ "Rule Scheduling Report\n\n" , "Period Phase Exprs Rule\n" , "------ ----- ----- ----\n" - , concatMap (reportPeriod mp) schedule + , concatMap (reportPeriod mp) schedule_ , " -----\n" , printf " %5i\n" $ sum $ map (ruleComplexity mp) rules , "\n" @@ -106,7 +106,7 @@ reportSchedule (mp, schedule) = concat , "\n" ] where - rules = concat $ [ r | (_, _, r) <- schedule ] + rules = concat $ [ r | (_, _, r) <- schedule_ ] reportPeriod :: UeMap -> (Int, Int, [Rule]) -> String diff --git a/Language/Atom/UeMap.hs b/Language/Atom/UeMap.hs index 25af769..2d038e7 100644 --- a/Language/Atom/UeMap.hs +++ b/Language/Atom/UeMap.hs @@ -12,7 +12,6 @@ module Language.Atom.UeMap , getUE , newUE , newUV --- , share , maybeUpdate , ueUpstream , nearestUVs @@ -21,7 +20,6 @@ module Language.Atom.UeMap ) where import Control.Monad.State.Strict ---import qualified Data.IntMap as M import qualified Data.Bimap as M import Data.List (nub) @@ -39,12 +37,12 @@ data MUV -- | 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') +newUV u mp = + case u 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 @@ -152,7 +150,7 @@ getUE h (_,mp) = -- | 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 +newUE ue_ mp = runState (share ue_) mp emptyMap :: UeMap emptyMap = (0, M.empty) @@ -349,9 +347,9 @@ 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 + (MUVRef u@(MUVArray _ h')) -> [u] ++ f h' + (MUVRef u) -> [u] + _ -> concatMap f $ ueUpstream hash mp -- | All array indexing subexpressions. arrayIndices :: Hash -> UeMap -> [(UA, Hash)] diff --git a/Language/Atom/Unit.hs b/Language/Atom/Unit.hs index 9061f22..ec5257f 100644 --- a/Language/Atom/Unit.hs +++ b/Language/Atom/Unit.hs @@ -17,7 +17,7 @@ import Data.Bits import Data.Int import Data.List import Data.Word -import Language.Atom.Code +import Language.Atom.Code hiding (err) import Language.Atom.Compile import Language.Atom.Language import System.Exit @@ -25,6 +25,7 @@ import System.IO import System.Process import Text.Printf +import Prelude hiding (id) -- | Data constructor:Test data Test = Test @@ -80,16 +81,16 @@ runTests seed tests = do when (not $ null unHitCoverage) $ exitWith $ ExitFailure 1 reportResult :: Int -> (Name, Bool, Int, a, b) -> IO () -reportResult m (name, pass, cycles, _, _) = +reportResult m (name', pass, cycles', _, _) = printf "%s: %s cycles = %7i %s\n" (if pass then "pass" else "FAIL") - (printf ("%-" ++ show m ++ "s") name :: String) - cycles - (if pass then "" else " (see " ++ name ++ ".log)") + (printf ("%-" ++ show m ++ "s") name' :: String) + cycles' + (if pass then "" else " (see " ++ name' ++ ".log)") runTest :: Int -> IO Test -> IO (Name, Bool, Int, [Name], [Name]) -runTest seed test = do - test <- test +runTest seed test' = do + test <- test' putStrLn $ "running test " ++ name test ++ " ..." hFlush stdout (_, _, _, coverageNames, _) <- compile "atom_unit_test" defaults { cStateName = name test, cCode = prePostCode test, cRuleCoverage = False } $ testbench test @@ -100,10 +101,10 @@ runTest seed test = do writeFile file $ out ++ err return (name test, False, 0, coverageNames, []) ExitSuccess -> do - log <- readProcess "./atom_unit_test" [] "" - let pass = not $ elem "FAILURE:" $ words log - covered = [ words line !! 1 | line <- lines log, isPrefixOf "covered:" line ] - writeFile file $ out ++ err ++ log + log_ <- readProcess "./atom_unit_test" [] "" + let pass = not $ elem "FAILURE:" $ words log_ + covered = [ words line !! 1 | line <- lines log_, isPrefixOf "covered:" line ] + writeFile file $ out ++ err ++ log_ hFlush stdout return (name test, pass, cycles test, coverageNames, covered) where @@ -115,13 +116,13 @@ runTest seed test = do , "void assert (int id, unsigned char check, unsigned long long clock) {" , " static unsigned char failed[" ++ show (length assertionNames) ++ "] = {" ++ intercalate "," (replicate (length assertionNames) "0") ++ "};" , " if (! check) {" - , " " ++ intercalate "\n else " [ "if (id == " ++ show id ++ ") { if (! failed[id]) { printf(\"ASSERTION FAILURE: " ++ name ++ " at time %lli\\n\", clock); failed[id] = 1; } }" | (name, id) <- zip assertionNames [0..] ] + , " " ++ intercalate "\n else " [ "if (id == " ++ show id ++ ") { if (! failed[id]) { printf(\"ASSERTION FAILURE: " ++ name' ++ " at time %lli\\n\", clock); failed[id] = 1; } }" | (name', id) <- zip assertionNames [0::Int ..] ] , " }" , "}" , "void cover (int id, unsigned char check, unsigned long long clock) {" , " static unsigned char covered[" ++ show (length coverageNames) ++ "] = {" ++ intercalate "," (replicate (length coverageNames) "0") ++ "};" , " if (check) {" - , " " ++ intercalate "\n else " [ "if (id == " ++ show id ++ ") { if (! covered[id]) { printf(\"covered: " ++ name ++ " at time %lli\\n\", clock); covered[id] = 1; } }" | (name, id) <- zip coverageNames [0..] ] + , " " ++ intercalate "\n else " [ "if (id == " ++ show id ++ ") { if (! covered[id]) { printf(\"covered: " ++ name' ++ " at time %lli\\n\", clock); covered[id] = 1; } }" | (name', id) <- zip coverageNames [0::Int ..] ] , " }" , "}" ] ++ declCode test @@ -149,11 +150,13 @@ printStrLn s = action (\ _ -> "printf(\"" ++ s ++ "\\n\")") [] -- | Print integral values. printIntegralE :: IntegralE a => String -> E a -> Atom () -printIntegralE name value = action (\ [v] -> "printf(\"" ++ name ++ ": %i\\n\", " ++ v ++ ")") [ue value] +printIntegralE name' value' = + action (\ v' -> "printf(\"" ++ name' ++ ": %i\\n\", " ++ head v' ++ ")") [ue value'] -- | Print floating point values. printFloatingE :: FloatingE a => String -> E a -> Atom () -printFloatingE name value = action (\ [v] -> "printf(\"" ++ name ++ ": %f\\n\", " ++ v ++ ")") [ue value] +printFloatingE name' value' = + action (\ v' -> "printf(\"" ++ name' ++ ": %f\\n\", " ++ head v' ++ ")") [ue value'] class Expr a => Random a where random :: E a diff --git a/atom.cabal b/atom.cabal index 11b498b..1db20f2 100644 --- a/atom.cabal +++ b/atom.cabal @@ -1,5 +1,5 @@ name: atom -version: 1.0.9 +version: 1.0.10 category: Language, Embedded