mirror of https://github.com/zachjs/sv2v.git
336 lines
14 KiB
Haskell
336 lines
14 KiB
Haskell
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{- sv2v
|
|
- Author: Zachary Snow <zach@zachjs.com>
|
|
-
|
|
- Conversion for `parameter type` in module instantiations
|
|
-}
|
|
|
|
module Convert.ParamType (convert) where
|
|
|
|
import Control.Monad.Writer.Strict
|
|
import Data.Either (isRight, lefts)
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import Convert.Traverse
|
|
import Language.SystemVerilog.AST
|
|
|
|
type TypeMap = Map.Map Identifier Type
|
|
type Modules = Map.Map Identifier TypeMap
|
|
|
|
type Instance = Map.Map Identifier (Type, IdentSet)
|
|
type Instances = Set.Set (Identifier, Instance)
|
|
|
|
type IdentSet = Set.Set Identifier
|
|
type UsageMap = [(Identifier, Set.Set Identifier)]
|
|
|
|
convert :: [AST] -> [AST]
|
|
convert files =
|
|
files'''
|
|
where
|
|
modules = execWriter $
|
|
mapM (collectDescriptionsM collectDescriptionM) files
|
|
(files', instancesRaw) =
|
|
runWriter $ mapM (mapM convertDescriptionM) files
|
|
instances = Set.toList instancesRaw
|
|
|
|
-- add type parameter instantiations
|
|
files'' = map (concatMap explodeDescription) files'
|
|
explodeDescription :: Description -> [Description]
|
|
explodeDescription (part @ (Part _ _ _ _ name _ _)) =
|
|
(part :) $
|
|
filter (not . alreadyExists) $
|
|
map (rewriteModule part) theseInstances
|
|
where
|
|
theseInstances = map snd $ filter ((== name) . fst) instances
|
|
alreadyExists = flip Map.member modules . moduleName
|
|
moduleName :: Description -> Identifier
|
|
moduleName = \(Part _ _ _ _ x _ _) -> x
|
|
explodeDescription other = [other]
|
|
|
|
-- remove or reduce source modules that are no longer needed
|
|
files''' = map (map reduceTypeDefaults . filter keepDescription) files''
|
|
-- produce a typed and untyped instantiation graph
|
|
(usedUntypedModules, usedTypedModules) =
|
|
both (Map.fromListWith Set.union) $
|
|
execWriter $ mapM (mapM collectUsageM) files''
|
|
collectUsageM :: Description -> Writer (UsageMap, UsageMap) ()
|
|
collectUsageM (part @ (Part _ _ _ _ name _ _)) =
|
|
tell $ both makeList $ execWriter $
|
|
(collectModuleItemsM collectModuleItemM) part
|
|
where makeList s = zip (Set.toList s) (repeat $ Set.singleton name)
|
|
collectUsageM _ = return ()
|
|
collectModuleItemM :: ModuleItem -> Writer (IdentSet, IdentSet) ()
|
|
collectModuleItemM (Instance m bindings _ _ _) =
|
|
if all (isRight . snd) bindings
|
|
then tell (Set.singleton m, Set.empty)
|
|
else tell (Set.empty, Set.singleton m)
|
|
collectModuleItemM _ = return ()
|
|
both f (x, y) = (f x, f y) -- simple tuple map helper
|
|
|
|
-- identify if a module is still in use
|
|
keepDescription :: Description -> Bool
|
|
keepDescription (Part _ _ _ _ name _ _) =
|
|
isNewModule
|
|
|| isntTyped
|
|
|| isUsedAsUntyped
|
|
|| isUsedAsTyped && isInstantiatedViaNonTyped
|
|
|| allTypesHaveDefaults && notInstantiated
|
|
where
|
|
maybeTypeMap = Map.lookup name modules
|
|
Just typeMap = maybeTypeMap
|
|
isNewModule = maybeTypeMap == Nothing
|
|
isntTyped = Map.null typeMap
|
|
isUsedAsTyped = Map.member name usedTypedModules
|
|
isUsedAsUntyped = Map.member name usedUntypedModules
|
|
isInstantiatedViaNonTyped = untypedUsageSearch $ Set.singleton name
|
|
allTypesHaveDefaults = all (/= UnknownType) (Map.elems typeMap)
|
|
notInstantiated = lookup name instances == Nothing
|
|
keepDescription _ = True
|
|
|
|
-- instantiate the type parameters if this is a used default instance
|
|
reduceTypeDefaults :: Description -> Description
|
|
reduceTypeDefaults (part @ (Part _ _ _ _ name _ _)) =
|
|
if shouldntReduce
|
|
then part
|
|
else traverseModuleItems (traverseDecls rewriteDecl) part
|
|
where
|
|
shouldntReduce =
|
|
Map.notMember name modules || Map.null typeMap ||
|
|
isTemplateTagged name
|
|
typeMap = modules Map.! name
|
|
rewriteDecl :: Decl -> Decl
|
|
rewriteDecl (ParamType Parameter x t) =
|
|
ParamType Localparam x t
|
|
rewriteDecl other = other
|
|
reduceTypeDefaults other = other
|
|
|
|
-- modules can be recursive; this checks if a typed module is not
|
|
-- connected to any modules which are themselves used as typed modules
|
|
untypedUsageSearch :: IdentSet -> Bool
|
|
untypedUsageSearch visited =
|
|
any (flip Map.notMember usedTypedModules) visited
|
|
|| Set.size visited /= Set.size visited'
|
|
&& untypedUsageSearch visited'
|
|
where
|
|
visited' =
|
|
Set.union visited $
|
|
Set.unions $
|
|
Set.map expandSet visited
|
|
expandSet :: Identifier -> IdentSet
|
|
expandSet ident =
|
|
Map.findWithDefault Set.empty ident usedTypedModules
|
|
|
|
-- substitute in a particular instance's parameter types
|
|
rewriteModule :: Description -> Instance -> Description
|
|
rewriteModule part inst =
|
|
Part attrs extern kw ml m' p (additionalParamItems ++ items')
|
|
where
|
|
Part attrs extern kw ml m p items = part
|
|
m' = moduleInstanceName m inst
|
|
items' = map rewriteModuleItem items
|
|
rewriteModuleItem = traverseNestedModuleItems $ traverseNodes
|
|
rewriteExpr rewriteDecl rewriteType rewriteLHS rewriteStmt
|
|
rewriteDecl :: Decl -> Decl
|
|
rewriteDecl (ParamType Parameter x t) =
|
|
ParamType kind x $ rewriteType $
|
|
case Map.lookup x inst of
|
|
Nothing -> t
|
|
Just (t', _) -> t'
|
|
where kind = if Map.null inst
|
|
then Parameter
|
|
else Localparam
|
|
rewriteDecl other =
|
|
traverseDeclTypes rewriteType $
|
|
traverseDeclExprs rewriteExpr other
|
|
additionalParamItems = concatMap makeAddedParams $
|
|
Map.toList $ Map.map snd inst
|
|
rewriteExpr :: Expr -> Expr
|
|
rewriteExpr (orig @ (Dot (Ident x) y)) =
|
|
if x == m
|
|
then Dot (Ident m') y
|
|
else orig
|
|
rewriteExpr other =
|
|
traverseExprTypes rewriteType $
|
|
traverseSinglyNestedExprs rewriteExpr other
|
|
rewriteLHS :: LHS -> LHS
|
|
rewriteLHS (orig @ (LHSDot (LHSIdent x) y)) =
|
|
if x == m
|
|
then LHSDot (LHSIdent m') y
|
|
else orig
|
|
rewriteLHS other =
|
|
traverseLHSExprs rewriteExpr $
|
|
traverseSinglyNestedLHSs rewriteLHS other
|
|
rewriteType :: Type -> Type
|
|
rewriteType =
|
|
traverseTypeExprs rewriteExpr .
|
|
traverseSinglyNestedTypes rewriteType
|
|
rewriteStmt :: Stmt -> Stmt
|
|
rewriteStmt =
|
|
traverseStmtLHSs rewriteLHS .
|
|
traverseStmtExprs rewriteExpr .
|
|
traverseSinglyNestedStmts rewriteStmt
|
|
|
|
makeAddedParams :: (Identifier, IdentSet) -> [ModuleItem]
|
|
makeAddedParams (paramName, identSet) =
|
|
map (MIPackageItem . Decl) $
|
|
map toTypeParam idents ++ map toParam idents
|
|
where
|
|
idents = Set.toList identSet
|
|
toParam :: Identifier -> Decl
|
|
toParam ident =
|
|
Param Parameter typ name (RawNum 0)
|
|
where
|
|
typ = Alias (addedParamTypeName paramName ident) []
|
|
name = addedParamName paramName ident
|
|
toTypeParam :: Identifier -> Decl
|
|
toTypeParam ident = ParamType Parameter name UnknownType
|
|
where name = addedParamTypeName paramName ident
|
|
|
|
-- write down module parameter names and type parameters
|
|
collectDescriptionM :: Description -> Writer Modules ()
|
|
collectDescriptionM (part @ (Part _ _ _ _ name _ _)) =
|
|
tell $ Map.singleton name typeMap
|
|
where
|
|
typeMap = Map.fromList $ execWriter $
|
|
collectModuleItemsM (collectDeclsM collectDeclM) part
|
|
collectDeclM :: Decl -> Writer [(Identifier, Type)] ()
|
|
collectDeclM (ParamType Parameter x v) = tell [(x, v)]
|
|
collectDeclM _ = return ()
|
|
collectDescriptionM _ = return ()
|
|
|
|
-- generate a "unique" name for a particular module type instance
|
|
moduleInstanceName :: Identifier -> Instance -> Identifier
|
|
moduleInstanceName (TemplateTag m) inst =
|
|
moduleInstanceName m inst
|
|
moduleInstanceName m inst =
|
|
if Map.null inst
|
|
then TemplateTag m
|
|
else m ++ "_" ++ shortHash (m, inst)
|
|
|
|
-- used to tag modules created for delayed type parameter instantiation
|
|
pattern TemplateTag :: Identifier -> Identifier
|
|
pattern TemplateTag x = '~' : x
|
|
isTemplateTagged :: Identifier -> Bool
|
|
isTemplateTagged TemplateTag{} = True
|
|
isTemplateTagged _ = False
|
|
|
|
-- checks where a type is sufficiently resolved to be substituted
|
|
isSimpleType :: Type -> Bool
|
|
isSimpleType typ =
|
|
(not $ typeIsUnresolved typ) &&
|
|
case typ of
|
|
IntegerVector{} -> True
|
|
IntegerAtom {} -> True
|
|
NonInteger {} -> True
|
|
Net {} -> True
|
|
Implicit {} -> True
|
|
Struct _ fields _ -> all (isSimpleType . fst) fields
|
|
Union _ fields _ -> all (isSimpleType . fst) fields
|
|
_ -> False
|
|
|
|
-- returns whether a top-level type contains any dimension queries or
|
|
-- hierarchical references
|
|
typeIsUnresolved :: Type -> Bool
|
|
typeIsUnresolved =
|
|
getAny . execWriter . collectTypeExprsM
|
|
(collectNestedExprsM collectUnresolvedExprM)
|
|
where
|
|
collectUnresolvedExprM :: Expr -> Writer Any ()
|
|
collectUnresolvedExprM DimsFn {} = tell $ Any True
|
|
collectUnresolvedExprM DimFn {} = tell $ Any True
|
|
collectUnresolvedExprM Dot {} = tell $ Any True
|
|
collectUnresolvedExprM _ = return ()
|
|
|
|
prepareTypeExprs :: Identifier -> Identifier -> Type -> (Type, (IdentSet, [Decl]))
|
|
prepareTypeExprs instanceName paramName =
|
|
runWriter . traverseNestedTypesM
|
|
(traverseTypeExprsM $ traverseNestedExprsM prepareExpr)
|
|
where
|
|
prepareExpr :: Expr -> Writer (IdentSet, [Decl]) Expr
|
|
prepareExpr (e @ Call{}) = do
|
|
tell (Set.empty, [decl])
|
|
prepareExpr $ Ident x
|
|
where
|
|
decl = Param Localparam (TypeOf e) x e
|
|
x = instanceName ++ "_sv2v_pfunc_" ++ shortHash e
|
|
prepareExpr (Ident x) = do
|
|
tell (Set.singleton x, [])
|
|
return $ Ident $ paramName ++ '_' : x
|
|
prepareExpr other = return other
|
|
|
|
addedParamName :: Identifier -> Identifier -> Identifier
|
|
addedParamName paramName var = paramName ++ '_' : var
|
|
|
|
addedParamTypeName :: Identifier -> Identifier -> Identifier
|
|
addedParamTypeName paramName var = paramName ++ '_' : var ++ "_type"
|
|
|
|
convertDescriptionM :: Description -> Writer Instances Description
|
|
convertDescriptionM (Part attrs extern kw liftetime name ports items) =
|
|
mapM convertModuleItemM items >>=
|
|
return . Part attrs extern kw liftetime name ports
|
|
convertDescriptionM other = return other
|
|
|
|
convertGenItemM :: GenItem -> Writer Instances GenItem
|
|
convertGenItemM (GenModuleItem item) =
|
|
convertModuleItemM item >>= return . GenModuleItem
|
|
convertGenItemM other =
|
|
traverseSinglyNestedGenItemsM convertGenItemM other
|
|
|
|
-- attempt to rewrite instantiations with type parameters
|
|
convertModuleItemM :: ModuleItem -> Writer Instances ModuleItem
|
|
convertModuleItemM (orig @ (Instance m bindings x r p)) =
|
|
if hasOnlyExprs then
|
|
return orig
|
|
else if not hasUnresolvedTypes then do
|
|
tell $ Set.singleton (m, resolvedTypes)
|
|
let m' = moduleInstanceName m resolvedTypes
|
|
return $ Generate $ map GenModuleItem $
|
|
map (MIPackageItem . Decl) addedDecls ++
|
|
[Instance m' (additionalBindings ++ exprBindings) x r p]
|
|
else if isTemplateTagged m then
|
|
return orig
|
|
else do
|
|
let m' = TemplateTag m
|
|
tell $ Set.singleton (m, Map.empty)
|
|
return $ Instance m' bindings x r p
|
|
where
|
|
hasOnlyExprs = all (isRight . snd) bindings
|
|
hasUnresolvedTypes = any (not . isSimpleType) (lefts $ map snd bindings)
|
|
|
|
-- determine the types corresponding to each type parameter
|
|
bindingsMap = Map.fromList bindings
|
|
resolvedTypesWithDecls = Map.mapMaybeWithKey resolveType bindingsMap
|
|
resolvedTypes = Map.map (\(a, (b, _)) -> (a, b)) resolvedTypesWithDecls
|
|
addedDecls = concatMap (snd . snd . snd) $
|
|
Map.toList resolvedTypesWithDecls
|
|
resolveType :: Identifier -> TypeOrExpr -> Maybe (Type, (IdentSet, [Decl]))
|
|
resolveType _ Right{} = Nothing
|
|
resolveType paramName (Left t) =
|
|
Just $ prepareTypeExprs x paramName t
|
|
|
|
-- leave only the normal expression params behind
|
|
exprBindings = filter (isRight . snd) bindings
|
|
|
|
-- create additional parameters needed to specify existing type params
|
|
additionalBindings = concatMap makeAddedParams $
|
|
Map.toList $ Map.map snd resolvedTypes
|
|
makeAddedParams :: (Identifier, IdentSet) -> [ParamBinding]
|
|
makeAddedParams (paramName, identSet) =
|
|
map toTypeParam idents ++ map toParam idents
|
|
where
|
|
idents = Set.toList identSet
|
|
toParam :: Identifier -> ParamBinding
|
|
toParam ident =
|
|
(addedParamName paramName ident, Right $ Ident ident)
|
|
toTypeParam :: Identifier -> ParamBinding
|
|
toTypeParam ident =
|
|
(addedParamTypeName paramName ident, Left $ TypeOf $ Ident ident)
|
|
|
|
convertModuleItemM (Generate items) =
|
|
mapM convertGenItemM items >>= return . Generate
|
|
convertModuleItemM (MIAttr attr item) =
|
|
convertModuleItemM item >>= return . MIAttr attr
|
|
convertModuleItemM other = return other
|