From cda40a13d09f9817bcfd152a055f964ccb0ceaf6 Mon Sep 17 00:00:00 2001 From: Zachary Snow Date: Mon, 25 Feb 2019 16:19:55 -0500 Subject: [PATCH] more fleshed out Traverse module --- Convert/CaseKW.hs | 11 ++++---- Convert/Logic.hs | 69 +++++++++++++-------------------------------- Convert/StarPort.hs | 10 +++---- Convert/Traverse.hs | 53 +++++++++++++++++++++++++++++----- 4 files changed, 75 insertions(+), 68 deletions(-) diff --git a/Convert/CaseKW.hs b/Convert/CaseKW.hs index d8bf635..3fb57e3 100644 --- a/Convert/CaseKW.hs +++ b/Convert/CaseKW.hs @@ -6,7 +6,7 @@ - Note that this conversion does not completely replicate the behavior of - `casex` and `casez` in cases where that case expression itself (rather than - just the case item patterns) contains wildcard values. This is apparently - - rarely ever intentially done. + - rarely ever intentionally done. -} module Convert.CaseKW (convert) where @@ -33,16 +33,15 @@ possibilities = ['0', '1'] explodeBy :: [Char] -> String -> [String] explodeBy _ "" = [""] explodeBy wilds (x : xs) = - [(:)] <*> chars <*> prev - where - chars = if elem x wilds then possibilities else [x] - prev = explodeBy wilds xs + (map (:) chars) <*> (explodeBy wilds xs) + where chars = if elem x wilds then possibilities else [x] expandExpr :: [Char] -> Expr -> [Expr] expandExpr wilds (Number s) = map Number $ explodeBy wilds s expandExpr [] other = [other] -- TODO: Hopefully they only give us constant expressions... -expandExpr _ other = error $ "CaseKW conversione encountered case that was not a number, which is dubious..." ++ (show other) +-- TODO: We could be given a constant identifier... +expandExpr _ other = error $ "CaseKW conversion encountered case that was not a number, which is dubious..." ++ (show other) -- Note that we don't have to convert the statements within the cases, as the -- conversion template takes care of that for us. diff --git a/Convert/Logic.hs b/Convert/Logic.hs index 7789c79..43ecbeb 100644 --- a/Convert/Logic.hs +++ b/Convert/Logic.hs @@ -13,65 +13,34 @@ module Convert.Logic (convert) where +import Control.Monad.Writer import qualified Data.Set as Set +import Convert.Traverse import Language.SystemVerilog.AST type RegIdents = Set.Set String convert :: AST -> AST -convert descriptions = map convertDescription descriptions +convert = traverseDescriptions convertDescription convertDescription :: Description -> Description -convertDescription (Module name ports items) = - Module name ports $ map (convertModuleItem idents) items +convertDescription orig = + traverseModuleItems convertModuleItem orig where - idents = Set.unions $ map getRegIdents items -convertDescription other = other + idents = execWriter (collectModuleItemsM regIdents orig) + convertModuleItem :: ModuleItem -> ModuleItem + convertModuleItem (MIDecl (Variable dir (Logic mr) ident a me)) = + MIDecl $ Variable dir (t mr) ident a me + where t = if Set.member ident idents then Reg else Wire + convertModuleItem other = other -getStmtLHSs :: Stmt -> [LHS] -getStmtLHSs (Block _ stmts) = concat $ map getStmtLHSs stmts -getStmtLHSs (Case kw e cases (Just stmt)) = (getStmtLHSs stmt) ++ (getStmtLHSs $ Case kw e cases Nothing) -getStmtLHSs (Case _ _ cases Nothing) = concat $ map getStmtLHSs $ map snd cases -getStmtLHSs (AsgnBlk lhs _) = [lhs] -getStmtLHSs (Asgn lhs _) = [lhs] -getStmtLHSs (For _ _ _ stmt) = getStmtLHSs stmt -getStmtLHSs (If _ s1 s2) = (getStmtLHSs s1) ++ (getStmtLHSs s2) -getStmtLHSs (Timing _ s) = getStmtLHSs s -getStmtLHSs (Null) = [] - -getLHSIdents :: LHS -> [Identifier] -getLHSIdents (LHS vx ) = [vx] -getLHSIdents (LHSBit vx _) = [vx] -getLHSIdents (LHSRange vx _) = [vx] -getLHSIdents (LHSConcat lhss) = concat $ map getLHSIdents lhss - -getRegIdents :: ModuleItem -> RegIdents -getRegIdents (AlwaysC _ stmt) = - Set.fromList idents +regIdents :: ModuleItem -> Writer RegIdents () +regIdents (AlwaysC _ stmt) = collectStmtLHSsM idents stmt where - lhss = getStmtLHSs stmt - idents = concat $ map getLHSIdents lhss -getRegIdents _ = Set.empty - -convertModuleItem :: RegIdents -> ModuleItem -> ModuleItem -convertModuleItem idents (MIDecl (Variable dir (Logic mr) ident a me)) = - MIDecl $ Variable dir (t mr) ident a me - where - t = if Set.member ident idents then Reg else Wire -convertModuleItem idents (Generate items) = Generate $ map (convertGenItem $ convertModuleItem idents) items -convertModuleItem _ other = other - -convertGenItem :: (ModuleItem -> ModuleItem) -> GenItem -> GenItem -convertGenItem f item = convertGenItem' item - where - convertGenItem' :: GenItem -> GenItem - convertGenItem' (GenBlock x items) = GenBlock x $ map convertGenItem' items - convertGenItem' (GenFor a b c d items) = GenFor a b c d $ map convertGenItem' items - convertGenItem' (GenIf e i1 i2) = GenIf e (convertGenItem' i1) (convertGenItem' i2) - convertGenItem' (GenNull) = GenNull - convertGenItem' (GenModuleItem moduleItem) = GenModuleItem $ f moduleItem - convertGenItem' (GenCase e cases def) = GenCase e cases' def' - where - cases' = zip (map fst cases) (map (convertGenItem' . snd) cases) - def' = fmap convertGenItem' def + idents :: LHS -> Writer RegIdents () + idents (LHS vx ) = tell $ Set.singleton vx + idents (LHSBit vx _) = tell $ Set.singleton vx + idents (LHSRange vx _) = tell $ Set.singleton vx + idents (LHSConcat lhss) = mapM idents lhss >>= \_ -> return () +regIdents _ = return () diff --git a/Convert/StarPort.hs b/Convert/StarPort.hs index 8171c8c..403d542 100644 --- a/Convert/StarPort.hs +++ b/Convert/StarPort.hs @@ -6,7 +6,7 @@ module Convert.StarPort (convert) where -import Data.Maybe (mapMaybe) +import Control.Monad.Writer import qualified Data.Map.Strict as Map import Convert.Traverse @@ -16,10 +16,10 @@ convert :: AST -> AST convert descriptions = traverseDescriptions (traverseModuleItems mapInstance) descriptions where - modulePorts = Map.fromList $ mapMaybe getPorts descriptions - getPorts :: Description -> Maybe (Identifier, [Identifier]) - getPorts (Module name ports _) = Just (name, ports) - getPorts _ = Nothing + modulePorts = execWriter $ collectDescriptionsM getPorts descriptions + getPorts :: Description -> Writer (Map.Map Identifier [Identifier]) () + getPorts (Module name ports _) = tell $ Map.singleton name ports + getPorts _ = return () mapInstance :: ModuleItem -> ModuleItem mapInstance (Instance m p x Nothing) = diff --git a/Convert/Traverse.hs b/Convert/Traverse.hs index c2343bc..b83c195 100644 --- a/Convert/Traverse.hs +++ b/Convert/Traverse.hs @@ -8,36 +8,51 @@ module Convert.Traverse ( MapperM , Mapper , unmonad +, collectify , traverseDescriptionsM , traverseDescriptions +, collectDescriptionsM , traverseModuleItemsM , traverseModuleItems +, collectModuleItemsM , traverseStmtsM , traverseStmts +, collectStmtsM +, traverseStmtLHSsM +, traverseStmtLHSs +, collectStmtLHSsM ) where import Control.Monad.State import Language.SystemVerilog.AST -type MapperM s t = t -> (State s) t +type MapperM m t = t -> m t type Mapper t = t -> t +type CollectorM m t = t -> m () -unmonad :: (MapperM () a -> MapperM () b) -> Mapper a -> Mapper b +unmonad :: (MapperM (State ()) a -> MapperM (State ()) b) -> Mapper a -> Mapper b unmonad traverser mapper thing = evalState (traverser (return . mapper) thing) () -traverseDescriptionsM :: MapperM s Description -> MapperM s AST +collectify :: Monad m => (MapperM m a -> MapperM m b) -> CollectorM m a -> CollectorM m b +collectify traverser collector thing = + traverser mapper thing >>= \_ -> return () + where mapper x = collector x >>= \() -> return x + +traverseDescriptionsM :: Monad m => MapperM m Description -> MapperM m AST traverseDescriptionsM mapper descriptions = mapM mapper descriptions traverseDescriptions :: Mapper Description -> Mapper AST traverseDescriptions = unmonad traverseDescriptionsM +collectDescriptionsM :: Monad m => CollectorM m Description -> CollectorM m AST +collectDescriptionsM = collectify traverseDescriptionsM maybeDo :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) maybeDo _ Nothing = return Nothing maybeDo fun (Just val) = fun val >>= return . Just -traverseModuleItemsM :: MapperM s ModuleItem -> MapperM s Description +traverseModuleItemsM :: Monad m => MapperM m ModuleItem -> MapperM m Description traverseModuleItemsM mapper (Module name ports items) = mapM fullMapper items >>= return . Module name ports where @@ -65,8 +80,10 @@ traverseModuleItemsM _ orig = return orig traverseModuleItems :: Mapper ModuleItem -> Mapper Description traverseModuleItems = unmonad traverseModuleItemsM +collectModuleItemsM :: Monad m => CollectorM m ModuleItem -> CollectorM m Description +collectModuleItemsM = collectify traverseModuleItemsM -traverseStmtsM :: MapperM s Stmt -> MapperM s ModuleItem +traverseStmtsM :: Monad m => MapperM m Stmt -> MapperM m ModuleItem traverseStmtsM mapper = moduleItemMapper where moduleItemMapper (AlwaysC kw stmt) = @@ -74,6 +91,19 @@ traverseStmtsM mapper = moduleItemMapper moduleItemMapper (Function ret name decls stmt) = fullMapper stmt >>= return . Function ret name decls moduleItemMapper other = return $ other + fullMapper = traverseNestedStmtsM mapper + +traverseStmts :: Mapper Stmt -> Mapper ModuleItem +traverseStmts = unmonad traverseStmtsM +collectStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m ModuleItem +collectStmtsM = collectify traverseStmtsM + +-- private utility for turning a thing which maps over a single lever of +-- statements into one that maps over the nested statements first, then the +-- higher levels up +traverseNestedStmtsM :: Monad m => MapperM m Stmt -> MapperM m Stmt +traverseNestedStmtsM mapper = fullMapper + where fullMapper stmt = mapper stmt >>= cs cs (Block decls stmts) = mapM fullMapper stmts >>= return . Block decls cs (Case kw expr cases def) = do @@ -91,5 +121,14 @@ traverseStmtsM mapper = moduleItemMapper cs (Timing sense stmt) = fullMapper stmt >>= return . Timing sense cs (Null) = return Null -traverseStmts :: Mapper Stmt -> Mapper ModuleItem -traverseStmts = unmonad traverseStmtsM +traverseStmtLHSsM :: Monad m => MapperM m LHS -> MapperM m Stmt +traverseStmtLHSsM mapper = traverseNestedStmtsM stmtMapper + where + stmtMapper (AsgnBlk lhs expr) = mapper lhs >>= \lhs' -> return $ AsgnBlk lhs' expr + stmtMapper (Asgn lhs expr) = mapper lhs >>= \lhs' -> return $ Asgn lhs' expr + stmtMapper other = return other + +traverseStmtLHSs :: Mapper LHS -> Mapper Stmt +traverseStmtLHSs = unmonad traverseStmtLHSsM +collectStmtLHSsM :: Monad m => CollectorM m LHS -> CollectorM m Stmt +collectStmtLHSsM = collectify traverseStmtLHSsM