mirror of https://github.com/zachjs/sv2v.git
1167 lines
47 KiB
Haskell
1167 lines
47 KiB
Haskell
{- sv2v
|
|
- Author: Zachary Snow <zach@zachjs.com>
|
|
-
|
|
- Utilities for traversing AST transformations.
|
|
-}
|
|
|
|
module Convert.Traverse
|
|
( MapperM
|
|
, Mapper
|
|
, CollectorM
|
|
, TFStrategy (..)
|
|
, unmonad
|
|
, collectify
|
|
, traverseDescriptionsM
|
|
, traverseDescriptions
|
|
, collectDescriptionsM
|
|
, traverseModuleItemsM
|
|
, traverseModuleItems
|
|
, collectModuleItemsM
|
|
, traverseStmtsM
|
|
, traverseStmts
|
|
, collectStmtsM
|
|
, traverseStmtsM'
|
|
, traverseStmts'
|
|
, collectStmtsM'
|
|
, traverseStmtLHSsM
|
|
, traverseStmtLHSs
|
|
, collectStmtLHSsM
|
|
, traverseExprsM
|
|
, traverseExprs
|
|
, collectExprsM
|
|
, traverseExprsM'
|
|
, traverseExprs'
|
|
, collectExprsM'
|
|
, traverseStmtExprsM
|
|
, traverseStmtExprs
|
|
, collectStmtExprsM
|
|
, traverseLHSsM
|
|
, traverseLHSs
|
|
, collectLHSsM
|
|
, traverseLHSsM'
|
|
, traverseLHSs'
|
|
, collectLHSsM'
|
|
, traverseDeclsM
|
|
, traverseDecls
|
|
, collectDeclsM
|
|
, traverseDeclsM'
|
|
, traverseDecls'
|
|
, collectDeclsM'
|
|
, traverseNestedTypesM
|
|
, traverseNestedTypes
|
|
, collectNestedTypesM
|
|
, traverseTypesM
|
|
, traverseTypes
|
|
, collectTypesM
|
|
, traverseGenItemsM
|
|
, traverseGenItems
|
|
, collectGenItemsM
|
|
, traverseAsgnsM
|
|
, traverseAsgns
|
|
, collectAsgnsM
|
|
, traverseAsgnsM'
|
|
, traverseAsgns'
|
|
, collectAsgnsM'
|
|
, traverseStmtAsgnsM
|
|
, traverseStmtAsgns
|
|
, collectStmtAsgnsM
|
|
, traverseNestedModuleItemsM
|
|
, traverseNestedModuleItems
|
|
, collectNestedModuleItemsM
|
|
, traverseNestedStmts
|
|
, collectNestedStmtsM
|
|
, traverseNestedExprsM
|
|
, traverseNestedExprs
|
|
, collectNestedExprsM
|
|
, traverseNestedLHSsM
|
|
, traverseNestedLHSs
|
|
, collectNestedLHSsM
|
|
, traverseScopesM
|
|
, scopedConversion
|
|
, scopedConversionM
|
|
, stately
|
|
, traverseFilesM
|
|
, traverseFiles
|
|
) where
|
|
|
|
import Data.Functor.Identity (runIdentity)
|
|
import Control.Monad.State
|
|
import Control.Monad.Writer
|
|
import Language.SystemVerilog.AST
|
|
|
|
type MapperM m t = t -> m t
|
|
type Mapper t = t -> t
|
|
type CollectorM m t = t -> m ()
|
|
|
|
data TFStrategy
|
|
= IncludeTFs
|
|
| ExcludeTFs
|
|
deriving Eq
|
|
|
|
unmonad :: (MapperM (State ()) a -> MapperM (State ()) b) -> Mapper a -> Mapper b
|
|
unmonad traverser mapper thing =
|
|
evalState (traverser (return . mapper) thing) ()
|
|
|
|
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 :: Monad m => MapperM m ModuleItem -> MapperM m Description
|
|
traverseModuleItemsM mapper (Part attrs extern kw lifetime name ports items) = do
|
|
items' <- mapM fullMapper items
|
|
let items'' = concatMap breakGenerate items'
|
|
return $ Part attrs extern kw lifetime name ports items''
|
|
where
|
|
fullMapper (Generate [GenBlock "" genItems]) =
|
|
mapM fullGenItemMapper genItems >>= mapper . Generate
|
|
fullMapper (Generate genItems) = do
|
|
let genItems' = filter (/= GenNull) genItems
|
|
mapM fullGenItemMapper genItems' >>= mapper . Generate
|
|
fullMapper (MIAttr attr mi) =
|
|
fullMapper mi >>= return . MIAttr attr
|
|
fullMapper other = mapper other
|
|
fullGenItemMapper = traverseNestedGenItemsM genItemMapper
|
|
genItemMapper (GenModuleItem moduleItem) = do
|
|
moduleItem' <- fullMapper moduleItem
|
|
return $ case moduleItem' of
|
|
Generate subItems -> GenBlock "" subItems
|
|
_ -> GenModuleItem moduleItem'
|
|
genItemMapper (GenIf (Number "1") s _) = return s
|
|
genItemMapper (GenIf (Number "0") _ s) = return s
|
|
genItemMapper (GenBlock _ []) = return GenNull
|
|
genItemMapper other = return other
|
|
breakGenerate :: ModuleItem -> [ModuleItem]
|
|
breakGenerate (Generate genItems) =
|
|
if all isGenModuleItem genItems
|
|
then map (\(GenModuleItem item) -> item) genItems
|
|
else [Generate genItems]
|
|
where
|
|
isGenModuleItem :: GenItem -> Bool
|
|
isGenModuleItem (GenModuleItem _) = True
|
|
isGenModuleItem _ = False
|
|
breakGenerate other = [other]
|
|
traverseModuleItemsM mapper (PackageItem packageItem) = do
|
|
let item = MIPackageItem packageItem
|
|
converted <-
|
|
traverseModuleItemsM mapper (Part [] False Module Nothing "DNE" [] [item])
|
|
let item' = case converted of
|
|
Part [] False Module Nothing "DNE" [] [newItem] -> newItem
|
|
_ -> error $ "redirected PackageItem traverse failed: "
|
|
++ show converted
|
|
return $ case item' of
|
|
MIPackageItem packageItem' -> PackageItem packageItem'
|
|
other -> error $ "encountered bad package module item: " ++ show other
|
|
traverseModuleItemsM mapper (Package lifetime name packageItems) = do
|
|
let items = map MIPackageItem packageItems
|
|
converted <-
|
|
traverseModuleItemsM mapper (Part [] False Module Nothing "DNE" [] items)
|
|
let items' = case converted of
|
|
Part [] False Module Nothing "DNE" [] newItems -> newItems
|
|
_ -> error $ "redirected Package traverse failed: "
|
|
++ show converted
|
|
return $ Package lifetime name $ map (\(MIPackageItem item) -> item) items'
|
|
|
|
traverseModuleItems :: Mapper ModuleItem -> Mapper Description
|
|
traverseModuleItems = unmonad traverseModuleItemsM
|
|
collectModuleItemsM :: Monad m => CollectorM m ModuleItem -> CollectorM m Description
|
|
collectModuleItemsM = collectify traverseModuleItemsM
|
|
|
|
traverseStmtsM' :: Monad m => TFStrategy -> MapperM m Stmt -> MapperM m ModuleItem
|
|
traverseStmtsM' strat mapper = moduleItemMapper
|
|
where
|
|
moduleItemMapper (AlwaysC kw stmt) =
|
|
fullMapper stmt >>= return . AlwaysC kw
|
|
moduleItemMapper (MIPackageItem (Function lifetime ret name decls stmts)) = do
|
|
stmts' <-
|
|
if strat == IncludeTFs
|
|
then mapM fullMapper stmts
|
|
else return stmts
|
|
return $ MIPackageItem $ Function lifetime ret name decls stmts'
|
|
moduleItemMapper (MIPackageItem (Task lifetime name decls stmts)) = do
|
|
stmts' <-
|
|
if strat == IncludeTFs
|
|
then mapM fullMapper stmts
|
|
else return stmts
|
|
return $ MIPackageItem $ Task lifetime name decls stmts'
|
|
moduleItemMapper (Initial stmt) =
|
|
fullMapper stmt >>= return . Initial
|
|
moduleItemMapper other = return $ other
|
|
fullMapper = traverseNestedStmtsM mapper
|
|
|
|
traverseStmts' :: TFStrategy -> Mapper Stmt -> Mapper ModuleItem
|
|
traverseStmts' strat = unmonad $ traverseStmtsM' strat
|
|
collectStmtsM' :: Monad m => TFStrategy -> CollectorM m Stmt -> CollectorM m ModuleItem
|
|
collectStmtsM' strat = collectify $ traverseStmtsM' strat
|
|
|
|
traverseStmtsM :: Monad m => MapperM m Stmt -> MapperM m ModuleItem
|
|
traverseStmtsM = traverseStmtsM' IncludeTFs
|
|
traverseStmts :: Mapper Stmt -> Mapper ModuleItem
|
|
traverseStmts = traverseStmts' IncludeTFs
|
|
collectStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m ModuleItem
|
|
collectStmtsM = collectStmtsM' IncludeTFs
|
|
|
|
-- 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 >>= traverseSinglyNestedStmtsM fullMapper
|
|
|
|
-- variant of the above which only traverses one level down
|
|
traverseSinglyNestedStmtsM :: Monad m => MapperM m Stmt -> MapperM m Stmt
|
|
traverseSinglyNestedStmtsM fullMapper = cs
|
|
where
|
|
cs (StmtAttr a stmt) = fullMapper stmt >>= return . StmtAttr a
|
|
cs (Block _ "" [] []) = return Null
|
|
cs (Block _ "" [] [stmt]) = fullMapper stmt
|
|
cs (Block Seq name decls stmts) = do
|
|
stmts' <- mapM fullMapper stmts
|
|
return $ Block Seq name decls $ concatMap explode stmts'
|
|
where
|
|
explode :: Stmt -> [Stmt]
|
|
explode (Block Seq "" [] ss) = ss
|
|
explode other = [other]
|
|
cs (Block kw name decls stmts) =
|
|
mapM fullMapper stmts >>= return . Block kw name decls
|
|
cs (Case u kw expr cases def) = do
|
|
caseStmts <- mapM fullMapper $ map snd cases
|
|
let cases' = zip (map fst cases) caseStmts
|
|
def' <- maybeDo fullMapper def
|
|
return $ Case u kw expr cases' def'
|
|
cs (AsgnBlk op lhs expr) = return $ AsgnBlk op lhs expr
|
|
cs (Asgn mt lhs expr) = return $ Asgn mt lhs expr
|
|
cs (For a b c stmt) = fullMapper stmt >>= return . For a b c
|
|
cs (While e stmt) = fullMapper stmt >>= return . While e
|
|
cs (RepeatL e stmt) = fullMapper stmt >>= return . RepeatL e
|
|
cs (DoWhile e stmt) = fullMapper stmt >>= return . DoWhile e
|
|
cs (Forever stmt) = fullMapper stmt >>= return . Forever
|
|
cs (Foreach x vars stmt) = fullMapper stmt >>= return . Foreach x vars
|
|
cs (If u e s1 s2) = do
|
|
s1' <- fullMapper s1
|
|
s2' <- fullMapper s2
|
|
return $ If u e s1' s2'
|
|
cs (Timing event stmt) = fullMapper stmt >>= return . Timing event
|
|
cs (Return expr) = return $ Return expr
|
|
cs (Subroutine ps f exprs) = return $ Subroutine ps f exprs
|
|
cs (Trigger blocks x) = return $ Trigger blocks x
|
|
cs (Assertion a) =
|
|
traverseAssertionStmtsM fullMapper a >>= return . Assertion
|
|
cs (Continue) = return Continue
|
|
cs (Break) = return Break
|
|
cs (Null) = return Null
|
|
|
|
traverseAssertionStmtsM :: Monad m => MapperM m Stmt -> MapperM m Assertion
|
|
traverseAssertionStmtsM mapper = assertionMapper
|
|
where
|
|
actionBlockMapper (ActionBlockIf stmt) =
|
|
mapper stmt >>= return . ActionBlockIf
|
|
actionBlockMapper (ActionBlockElse Nothing stmt) =
|
|
mapper stmt >>= return . ActionBlockElse Nothing
|
|
actionBlockMapper (ActionBlockElse (Just s1) s2) = do
|
|
s1' <- mapper s1
|
|
s2' <- mapper s2
|
|
return $ ActionBlockElse (Just s1') s2'
|
|
assertionMapper (Assert e ab) =
|
|
actionBlockMapper ab >>= return . Assert e
|
|
assertionMapper (Assume e ab) =
|
|
actionBlockMapper ab >>= return . Assume e
|
|
assertionMapper (Cover e stmt) =
|
|
mapper stmt >>= return . Cover e
|
|
|
|
-- Note that this does not include the expressions without the statements of the
|
|
-- actions associated with the assertions.
|
|
traverseAssertionExprsM :: Monad m => MapperM m Expr -> MapperM m Assertion
|
|
traverseAssertionExprsM mapper = assertionMapper
|
|
where
|
|
seqExprMapper (SeqExpr e) =
|
|
mapper e >>= return . SeqExpr
|
|
seqExprMapper (SeqExprAnd s1 s2) =
|
|
ssMapper SeqExprAnd s1 s2
|
|
seqExprMapper (SeqExprOr s1 s2) =
|
|
ssMapper SeqExprOr s1 s2
|
|
seqExprMapper (SeqExprIntersect s1 s2) =
|
|
ssMapper SeqExprIntersect s1 s2
|
|
seqExprMapper (SeqExprWithin s1 s2) =
|
|
ssMapper SeqExprWithin s1 s2
|
|
seqExprMapper (SeqExprThroughout e s) = do
|
|
e' <- mapper e
|
|
s' <- seqExprMapper s
|
|
return $ SeqExprThroughout e' s'
|
|
seqExprMapper (SeqExprDelay ms e s) = do
|
|
ms' <- case ms of
|
|
Nothing -> return Nothing
|
|
Just x -> seqExprMapper x >>= return . Just
|
|
e' <- mapper e
|
|
s' <- seqExprMapper s
|
|
return $ SeqExprDelay ms' e' s'
|
|
seqExprMapper (SeqExprFirstMatch s items) = do
|
|
s' <- seqExprMapper s
|
|
items' <- mapM seqMatchItemMapper items
|
|
return $ SeqExprFirstMatch s' items'
|
|
seqMatchItemMapper (Left (a, b, c)) = do
|
|
c' <- mapper c
|
|
return $ Left (a, b, c')
|
|
seqMatchItemMapper (Right (x, (Args l p))) = do
|
|
l' <- mapM maybeExprMapper l
|
|
pes <- mapM maybeExprMapper $ map snd p
|
|
let p' = zip (map fst p) pes
|
|
return $ Right (x, Args l' p')
|
|
maybeExprMapper Nothing = return Nothing
|
|
maybeExprMapper (Just e) =
|
|
mapper e >>= return . Just
|
|
ppMapper constructor p1 p2 = do
|
|
p1' <- propExprMapper p1
|
|
p2' <- propExprMapper p2
|
|
return $ constructor p1' p2'
|
|
ssMapper constructor s1 s2 = do
|
|
s1' <- seqExprMapper s1
|
|
s2' <- seqExprMapper s2
|
|
return $ constructor s1' s2'
|
|
spMapper constructor se pe = do
|
|
se' <- seqExprMapper se
|
|
pe' <- propExprMapper pe
|
|
return $ constructor se' pe'
|
|
propExprMapper (PropExpr se) =
|
|
seqExprMapper se >>= return . PropExpr
|
|
propExprMapper (PropExprImpliesO se pe) =
|
|
spMapper PropExprImpliesO se pe
|
|
propExprMapper (PropExprImpliesNO se pe) =
|
|
spMapper PropExprImpliesNO se pe
|
|
propExprMapper (PropExprFollowsO se pe) =
|
|
spMapper PropExprFollowsO se pe
|
|
propExprMapper (PropExprFollowsNO se pe) =
|
|
spMapper PropExprFollowsNO se pe
|
|
propExprMapper (PropExprIff p1 p2) =
|
|
ppMapper PropExprIff p1 p2
|
|
propSpecMapper (PropertySpec ms me pe) = do
|
|
me' <- case me of
|
|
Nothing -> return Nothing
|
|
Just e -> mapper e >>= return . Just
|
|
pe' <- propExprMapper pe
|
|
return $ PropertySpec ms me' pe'
|
|
assertionExprMapper (Left e) =
|
|
propSpecMapper e >>= return . Left
|
|
assertionExprMapper (Right e) =
|
|
mapper e >>= return . Right
|
|
assertionMapper (Assert e ab) = do
|
|
e' <- assertionExprMapper e
|
|
return $ Assert e' ab
|
|
assertionMapper (Assume e ab) = do
|
|
e' <- assertionExprMapper e
|
|
return $ Assume e' ab
|
|
assertionMapper (Cover e stmt) = do
|
|
e' <- assertionExprMapper e
|
|
return $ Cover e' stmt
|
|
|
|
traverseStmtLHSsM :: Monad m => MapperM m LHS -> MapperM m Stmt
|
|
traverseStmtLHSsM mapper = stmtMapper
|
|
where
|
|
fullMapper = mapper
|
|
stmtMapper (Timing (Event sense) stmt) = do
|
|
sense' <- senseMapper sense
|
|
return $ Timing (Event sense') stmt
|
|
stmtMapper (Asgn (Just (Event sense)) lhs expr) = do
|
|
lhs' <- fullMapper lhs
|
|
sense' <- senseMapper sense
|
|
return $ Asgn (Just $ Event sense') lhs' expr
|
|
stmtMapper (AsgnBlk op lhs expr) = fullMapper lhs >>= \lhs' -> return $ AsgnBlk op lhs' expr
|
|
stmtMapper (Asgn mt lhs expr) = fullMapper lhs >>= \lhs' -> return $ Asgn mt lhs' expr
|
|
stmtMapper (For inits me incrs stmt) = do
|
|
inits' <- mapInits inits
|
|
let (lhss, asgnOps, exprs) = unzip3 incrs
|
|
lhss' <- mapM fullMapper lhss
|
|
let incrs' = zip3 lhss' asgnOps exprs
|
|
return $ For inits' me incrs' stmt
|
|
where
|
|
mapInits (Left decls) = return $ Left decls
|
|
mapInits (Right asgns) = do
|
|
let (lhss, exprs) = unzip asgns
|
|
lhss' <- mapM fullMapper lhss
|
|
return $ Right $ zip lhss' exprs
|
|
stmtMapper (Assertion a) =
|
|
assertionMapper a >>= return . Assertion
|
|
stmtMapper other = return other
|
|
senseMapper (Sense lhs) = fullMapper lhs >>= return . Sense
|
|
senseMapper (SensePosedge lhs) = fullMapper lhs >>= return . SensePosedge
|
|
senseMapper (SenseNegedge lhs) = fullMapper lhs >>= return . SenseNegedge
|
|
senseMapper (SenseOr s1 s2) = do
|
|
s1' <- senseMapper s1
|
|
s2' <- senseMapper s2
|
|
return $ SenseOr s1' s2'
|
|
senseMapper (SenseStar ) = return SenseStar
|
|
assertionExprMapper (Left (PropertySpec (Just sense) me pe)) = do
|
|
sense' <- senseMapper sense
|
|
return $ Left $ PropertySpec (Just sense') me pe
|
|
assertionExprMapper other = return $ other
|
|
assertionMapper (Assert e ab) = do
|
|
e' <- assertionExprMapper e
|
|
return $ Assert e' ab
|
|
assertionMapper (Assume e ab) = do
|
|
e' <- assertionExprMapper e
|
|
return $ Assume e' ab
|
|
assertionMapper (Cover e stmt) = do
|
|
e' <- assertionExprMapper e
|
|
return $ Cover e' stmt
|
|
|
|
traverseStmtLHSs :: Mapper LHS -> Mapper Stmt
|
|
traverseStmtLHSs = unmonad traverseStmtLHSsM
|
|
collectStmtLHSsM :: Monad m => CollectorM m LHS -> CollectorM m Stmt
|
|
collectStmtLHSsM = collectify traverseStmtLHSsM
|
|
|
|
traverseNestedExprsM :: Monad m => MapperM m Expr -> MapperM m Expr
|
|
traverseNestedExprsM mapper = exprMapper
|
|
where
|
|
exprMapper e = mapper e >>= em
|
|
maybeExprMapper Nothing = return Nothing
|
|
maybeExprMapper (Just e) =
|
|
exprMapper e >>= return . Just
|
|
typeOrExprMapper (Left t) = return $ Left t
|
|
typeOrExprMapper (Right e) =
|
|
exprMapper e >>= return . Right
|
|
em (String s) = return $ String s
|
|
em (Number s) = return $ Number s
|
|
em (Time s) = return $ Time s
|
|
em (Ident i) = return $ Ident i
|
|
em (PSIdent x y) = return $ PSIdent x y
|
|
em (Range e m (e1, e2)) = do
|
|
e' <- exprMapper e
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
return $ Range e' m (e1', e2')
|
|
em (Bit e1 e2) = do
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
return $ Bit e1' e2'
|
|
em (Repeat e l) = do
|
|
e' <- exprMapper e
|
|
l' <- mapM exprMapper l
|
|
return $ Repeat e' l'
|
|
em (Concat l) =
|
|
mapM exprMapper l >>= return . Concat
|
|
em (Stream o e l) = do
|
|
e' <- exprMapper e
|
|
l' <- mapM exprMapper l
|
|
return $ Stream o e' l'
|
|
em (Call ps f (Args l p)) = do
|
|
l' <- mapM maybeExprMapper l
|
|
pes <- mapM maybeExprMapper $ map snd p
|
|
let p' = zip (map fst p) pes
|
|
return $ Call ps f (Args l' p')
|
|
em (UniOp o e) =
|
|
exprMapper e >>= return . UniOp o
|
|
em (BinOp o e1 e2) = do
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
return $ BinOp o e1' e2'
|
|
em (Mux e1 e2 e3) = do
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
e3' <- exprMapper e3
|
|
return $ Mux e1' e2' e3'
|
|
em (Cast (Left t) e) =
|
|
exprMapper e >>= return . Cast (Left t)
|
|
em (Cast (Right e1) e2) = do
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
return $ Cast (Right e1') e2'
|
|
em (DimsFn f tore) =
|
|
typeOrExprMapper tore >>= return . DimsFn f
|
|
em (DimFn f tore e) = do
|
|
tore' <- typeOrExprMapper tore
|
|
e' <- exprMapper e
|
|
return $ DimFn f tore' e'
|
|
em (Dot e x) =
|
|
exprMapper e >>= \e' -> return $ Dot e' x
|
|
em (Pattern l) = do
|
|
let names = map fst l
|
|
exprs <- mapM exprMapper $ map snd l
|
|
return $ Pattern $ zip names exprs
|
|
em (MinTypMax e1 e2 e3) = do
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
e3' <- exprMapper e3
|
|
return $ MinTypMax e1' e2' e3'
|
|
em (Nil) = return Nil
|
|
|
|
exprMapperHelpers :: Monad m => MapperM m Expr ->
|
|
(MapperM m Range, MapperM m (Maybe Expr), MapperM m Decl, MapperM m LHS, MapperM m Type)
|
|
exprMapperHelpers exprMapper =
|
|
(rangeMapper, maybeExprMapper, declMapper, traverseNestedLHSsM lhsMapper, typeMapper)
|
|
where
|
|
|
|
rangeMapper (a, b) = do
|
|
a' <- exprMapper a
|
|
b' <- exprMapper b
|
|
return (a', b')
|
|
|
|
maybeExprMapper Nothing = return Nothing
|
|
maybeExprMapper (Just e) =
|
|
exprMapper e >>= return . Just
|
|
|
|
typeMapper' t = do
|
|
let (tf, rs) = typeRanges t
|
|
rs' <- mapM rangeMapper rs
|
|
return $ tf rs'
|
|
typeMapper = traverseNestedTypesM typeMapper'
|
|
|
|
maybeTypeMapper Nothing = return Nothing
|
|
maybeTypeMapper (Just t) =
|
|
typeMapper t >>= return . Just
|
|
|
|
declMapper (Param s t x e) = do
|
|
t' <- typeMapper t
|
|
e' <- exprMapper e
|
|
return $ Param s t' x e'
|
|
declMapper (ParamType s x mt) = do
|
|
mt' <- maybeTypeMapper mt
|
|
return $ ParamType s x mt'
|
|
declMapper (Variable d t x a me) = do
|
|
t' <- typeMapper t
|
|
a' <- mapM rangeMapper a
|
|
me' <- maybeExprMapper me
|
|
return $ Variable d t' x a' me'
|
|
|
|
lhsMapper (LHSRange l m r) =
|
|
rangeMapper r >>= return . LHSRange l m
|
|
lhsMapper (LHSBit l e) =
|
|
exprMapper e >>= return . LHSBit l
|
|
lhsMapper (LHSStream o e ls) = do
|
|
e' <- exprMapper e
|
|
return $ LHSStream o e' ls
|
|
lhsMapper other = return other
|
|
|
|
traverseExprsM' :: Monad m => TFStrategy -> MapperM m Expr -> MapperM m ModuleItem
|
|
traverseExprsM' strat exprMapper = moduleItemMapper
|
|
where
|
|
|
|
(rangeMapper, maybeExprMapper, declMapper, lhsMapper, typeMapper)
|
|
= exprMapperHelpers exprMapper
|
|
|
|
stmtMapper = traverseNestedStmtsM (traverseStmtExprsM exprMapper)
|
|
|
|
portBindingMapper (p, me) =
|
|
maybeExprMapper me >>= \me' -> return (p, me')
|
|
|
|
paramBindingMapper (p, Left t) =
|
|
typeMapper t >>= \t' -> return (p, Left t')
|
|
paramBindingMapper (p, Right e) =
|
|
exprMapper e >>= \e' -> return (p, Right e')
|
|
|
|
moduleItemMapper (MIAttr attr mi) =
|
|
-- note: we exclude expressions in attributes from conversion
|
|
return $ MIAttr attr mi
|
|
moduleItemMapper (MIPackageItem (Typedef t x)) = do
|
|
t' <- typeMapper t
|
|
return $ MIPackageItem $ Typedef t' x
|
|
moduleItemMapper (MIPackageItem (Decl decl)) =
|
|
declMapper decl >>= return . MIPackageItem . Decl
|
|
moduleItemMapper (Defparam lhs expr) = do
|
|
lhs' <- lhsMapper lhs
|
|
expr' <- exprMapper expr
|
|
return $ Defparam lhs' expr'
|
|
moduleItemMapper (AlwaysC kw stmt) =
|
|
stmtMapper stmt >>= return . AlwaysC kw
|
|
moduleItemMapper (Initial stmt) =
|
|
stmtMapper stmt >>= return . Initial
|
|
moduleItemMapper (Assign delay lhs expr) = do
|
|
delay' <- maybeExprMapper delay
|
|
lhs' <- lhsMapper lhs
|
|
expr' <- exprMapper expr
|
|
return $ Assign delay' lhs' expr'
|
|
moduleItemMapper (MIPackageItem (Function lifetime ret f decls stmts)) = do
|
|
ret' <- typeMapper ret
|
|
decls' <-
|
|
if strat == IncludeTFs
|
|
then mapM declMapper decls
|
|
else return decls
|
|
stmts' <-
|
|
if strat == IncludeTFs
|
|
then mapM stmtMapper stmts
|
|
else return stmts
|
|
return $ MIPackageItem $ Function lifetime ret' f decls' stmts'
|
|
moduleItemMapper (MIPackageItem (Task lifetime f decls stmts)) = do
|
|
decls' <-
|
|
if strat == IncludeTFs
|
|
then mapM declMapper decls
|
|
else return decls
|
|
stmts' <-
|
|
if strat == IncludeTFs
|
|
then mapM stmtMapper stmts
|
|
else return stmts
|
|
return $ MIPackageItem $ Task lifetime f decls' stmts'
|
|
moduleItemMapper (Instance m p x r l) = do
|
|
p' <- mapM paramBindingMapper p
|
|
l' <- mapM portBindingMapper l
|
|
r' <- mapM rangeMapper r
|
|
return $ Instance m p' x r' l'
|
|
moduleItemMapper (Modport x l) =
|
|
mapM modportDeclMapper l >>= return . Modport x
|
|
moduleItemMapper (NInputGate kw x lhs exprs) = do
|
|
exprs' <- mapM exprMapper exprs
|
|
lhs' <- lhsMapper lhs
|
|
return $ NInputGate kw x lhs' exprs'
|
|
moduleItemMapper (NOutputGate kw x lhss expr) = do
|
|
lhss' <- mapM lhsMapper lhss
|
|
expr' <- exprMapper expr
|
|
return $ NOutputGate kw x lhss' expr'
|
|
moduleItemMapper (Genvar x) = return $ Genvar x
|
|
moduleItemMapper (Generate items) = do
|
|
items' <- mapM (traverseNestedGenItemsM genItemMapper) items
|
|
return $ Generate items'
|
|
moduleItemMapper (MIPackageItem (Directive c)) =
|
|
return $ MIPackageItem $ Directive c
|
|
moduleItemMapper (MIPackageItem (Comment c)) =
|
|
return $ MIPackageItem $ Comment c
|
|
moduleItemMapper (MIPackageItem (Import x y)) =
|
|
return $ MIPackageItem $ Import x y
|
|
moduleItemMapper (MIPackageItem (Export x)) =
|
|
return $ MIPackageItem $ Export x
|
|
moduleItemMapper (AssertionItem (mx, a)) = do
|
|
a' <- traverseAssertionStmtsM stmtMapper a
|
|
a'' <- traverseAssertionExprsM exprMapper a'
|
|
return $ AssertionItem (mx, a'')
|
|
|
|
genItemMapper (GenFor (n1, x1, e1) cc (x2, op2, e2) subItem) = do
|
|
e1' <- exprMapper e1
|
|
e2' <- exprMapper e2
|
|
cc' <- exprMapper cc
|
|
return $ GenFor (n1, x1, e1') cc' (x2, op2, e2') subItem
|
|
genItemMapper (GenIf e i1 i2) = do
|
|
e' <- exprMapper e
|
|
return $ GenIf e' i1 i2
|
|
genItemMapper (GenCase e cases def) = do
|
|
e' <- exprMapper e
|
|
caseExprs <- mapM (mapM exprMapper . fst) cases
|
|
let cases' = zip caseExprs (map snd cases)
|
|
return $ GenCase e' cases' def
|
|
genItemMapper other = return other
|
|
|
|
modportDeclMapper (dir, ident, Just e) = do
|
|
e' <- exprMapper e
|
|
return (dir, ident, Just e')
|
|
modportDeclMapper other = return other
|
|
|
|
traverseExprs' :: TFStrategy -> Mapper Expr -> Mapper ModuleItem
|
|
traverseExprs' strat = unmonad $ traverseExprsM' strat
|
|
collectExprsM' :: Monad m => TFStrategy -> CollectorM m Expr -> CollectorM m ModuleItem
|
|
collectExprsM' strat = collectify $ traverseExprsM' strat
|
|
|
|
traverseExprsM :: Monad m => MapperM m Expr -> MapperM m ModuleItem
|
|
traverseExprsM = traverseExprsM' IncludeTFs
|
|
traverseExprs :: Mapper Expr -> Mapper ModuleItem
|
|
traverseExprs = traverseExprs' IncludeTFs
|
|
collectExprsM :: Monad m => CollectorM m Expr -> CollectorM m ModuleItem
|
|
collectExprsM = collectExprsM' IncludeTFs
|
|
|
|
traverseStmtExprsM :: Monad m => MapperM m Expr -> MapperM m Stmt
|
|
traverseStmtExprsM exprMapper = flatStmtMapper
|
|
where
|
|
|
|
(_, maybeExprMapper, declMapper, lhsMapper, _)
|
|
= exprMapperHelpers exprMapper
|
|
|
|
caseMapper (exprs, stmt) = do
|
|
exprs' <- mapM exprMapper exprs
|
|
return (exprs', stmt)
|
|
stmtMapper = traverseNestedStmtsM flatStmtMapper
|
|
flatStmtMapper (StmtAttr attr stmt) =
|
|
-- note: we exclude expressions in attributes from conversion
|
|
return $ StmtAttr attr stmt
|
|
flatStmtMapper (Block kw name decls stmts) = do
|
|
decls' <- mapM declMapper decls
|
|
return $ Block kw name decls' stmts
|
|
flatStmtMapper (Case u kw e cases def) = do
|
|
e' <- exprMapper e
|
|
cases' <- mapM caseMapper cases
|
|
return $ Case u kw e' cases' def
|
|
flatStmtMapper (AsgnBlk op lhs expr) = do
|
|
lhs' <- lhsMapper lhs
|
|
expr' <- exprMapper expr
|
|
return $ AsgnBlk op lhs' expr'
|
|
flatStmtMapper (Asgn mt lhs expr) = do
|
|
lhs' <- lhsMapper lhs
|
|
expr' <- exprMapper expr
|
|
return $ Asgn mt lhs' expr'
|
|
flatStmtMapper (For inits cc asgns stmt) = do
|
|
inits' <- initsMapper inits
|
|
cc' <- exprMapper cc
|
|
asgns' <- mapM asgnMapper asgns
|
|
return $ For inits' cc' asgns' stmt
|
|
flatStmtMapper (While e stmt) =
|
|
exprMapper e >>= \e' -> return $ While e' stmt
|
|
flatStmtMapper (RepeatL e stmt) =
|
|
exprMapper e >>= \e' -> return $ RepeatL e' stmt
|
|
flatStmtMapper (DoWhile e stmt) =
|
|
exprMapper e >>= \e' -> return $ DoWhile e' stmt
|
|
flatStmtMapper (Forever stmt) = return $ Forever stmt
|
|
flatStmtMapper (Foreach x vars stmt) = return $ Foreach x vars stmt
|
|
flatStmtMapper (If u cc s1 s2) =
|
|
exprMapper cc >>= \cc' -> return $ If u cc' s1 s2
|
|
flatStmtMapper (Timing event stmt) = return $ Timing event stmt
|
|
flatStmtMapper (Subroutine ps f (Args l p)) = do
|
|
l' <- mapM maybeExprMapper l
|
|
pes <- mapM maybeExprMapper $ map snd p
|
|
let p' = zip (map fst p) pes
|
|
return $ Subroutine ps f (Args l' p')
|
|
flatStmtMapper (Return expr) =
|
|
exprMapper expr >>= return . Return
|
|
flatStmtMapper (Trigger blocks x) = return $ Trigger blocks x
|
|
flatStmtMapper (Assertion a) = do
|
|
a' <- traverseAssertionStmtsM stmtMapper a
|
|
a'' <- traverseAssertionExprsM exprMapper a'
|
|
return $ Assertion a''
|
|
flatStmtMapper (Continue) = return Continue
|
|
flatStmtMapper (Break) = return Break
|
|
flatStmtMapper (Null) = return Null
|
|
|
|
initsMapper (Left decls) = mapM declMapper decls >>= return . Left
|
|
initsMapper (Right asgns) = mapM mapper asgns >>= return . Right
|
|
where mapper (l, e) = exprMapper e >>= return . (,) l
|
|
|
|
asgnMapper (l, op, e) = exprMapper e >>= \e' -> return $ (l, op, e')
|
|
|
|
traverseStmtExprs :: Mapper Expr -> Mapper Stmt
|
|
traverseStmtExprs = unmonad traverseStmtExprsM
|
|
collectStmtExprsM :: Monad m => CollectorM m Expr -> CollectorM m Stmt
|
|
collectStmtExprsM = collectify traverseStmtExprsM
|
|
|
|
traverseLHSsM' :: Monad m => TFStrategy -> MapperM m LHS -> MapperM m ModuleItem
|
|
traverseLHSsM' strat mapper item =
|
|
traverseStmtsM' strat (traverseStmtLHSsM mapper) item >>= traverseModuleItemLHSsM
|
|
where
|
|
traverseModuleItemLHSsM (Assign delay lhs expr) = do
|
|
lhs' <- mapper lhs
|
|
return $ Assign delay lhs' expr
|
|
traverseModuleItemLHSsM (Defparam lhs expr) = do
|
|
lhs' <- mapper lhs
|
|
return $ Defparam lhs' expr
|
|
traverseModuleItemLHSsM (NOutputGate kw x lhss expr) = do
|
|
lhss' <- mapM mapper lhss
|
|
return $ NOutputGate kw x lhss' expr
|
|
traverseModuleItemLHSsM (NInputGate kw x lhs exprs) = do
|
|
lhs' <- mapper lhs
|
|
return $ NInputGate kw x lhs' exprs
|
|
traverseModuleItemLHSsM (AssertionItem (mx, a)) = do
|
|
converted <-
|
|
traverseNestedStmtsM (traverseStmtLHSsM mapper) (Assertion a)
|
|
return $ case converted of
|
|
Assertion a' -> AssertionItem (mx, a')
|
|
_ -> error $ "redirected AssertionItem traverse failed: "
|
|
++ show converted
|
|
traverseModuleItemLHSsM (Generate items) = do
|
|
items' <- mapM (traverseNestedGenItemsM traverGenItemLHSsM) items
|
|
return $ Generate items'
|
|
traverseModuleItemLHSsM other = return other
|
|
traverGenItemLHSsM (GenFor (n1, x1, e1) cc (x2, op2, e2) subItem) = do
|
|
wrapped_x1' <- (if n1 then return else mapper) $ LHSIdent x1
|
|
wrapped_x2' <- mapper $ LHSIdent x2
|
|
let LHSIdent x1' = wrapped_x1'
|
|
let LHSIdent x2' = wrapped_x2'
|
|
return $ GenFor (n1, x1', e1) cc (x2', op2, e2) subItem
|
|
traverGenItemLHSsM other = return other
|
|
|
|
traverseLHSs' :: TFStrategy -> Mapper LHS -> Mapper ModuleItem
|
|
traverseLHSs' strat = unmonad $ traverseLHSsM' strat
|
|
collectLHSsM' :: Monad m => TFStrategy -> CollectorM m LHS -> CollectorM m ModuleItem
|
|
collectLHSsM' strat = collectify $ traverseLHSsM' strat
|
|
|
|
traverseLHSsM :: Monad m => MapperM m LHS -> MapperM m ModuleItem
|
|
traverseLHSsM = traverseLHSsM' IncludeTFs
|
|
traverseLHSs :: Mapper LHS -> Mapper ModuleItem
|
|
traverseLHSs = traverseLHSs' IncludeTFs
|
|
collectLHSsM :: Monad m => CollectorM m LHS -> CollectorM m ModuleItem
|
|
collectLHSsM = collectLHSsM' IncludeTFs
|
|
|
|
traverseNestedLHSsM :: Monad m => MapperM m LHS -> MapperM m LHS
|
|
traverseNestedLHSsM mapper = fullMapper
|
|
where
|
|
fullMapper lhs = mapper lhs >>= tl
|
|
tl (LHSIdent x ) = return $ LHSIdent x
|
|
tl (LHSBit l e ) = fullMapper l >>= \l' -> return $ LHSBit l' e
|
|
tl (LHSRange l m r ) = fullMapper l >>= \l' -> return $ LHSRange l' m r
|
|
tl (LHSDot l x ) = fullMapper l >>= \l' -> return $ LHSDot l' x
|
|
tl (LHSConcat lhss) = mapM fullMapper lhss >>= return . LHSConcat
|
|
tl (LHSStream o e lhss) = mapM fullMapper lhss >>= return . LHSStream o e
|
|
|
|
traverseNestedLHSs :: Mapper LHS -> Mapper LHS
|
|
traverseNestedLHSs = unmonad traverseNestedLHSsM
|
|
collectNestedLHSsM :: Monad m => CollectorM m LHS -> CollectorM m LHS
|
|
collectNestedLHSsM = collectify traverseNestedLHSsM
|
|
|
|
traverseDeclsM' :: Monad m => TFStrategy -> MapperM m Decl -> MapperM m ModuleItem
|
|
traverseDeclsM' strat mapper item = do
|
|
item' <- miMapper item
|
|
traverseStmtsM' strat stmtMapper item'
|
|
where
|
|
miMapper (MIPackageItem (Decl decl)) =
|
|
mapper decl >>= return . MIPackageItem . Decl
|
|
miMapper (MIPackageItem (Function l t x decls stmts)) = do
|
|
decls' <-
|
|
if strat == IncludeTFs
|
|
then mapM mapper decls
|
|
else return decls
|
|
return $ MIPackageItem $ Function l t x decls' stmts
|
|
miMapper (MIPackageItem (Task l x decls stmts)) = do
|
|
decls' <-
|
|
if strat == IncludeTFs
|
|
then mapM mapper decls
|
|
else return decls
|
|
return $ MIPackageItem $ Task l x decls' stmts
|
|
miMapper other = return other
|
|
stmtMapper (Block kw name decls stmts) = do
|
|
decls' <- mapM mapper decls
|
|
return $ Block kw name decls' stmts
|
|
stmtMapper other = return other
|
|
|
|
traverseDecls' :: TFStrategy -> Mapper Decl -> Mapper ModuleItem
|
|
traverseDecls' strat = unmonad $ traverseDeclsM' strat
|
|
collectDeclsM' :: Monad m => TFStrategy -> CollectorM m Decl -> CollectorM m ModuleItem
|
|
collectDeclsM' strat = collectify $ traverseDeclsM' strat
|
|
|
|
traverseDeclsM :: Monad m => MapperM m Decl -> MapperM m ModuleItem
|
|
traverseDeclsM = traverseDeclsM' IncludeTFs
|
|
traverseDecls :: Mapper Decl -> Mapper ModuleItem
|
|
traverseDecls = traverseDecls' IncludeTFs
|
|
collectDeclsM :: Monad m => CollectorM m Decl -> CollectorM m ModuleItem
|
|
collectDeclsM = collectDeclsM' IncludeTFs
|
|
|
|
traverseNestedTypesM :: Monad m => MapperM m Type -> MapperM m Type
|
|
traverseNestedTypesM mapper = fullMapper
|
|
where
|
|
fullMapper t = tm t >>= mapper
|
|
tm (Alias ps xx rs) = return $ Alias ps xx rs
|
|
tm (Net kw sg rs) = return $ Net kw sg rs
|
|
tm (Implicit sg rs) = return $ Implicit sg rs
|
|
tm (IntegerVector kw sg rs) = return $ IntegerVector kw sg rs
|
|
tm (IntegerAtom kw sg ) = return $ IntegerAtom kw sg
|
|
tm (NonInteger kw ) = return $ NonInteger kw
|
|
tm (InterfaceT x my r) = return $ InterfaceT x my r
|
|
tm (Enum Nothing vals r) =
|
|
return $ Enum Nothing vals r
|
|
tm (Enum (Just t) vals r) = do
|
|
t' <- fullMapper t
|
|
return $ Enum (Just t') vals r
|
|
tm (Struct p fields r) = do
|
|
types <- mapM fullMapper $ map fst fields
|
|
let idents = map snd fields
|
|
return $ Struct p (zip types idents) r
|
|
tm (Union p fields r) = do
|
|
types <- mapM fullMapper $ map fst fields
|
|
let idents = map snd fields
|
|
return $ Union p (zip types idents) r
|
|
|
|
traverseNestedTypes :: Mapper Type -> Mapper Type
|
|
traverseNestedTypes = unmonad traverseNestedTypesM
|
|
collectNestedTypesM :: Monad m => CollectorM m Type -> CollectorM m Type
|
|
collectNestedTypesM = collectify traverseNestedTypesM
|
|
|
|
traverseTypesM :: Monad m => MapperM m Type -> MapperM m ModuleItem
|
|
traverseTypesM mapper item =
|
|
miMapper item >>=
|
|
traverseDeclsM declMapper >>=
|
|
traverseExprsM (traverseNestedExprsM exprMapper)
|
|
where
|
|
fullMapper = traverseNestedTypesM mapper
|
|
maybeMapper Nothing = return Nothing
|
|
maybeMapper (Just t) = fullMapper t >>= return . Just
|
|
typeOrExprMapper (Right e) = return $ Right e
|
|
typeOrExprMapper (Left t) =
|
|
fullMapper t >>= return . Left
|
|
exprMapper (Cast (Left t) e) =
|
|
fullMapper t >>= \t' -> return $ Cast (Left t') e
|
|
exprMapper (DimsFn f tore) =
|
|
typeOrExprMapper tore >>= return . DimsFn f
|
|
exprMapper (DimFn f tore e) = do
|
|
tore' <- typeOrExprMapper tore
|
|
return $ DimFn f tore' e
|
|
exprMapper other = return other
|
|
declMapper (Param s t x e) =
|
|
fullMapper t >>= \t' -> return $ Param s t' x e
|
|
declMapper (ParamType s x mt) =
|
|
maybeMapper mt >>= \mt' -> return $ ParamType s x mt'
|
|
declMapper (Variable d t x a me) =
|
|
fullMapper t >>= \t' -> return $ Variable d t' x a me
|
|
miMapper (MIPackageItem (Typedef t x)) =
|
|
fullMapper t >>= \t' -> return $ MIPackageItem $ Typedef t' x
|
|
miMapper (MIPackageItem (Function l t x d s)) =
|
|
fullMapper t >>= \t' -> return $ MIPackageItem $ Function l t' x d s
|
|
miMapper (MIPackageItem (other @ (Task _ _ _ _))) =
|
|
return $ MIPackageItem other
|
|
miMapper (Instance m params x r p) = do
|
|
params' <- mapM mapParam params
|
|
return $ Instance m params' x r p
|
|
where
|
|
mapParam (i, Left t) =
|
|
fullMapper t >>= \t' -> return (i, Left t')
|
|
mapParam (i, Right e) = return $ (i, Right e)
|
|
miMapper other = return other
|
|
|
|
traverseTypes :: Mapper Type -> Mapper ModuleItem
|
|
traverseTypes = unmonad traverseTypesM
|
|
collectTypesM :: Monad m => CollectorM m Type -> CollectorM m ModuleItem
|
|
collectTypesM = collectify traverseTypesM
|
|
|
|
traverseGenItemsM :: Monad m => MapperM m GenItem -> MapperM m ModuleItem
|
|
traverseGenItemsM mapper = moduleItemMapper
|
|
where
|
|
fullMapper = traverseNestedGenItemsM mapper
|
|
moduleItemMapper (Generate genItems) =
|
|
mapM fullMapper genItems >>= return . Generate
|
|
moduleItemMapper other = return other
|
|
|
|
traverseGenItems :: Mapper GenItem -> Mapper ModuleItem
|
|
traverseGenItems = unmonad traverseGenItemsM
|
|
collectGenItemsM :: Monad m => CollectorM m GenItem -> CollectorM m ModuleItem
|
|
collectGenItemsM = collectify traverseGenItemsM
|
|
|
|
-- traverses all GenItems within a given GenItem, but doesn't inspect within
|
|
-- GenModuleItems
|
|
traverseNestedGenItemsM :: Monad m => MapperM m GenItem -> MapperM m GenItem
|
|
traverseNestedGenItemsM mapper = fullMapper
|
|
where
|
|
fullMapper stmt =
|
|
mapper stmt >>= traverseSinglyNestedGenItemsM fullMapper
|
|
|
|
traverseSinglyNestedGenItemsM :: Monad m => MapperM m GenItem -> MapperM m GenItem
|
|
traverseSinglyNestedGenItemsM fullMapper = gim
|
|
where
|
|
gim (GenBlock x subItems) = do
|
|
subItems' <- mapM fullMapper subItems
|
|
return $ GenBlock x (concatMap flattenBlocks subItems')
|
|
gim (GenFor a b c subItem) = do
|
|
subItem' <- fullMapper subItem
|
|
return $ GenFor a b c subItem'
|
|
gim (GenIf e i1 i2) = do
|
|
i1' <- fullMapper i1
|
|
i2' <- fullMapper i2
|
|
return $ GenIf e i1' i2'
|
|
gim (GenCase e cases def) = do
|
|
caseItems <- mapM (fullMapper . snd) cases
|
|
let cases' = zip (map fst cases) caseItems
|
|
def' <- maybeDo fullMapper def
|
|
return $ GenCase e cases' def'
|
|
gim (GenModuleItem moduleItem) =
|
|
return $ GenModuleItem moduleItem
|
|
gim (GenNull) = return GenNull
|
|
flattenBlocks :: GenItem -> [GenItem]
|
|
flattenBlocks (GenBlock "" items) = items
|
|
flattenBlocks other = [other]
|
|
|
|
traverseAsgnsM' :: Monad m => TFStrategy -> MapperM m (LHS, Expr) -> MapperM m ModuleItem
|
|
traverseAsgnsM' strat mapper = moduleItemMapper
|
|
where
|
|
moduleItemMapper item = miMapperA item >>= miMapperB
|
|
|
|
miMapperA (Assign delay lhs expr) = do
|
|
(lhs', expr') <- mapper (lhs, expr)
|
|
return $ Assign delay lhs' expr'
|
|
miMapperA (Defparam lhs expr) = do
|
|
(lhs', expr') <- mapper (lhs, expr)
|
|
return $ Defparam lhs' expr'
|
|
miMapperA other = return other
|
|
|
|
miMapperB = traverseStmtsM' strat stmtMapper
|
|
stmtMapper = traverseStmtAsgnsM mapper
|
|
|
|
traverseAsgns' :: TFStrategy -> Mapper (LHS, Expr) -> Mapper ModuleItem
|
|
traverseAsgns' strat = unmonad $ traverseAsgnsM' strat
|
|
collectAsgnsM' :: Monad m => TFStrategy -> CollectorM m (LHS, Expr) -> CollectorM m ModuleItem
|
|
collectAsgnsM' strat = collectify $ traverseAsgnsM' strat
|
|
|
|
traverseAsgnsM :: Monad m => MapperM m (LHS, Expr) -> MapperM m ModuleItem
|
|
traverseAsgnsM = traverseAsgnsM' IncludeTFs
|
|
traverseAsgns :: Mapper (LHS, Expr) -> Mapper ModuleItem
|
|
traverseAsgns = traverseAsgns' IncludeTFs
|
|
collectAsgnsM :: Monad m => CollectorM m (LHS, Expr) -> CollectorM m ModuleItem
|
|
collectAsgnsM = collectAsgnsM' IncludeTFs
|
|
|
|
traverseStmtAsgnsM :: Monad m => MapperM m (LHS, Expr) -> MapperM m Stmt
|
|
traverseStmtAsgnsM mapper = stmtMapper
|
|
where
|
|
stmtMapper (AsgnBlk op lhs expr) = do
|
|
(lhs', expr') <- mapper (lhs, expr)
|
|
return $ AsgnBlk op lhs' expr'
|
|
stmtMapper (Asgn mt lhs expr) = do
|
|
(lhs', expr') <- mapper (lhs, expr)
|
|
return $ Asgn mt lhs' expr'
|
|
stmtMapper other = return other
|
|
|
|
traverseStmtAsgns :: Mapper (LHS, Expr) -> Mapper Stmt
|
|
traverseStmtAsgns = unmonad traverseStmtAsgnsM
|
|
collectStmtAsgnsM :: Monad m => CollectorM m (LHS, Expr) -> CollectorM m Stmt
|
|
collectStmtAsgnsM = collectify traverseStmtAsgnsM
|
|
|
|
traverseNestedModuleItemsM :: Monad m => MapperM m ModuleItem -> MapperM m ModuleItem
|
|
traverseNestedModuleItemsM mapper item = do
|
|
converted <-
|
|
traverseModuleItemsM mapper (Part [] False Module Nothing "DNE" [] [item])
|
|
let items' = case converted of
|
|
Part [] False Module Nothing "DNE" [] newItems -> newItems
|
|
_ -> error $ "redirected NestedModuleItems traverse failed: "
|
|
++ show converted
|
|
return $ case items' of
|
|
[item'] -> item'
|
|
_ -> Generate $ map GenModuleItem items'
|
|
|
|
traverseNestedModuleItems :: Mapper ModuleItem -> Mapper ModuleItem
|
|
traverseNestedModuleItems = unmonad traverseNestedModuleItemsM
|
|
collectNestedModuleItemsM :: Monad m => CollectorM m ModuleItem -> CollectorM m ModuleItem
|
|
collectNestedModuleItemsM = collectify traverseNestedModuleItemsM
|
|
|
|
traverseNestedStmts :: Mapper Stmt -> Mapper Stmt
|
|
traverseNestedStmts = unmonad traverseNestedStmtsM
|
|
collectNestedStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m Stmt
|
|
collectNestedStmtsM = collectify traverseNestedStmtsM
|
|
|
|
traverseNestedExprs :: Mapper Expr -> Mapper Expr
|
|
traverseNestedExprs = unmonad traverseNestedExprsM
|
|
collectNestedExprsM :: Monad m => CollectorM m Expr -> CollectorM m Expr
|
|
collectNestedExprsM = collectify traverseNestedExprsM
|
|
|
|
-- Traverse all the declaration scopes within a ModuleItem. Note that Functions,
|
|
-- Tasks, Always and Initial blocks are all NOT passed through ModuleItem
|
|
-- mapper, and Decl ModuleItems are NOT passed through the Decl mapper. The
|
|
-- state is restored to its previous value after each scope is exited. Only the
|
|
-- Decl mapper may modify the state, as we maintain the invariant that all other
|
|
-- functions restore the state on exit. The Stmt mapper must not traverse
|
|
-- statements recursively, as we add a recursive wrapper here.
|
|
traverseScopesM
|
|
:: (Eq s, Show s)
|
|
=> Monad m
|
|
=> MapperM (StateT s m) Decl
|
|
-> MapperM (StateT s m) ModuleItem
|
|
-> MapperM (StateT s m) Stmt
|
|
-> MapperM (StateT s m) ModuleItem
|
|
traverseScopesM declMapper moduleItemMapper stmtMapper =
|
|
fullModuleItemMapper
|
|
where
|
|
|
|
nestedStmtMapper stmt =
|
|
stmtMapper stmt >>= traverseSinglyNestedStmtsM fullStmtMapper
|
|
fullStmtMapper (Block kw name decls stmts) = do
|
|
prevState <- get
|
|
decls' <- mapM declMapper decls
|
|
block <- nestedStmtMapper $ Block kw name decls' stmts
|
|
put prevState
|
|
return block
|
|
fullStmtMapper other = nestedStmtMapper other
|
|
|
|
redirectModuleItem (MIPackageItem (Function ml t x decls stmts)) = do
|
|
prevState <- get
|
|
t' <- do
|
|
res <- declMapper $ Variable Local t x [] Nothing
|
|
case res of
|
|
Variable Local newType _ [] Nothing -> return newType
|
|
_ -> error $ "redirected func ret traverse failed: " ++ show res
|
|
decls' <- mapM declMapper decls
|
|
stmts' <- mapM fullStmtMapper stmts
|
|
put prevState
|
|
return $ MIPackageItem $ Function ml t' x decls' stmts'
|
|
redirectModuleItem (MIPackageItem (Task ml x decls stmts)) = do
|
|
prevState <- get
|
|
decls' <- mapM declMapper decls
|
|
stmts' <- mapM fullStmtMapper stmts
|
|
put prevState
|
|
return $ MIPackageItem $ Task ml x decls' stmts'
|
|
redirectModuleItem (AlwaysC kw stmt) =
|
|
fullStmtMapper stmt >>= return . AlwaysC kw
|
|
redirectModuleItem (Initial stmt) =
|
|
fullStmtMapper stmt >>= return . Initial
|
|
redirectModuleItem item =
|
|
moduleItemMapper item
|
|
|
|
-- This previously checked the invariant that the module item mappers
|
|
-- should not modify the state. Now we simply "enforce" it but resetting
|
|
-- the state to its previous value. Comparing the state, as we did
|
|
-- previously, incurs a noticeable performance hit.
|
|
fullModuleItemMapper item = do
|
|
prevState <- get
|
|
item' <- redirectModuleItem item
|
|
put prevState
|
|
return item'
|
|
|
|
-- applies the given decl conversion across the description, and then performs a
|
|
-- scoped traversal for each ModuleItem in the description
|
|
scopedConversion
|
|
:: (Eq s, Show s)
|
|
=> MapperM (State s) Decl
|
|
-> MapperM (State s) ModuleItem
|
|
-> MapperM (State s) Stmt
|
|
-> s
|
|
-> Description
|
|
-> Description
|
|
scopedConversion traverseDeclM traverseModuleItemM traverseStmtM s description =
|
|
runIdentity $ scopedConversionM traverseDeclM traverseModuleItemM traverseStmtM s description
|
|
|
|
scopedConversionM
|
|
:: (Eq s, Show s)
|
|
=> Monad m
|
|
=> MapperM (StateT s m) Decl
|
|
-> MapperM (StateT s m) ModuleItem
|
|
-> MapperM (StateT s m) Stmt
|
|
-> s
|
|
-> Description
|
|
-> m Description
|
|
scopedConversionM traverseDeclM traverseModuleItemM traverseStmtM s description =
|
|
evalStateT (initialTraverse description >>= scopedTraverse) s
|
|
where
|
|
initialTraverse = traverseModuleItemsM traverseMIPackageItemDecl
|
|
scopedTraverse = traverseModuleItemsM $
|
|
traverseScopesM traverseDeclM traverseModuleItemM traverseStmtM
|
|
traverseMIPackageItemDecl (MIPackageItem (Decl decl)) =
|
|
traverseDeclM decl >>= return . MIPackageItem . Decl
|
|
traverseMIPackageItemDecl other = return other
|
|
|
|
-- convert a basic mapper with an initial argument to a stateful mapper
|
|
stately :: (Eq s, Show s) => (s -> Mapper a) -> MapperM (State s) a
|
|
stately mapper thing = do
|
|
s <- get
|
|
return $ mapper s thing
|
|
|
|
-- In many conversions, we want to resolve items locally first, and then fall
|
|
-- back to looking at other source files, if necessary. This helper captures
|
|
-- this behavior, allowing a conversion to fall back to arbitrary global
|
|
-- collected item, if one exists. While this isn't foolproof (we could
|
|
-- inadvertently resolve a name that doesn't exist in the given file), many
|
|
-- projects rely on their toolchain to locate their modules, interfaces,
|
|
-- packages, or typenames in other files. Global resolution of modules and
|
|
-- interfaces is more commonly expected than global resolution of typenames and
|
|
-- packages.
|
|
traverseFilesM
|
|
:: (Monoid w, Monad m)
|
|
=> CollectorM (Writer w) AST
|
|
-> (w -> MapperM m AST)
|
|
-> MapperM m [AST]
|
|
traverseFilesM fileCollectorM fileMapperM files =
|
|
mapM traverseFileM files
|
|
where
|
|
globalNotes = execWriter $ mapM fileCollectorM files
|
|
traverseFileM file =
|
|
fileMapperM notes file
|
|
where
|
|
localNotes = execWriter $ fileCollectorM file
|
|
notes = localNotes <> globalNotes
|
|
traverseFiles
|
|
:: Monoid w
|
|
=> CollectorM (Writer w) AST
|
|
-> (w -> Mapper AST)
|
|
-> Mapper [AST]
|
|
traverseFiles fileCollectorM fileMapper files =
|
|
evalState (traverseFilesM fileCollectorM fileMapperM files) ()
|
|
where fileMapperM = (\w -> return . fileMapper w)
|