atom 1.0.10 → 1.0.11
raw patch · 11 files changed
+166/−163 lines, 11 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Language.Atom.Expressions: rol :: (Bits a, IntegralE a, IntegralE n) => E a -> E n -> E a
+ Language.Atom.Expressions: rol :: (IntegralE a, IntegralE n, Bits a) => E a -> E n -> E a
- Language.Atom.Expressions: ror :: (Bits a, IntegralE a, IntegralE n) => E a -> E n -> E a
+ Language.Atom.Expressions: ror :: (IntegralE a, IntegralE n, Bits a) => E a -> E n -> E a
- Language.Atom.Language: class Expr a => Assign a
+ Language.Atom.Language: class Expr a => Assign a where v <== e = do { (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'})) }
Files
- Language/Atom/Analysis.hs +3/−3
- Language/Atom/Code.hs +40/−40
- Language/Atom/Common.hs +24/−24
- Language/Atom/Compile.hs +2/−2
- Language/Atom/Elaboration.hs +23/−23
- Language/Atom/Expressions.hs +14/−12
- Language/Atom/Language.hs +24/−24
- Language/Atom/Scheduling.hs +7/−7
- Language/Atom/UeMap.hs +10/−12
- Language/Atom/Unit.hs +18/−15
- atom.cabal +1/−1
Language/Atom/Analysis.hs view
@@ -13,9 +13,9 @@ 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
Language/Atom/Code.hs view
@@ -123,18 +123,18 @@ 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 @@ 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 @@ 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 @@ , postCode ] - codePeriodPhases = concatMap (codePeriodPhase config) schedule+ codePeriodPhases = concatMap (codePeriodPhase config) schedule' swOrHwClock = case hardwareClock config of@@ -324,8 +324,8 @@ 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 @@ 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 @@ 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 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 @@ "/* " ++ 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 @@ ++ " }\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 @@ 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 @@ 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 @@ , 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, " */"]
Language/Atom/Common.hs view
@@ -29,8 +29,8 @@ -- | 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 @@ -- | 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 @@ -- | 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 @@ (_, 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 @@ 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 {-
Language/Atom/Compile.hs view
@@ -18,8 +18,8 @@ -- | 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
Language/Atom/Elaboration.hs view
@@ -136,20 +136,20 @@ , 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 @@ ) [] (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 @@ (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 @@ 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 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 @@ -- | 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 @@ -- | 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 @@ -- | 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 = 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]
Language/Atom/Expressions.hs view
@@ -132,7 +132,7 @@ 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 @@ 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 @@ 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 @@ 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 = 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 @@ -- | 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
Language/Atom/Language.hs view
@@ -94,12 +94,12 @@ -- > 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 @@ 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 @@ -- | 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 @@ 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 @@ -- | 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 @@ -- | 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 @@ -- 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 @@ -- 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 @@ -- 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' }))
Language/Atom/Scheduling.hs view
@@ -45,13 +45,13 @@ -- 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 @@ 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 @@ | 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 @@ , "\n" ] where- rules = concat $ [ r | (_, _, r) <- schedule ]+ rules = concat $ [ r | (_, _, r) <- schedule_ ] reportPeriod :: UeMap -> (Int, Int, [Rule]) -> String
Language/Atom/UeMap.hs view
@@ -12,7 +12,6 @@ , getUE , newUE , newUV--- , share , maybeUpdate , ueUpstream , nearestUVs@@ -21,7 +20,6 @@ ) 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 @@ -- | 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 @@ -- | 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 @@ 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)]
Language/Atom/Unit.hs view
@@ -17,7 +17,7 @@ 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.Process import Text.Printf +import Prelude hiding (id) -- | Data constructor:Test data Test = Test@@ -80,16 +81,16 @@ 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 @@ 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 @@ , "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 @@ -- | 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
atom.cabal view
@@ -1,5 +1,5 @@ name: atom-version: 1.0.10+version: 1.0.11 category: Language, Embedded