mirror of https://github.com/zachjs/sv2v.git
completed preliminary interface conversion
This commit is contained in:
Zachary Snow
parent
ccd0bf879a
commit
15d85b461b
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
module Convert.Interface (convert) where
|
||||
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Maybe (isJust, mapMaybe)
|
||||
import Control.Monad.Writer
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
|
|
@ -33,36 +33,54 @@ convert descriptions =
|
|||
isInterface (Part Interface _ _ _) = True
|
||||
isInterface _ = False
|
||||
|
||||
-- TODO FIXME XXX: We should probably extract out/flatten the needless generate
|
||||
-- blocks we make during covnersion...
|
||||
|
||||
convertDescription :: Interfaces -> Description -> Description
|
||||
convertDescription interfaces (orig @ (Part Module name _ _)) =
|
||||
convertDescription interfaces (Part Module name ports items) =
|
||||
Part Module name ports' items'
|
||||
where
|
||||
Part Module _ ports items = traverseModuleItems mapInstance orig
|
||||
ports' = ports
|
||||
items' = items
|
||||
items' =
|
||||
map (traverseNestedModuleItems $ traverseExprs convertExpr) $
|
||||
map (traverseNestedModuleItems $ traverseLHSs convertLHS) $
|
||||
map (traverseNestedModuleItems mapInterface) $
|
||||
items
|
||||
ports' = concatMap convertPort ports
|
||||
|
||||
-- collect the interface type of all interface instances in this module
|
||||
instances = execWriter $ collectModuleItemsM collectInstance orig
|
||||
collectInstance :: ModuleItem -> Writer Instances ()
|
||||
collectInstance (Instance part _ ident _) =
|
||||
(instances, modports) = execWriter $ mapM
|
||||
(collectNestedModuleItemsM collectInterface) items
|
||||
collectInterface :: ModuleItem -> Writer (Instances, Modports) ()
|
||||
collectInterface (MIDecl (Variable Local t ident _ _)) =
|
||||
case t of
|
||||
InterfaceT interfaceName (Just modportName) [] ->
|
||||
tell (Map.empty, Map.singleton ident modportDecls)
|
||||
where modportDecls = lookupModport Nothing interfaceName modportName
|
||||
_ -> return ()
|
||||
collectInterface (Instance part _ ident _) =
|
||||
if Map.member part interfaces
|
||||
then tell $ Map.singleton ident part
|
||||
then tell (Map.singleton ident part, Map.empty)
|
||||
else return ()
|
||||
collectInstance _ = return ()
|
||||
collectInterface _ = return ()
|
||||
|
||||
-- TODO: We don't yet handle interfaces with parameter bindings.
|
||||
mapInstance :: ModuleItem -> ModuleItem
|
||||
mapInstance (Instance part params ident (Just instancePorts)) =
|
||||
mapInterface :: ModuleItem -> ModuleItem
|
||||
mapInterface (orig @ (MIDecl (Variable Local t ident _ _))) =
|
||||
case Map.lookup ident modports of
|
||||
Just modportDecls -> Generate $
|
||||
map (GenModuleItem . MIDecl . mapper) modportDecls
|
||||
Nothing -> orig
|
||||
where
|
||||
InterfaceT interfaceName (Just _) [] = t
|
||||
interfaceItems = snd $ interfaces Map.! interfaceName
|
||||
mapper = \(dir, port, Just expr) ->
|
||||
Variable dir (lookupType interfaceItems expr)
|
||||
(ident ++ "_" ++ port) [] Nothing
|
||||
mapInterface (Instance part params ident (Just instancePorts)) =
|
||||
case Map.lookup part interfaces of
|
||||
Just interface ->
|
||||
Generate $ map GenModuleItem $
|
||||
inlineInterface interface (ident, expandedPorts)
|
||||
Nothing -> Instance part params ident (Just expandedPorts)
|
||||
where expandedPorts = concatMap expandPortBinding instancePorts
|
||||
mapInstance other = other
|
||||
mapInterface other = other
|
||||
|
||||
expandPortBinding :: PortBinding -> [PortBinding]
|
||||
expandPortBinding (origBinding @ (portName, Just (Access (Ident instanceName) modportName))) =
|
||||
|
|
@ -71,23 +89,42 @@ convertDescription interfaces (orig @ (Part Module name _ _)) =
|
|||
Just interfaceName ->
|
||||
map mapper modportDecls
|
||||
where
|
||||
modportDecls = lookupModport instanceName interfaceName modportName
|
||||
modportDecls = lookupModport (Just instanceName) interfaceName modportName
|
||||
mapper (_, x, me) = (portName ++ "_" ++ x, me)
|
||||
expandPortBinding other = [other]
|
||||
|
||||
lookupModport :: Identifier -> Identifier -> Identifier -> [ModportDecl]
|
||||
lookupModport :: Maybe Identifier -> Identifier -> Identifier -> [ModportDecl]
|
||||
lookupModport instanceName interfaceName = (Map.!) modportMap
|
||||
where
|
||||
prefix = maybe "" (++ "_") instanceName
|
||||
interfaceItems =
|
||||
map (prefixModuleItems $ instanceName ++ "_") $
|
||||
map (prefixModuleItems prefix) $
|
||||
snd $ interfaces Map.! interfaceName
|
||||
modportMap = execWriter $
|
||||
mapM (collectNestedModuleItemsM collectModport) $
|
||||
interfaceItems
|
||||
collectModport :: ModuleItem -> Writer Modports ()
|
||||
collectModport (Modport x l) = tell $ Map.singleton x l
|
||||
collectModport (Modport ident l) = tell $ Map.singleton ident l
|
||||
collectModport _ = return ()
|
||||
|
||||
convertExpr :: Expr -> Expr
|
||||
convertExpr (orig @ (Access (Ident x) y)) =
|
||||
if Map.member x modports
|
||||
then Ident (x ++ "_" ++ y)
|
||||
else orig
|
||||
convertExpr other = other
|
||||
convertLHS :: LHS -> LHS
|
||||
convertLHS (orig @ (LHSDot (LHSIdent x) y)) =
|
||||
if Map.member x modports
|
||||
then LHSIdent (x ++ "_" ++ y)
|
||||
else orig
|
||||
convertLHS other = other
|
||||
convertPort :: Identifier -> [Identifier]
|
||||
convertPort ident =
|
||||
case Map.lookup ident modports of
|
||||
Nothing -> [ident]
|
||||
Just decls -> map (\(_, x, _) -> ident ++ "_" ++ x) decls
|
||||
|
||||
convertDescription _ other = other
|
||||
|
||||
|
||||
|
|
@ -109,6 +146,18 @@ prefixModuleItems prefix =
|
|||
prefixLHS (LHSIdent x) = LHSIdent (prefix ++ x)
|
||||
prefixLHS other = other
|
||||
|
||||
-- TODO: this is an incomplete attempt at looking up the type of an expression;
|
||||
-- there is definitely some overlap here with the Struct conversion
|
||||
lookupType :: [ModuleItem] -> Expr -> Type
|
||||
lookupType items (Ident ident) =
|
||||
head $ mapMaybe findType items
|
||||
where
|
||||
findType :: ModuleItem -> Maybe Type
|
||||
findType (MIDecl (Variable _ t x [] Nothing)) =
|
||||
if x == ident then Just t else Nothing
|
||||
findType _ = Nothing
|
||||
lookupType _ expr = error $ "lookupType on fancy expr: " ++ show expr
|
||||
|
||||
-- convert an interface instantiation into a series of equivalent module items
|
||||
inlineInterface :: Interface -> (Identifier, [PortBinding]) -> [ModuleItem]
|
||||
inlineInterface (ports, items) (instanceName, instancePorts) =
|
||||
|
|
|
|||
|
|
@ -107,7 +107,9 @@ hoistPortDecls (Part kw name ports items) =
|
|||
where
|
||||
explode :: ModuleItem -> [ModuleItem]
|
||||
explode (Generate genItems) =
|
||||
portDecls ++ [Generate rest]
|
||||
if null rest
|
||||
then portDecls
|
||||
else portDecls ++ [Generate rest]
|
||||
where
|
||||
(wrappedPortDecls, rest) = partition isPortDecl genItems
|
||||
portDecls = map (\(GenModuleItem item) -> item) wrappedPortDecls
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ convertAsgn structs types (lhs, expr) =
|
|||
hi' = BinOp Add base $ BinOp Sub hi lo
|
||||
lo' = base
|
||||
tr = (simplify hi', simplify lo')
|
||||
_ -> error $ "convertLHS encountered dot for bad type: " ++ show l
|
||||
_ -> error $ "convertLHS encountered dot for bad type: " ++ show (t, l, x)
|
||||
where
|
||||
(t, l') = convertLHS l
|
||||
Struct p fields [] = t
|
||||
|
|
|
|||
|
|
@ -147,9 +147,20 @@ traverseStmtLHSsM :: Monad m => MapperM m LHS -> MapperM m Stmt
|
|||
traverseStmtLHSsM mapper = traverseNestedStmtsM stmtMapper
|
||||
where
|
||||
fullMapper = traverseNestedLHSsM mapper
|
||||
stmtMapper (Timing (Event sense) stmt) = do
|
||||
sense' <- senseMapper sense
|
||||
return $ Timing (Event sense') stmt
|
||||
stmtMapper (AsgnBlk lhs expr) = fullMapper lhs >>= \lhs' -> return $ AsgnBlk lhs' expr
|
||||
stmtMapper (Asgn lhs expr) = fullMapper lhs >>= \lhs' -> return $ Asgn lhs' expr
|
||||
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
|
||||
|
||||
traverseStmtLHSs :: Mapper LHS -> Mapper Stmt
|
||||
traverseStmtLHSs = unmonad traverseStmtLHSsM
|
||||
|
|
|
|||
Loading…
Reference in New Issue