diff --git a/Language/Atom/Elaboration.hs b/Language/Atom/Elaboration.hs --- a/Language/Atom/Elaboration.hs +++ b/Language/Atom/Elaboration.hs @@ -10,6 +10,7 @@ -- * Type Aliases and Utilities , UID , Name + , Phase (..) , Path , elaborate , var @@ -36,6 +37,9 @@ -- | A hierarchical name. type Path = [Name] +-- | A phase is either the minimum phase or the exact phase. +data Phase = MinPhase Int | ExactPhase Int + data Global = Global { gRuleId :: Int , gVarId :: Int @@ -43,7 +47,7 @@ , gState :: [StateHierarchy] , gProbes :: [(String, UE)] , gPeriod :: Int - , gPhase :: Int + , gPhase :: Phase } data AtomDB = AtomDB @@ -53,7 +57,7 @@ , atomEnable :: UE -- Enabling condition. , atomSubs :: [AtomDB] -- Sub atoms. , atomPeriod :: Int - , atomPhase :: Int + , atomPhase :: Phase , atomAssigns :: [(UV, UE)] , atomActions :: [([String] -> String, [UE])] , atomAsserts :: [(Name, UE)] @@ -68,7 +72,7 @@ , ruleAssigns :: [(UV, UE)] , ruleActions :: [([String] -> String, [UE])] , rulePeriod :: Int - , rulePhase :: Int + , rulePhase :: Phase } | Assert { ruleName :: Name @@ -171,7 +175,7 @@ -- | 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 = 0 } name atom + (_, (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 coverageNames = [ name | Cover name _ _ <- rules ] assertionNames = [ name | Assert name _ _ <- rules ] diff --git a/Language/Atom/Language.hs b/Language/Atom/Language.hs --- a/Language/Atom/Language.hs +++ b/Language/Atom/Language.hs @@ -9,6 +9,7 @@ , period , getPeriod , phase + , exactPhase , getPhase -- * Action Directives , cond @@ -104,25 +105,43 @@ (g, _) <- get return $ gPeriod g --- | Defines the earliest phase within the period at which the rule should --- execute. The 'phase' must be at least zero and less than the current 'period'. -phase :: Int -> Atom a -> Atom a -phase n _ | n < 0 = error "ERROR: phase must be at least 0." -phase n atom = 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 (g, a) <- get if (n >= gPeriod g) - then error "ERROR: phase must be less than the current phase." - else do put (g { gPhase = n }, a) + then error $ "ERROR: phase " ++ show n ++ " must be less than the current period " + ++ show (gPeriod g) ++ "." + else do put (g { gPhase = phType n }, a) r <- atom (g', a) <- get put (g' { gPhase = gPhase g }, a) return r + -- XXX + -- else do put (g { gPhase = n }, a) + -- r <- atom + -- (g', a) <- get + -- put (g' { gPhase = gPhase g }, a) + -- return r +-- | Defines the earliest phase within the period at which the rule should +-- execute; the scheduler attempt to find an optimal phase from 0 <= @n@ < +-- period (thus, the 'phase' must be at least zero and less than the current +-- 'period'.). +phase :: Int -> Atom a -> Atom a +phase n a = phase' MinPhase n a + +-- | Ensures an atom is scheduled only at phase @n@. +exactPhase :: Int -> Atom a -> Atom a +exactPhase n a = phase' ExactPhase n a + -- | Returns the phase of the current scope. getPhase :: Atom Int getPhase = do (g, _) <- get - return $ gPhase g + return $ case gPhase g of + MinPhase ph -> ph + ExactPhase ph -> ph -- | Returns the current atom hierarchical path. path :: Atom String diff --git a/Language/Atom/Scheduling.hs b/Language/Atom/Scheduling.hs --- a/Language/Atom/Scheduling.hs +++ b/Language/Atom/Scheduling.hs @@ -17,7 +17,8 @@ where rules = [ r | r@(Rule _ _ _ _ _ _ _) <- rules' ] - -- Algorithm for assigning rules to phases for a given period: + -- Algorithm for assigning rules to phases for a given period + -- (assuming they aren't given an exact phase): -- 1. List the rules by their offsets, highest first. @@ -43,26 +44,40 @@ spread :: (Int, [Rule]) -> Schedule spread (period, rules) = - placeRules (replicate period []) orderedByPhase - + placeRules (placeExactRules (replicate period []) exactRules) + orderedByPhase where + (minRules,exactRules) = partition (\r -> case rulePhase r of + MinPhase _ -> True + ExactPhase _ -> False) rules + placeExactRules :: [[Rule]] -> [Rule] -> [[Rule]] + placeExactRules ls [] = ls + placeExactRules ls (r:rst) = placeExactRules (insertAt (getPh r) r ls) + rst + orderedByPhase :: [Rule] - orderedByPhase = - sortBy (\r0 r1 -> compare (rulePhase r1) (rulePhase r0)) rules + orderedByPhase = sortBy (\r0 r1 -> compare (getPh r1) (getPh r0)) minRules + getPh r = case rulePhase r of + MinPhase i -> i + ExactPhase i -> i + -- Initially, ls contains all the exactPhase rules. We put rules in those + -- lists according to the algorithm, and then filter out the phase-lists + -- with no rules. placeRules :: [[Rule]] -> [Rule] -> [(Int, Int, [Rule])] - placeRules ls [] = - filter (\(_,_,rls) -> not (null rls)) $ zip3 (repeat period) [0..(period-1)] ls + placeRules ls [] = filter (\(_,_,rls) -> not (null rls)) + (zip3 (repeat period) [0..(period-1)] ls) placeRules ls (r:rst) = placeRules (insertAt (lub r ls) r ls) rst lub :: Rule -> [[Rule]] -> Int - lub r ls = let minI = rulePhase r + 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) in lub' minI (drop minI $ map length ls) + -- Cons rule r onto the list at index i in ls. insertAt :: Int -> Rule -> [[Rule]] -> [[Rule]] insertAt i r ls = (take i ls) ++ ((r:(ls !! i)):(drop (i+1) ls)) diff --git a/RELEASE-NOTES b/RELEASE-NOTES --- a/RELEASE-NOTES +++ b/RELEASE-NOTES @@ -1,3 +1,7 @@ +atom 1.0.4 05/23/2010 + +- Added 'exactPhase'. (Lee Pike) + atom 1.0.3 04/19/2010 - Reduced line length in C code generation. diff --git a/atom.cabal b/atom.cabal --- a/atom.cabal +++ b/atom.cabal @@ -1,5 +1,5 @@ name: atom -version: 1.0.3 +version: 1.0.4 category: Language