{- sv2v - Author: Zachary Snow - - Conversion for `parameter type` in module instantiations -} module Convert.ParamType (convert) where import Control.Monad.Writer import Data.Either (isLeft) import Data.Maybe (isJust, isNothing, fromJust) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Convert.Traverse import Language.SystemVerilog.AST type MaybeTypeMap = Map.Map Identifier (Maybe Type) type Info = Map.Map Identifier ([Identifier], MaybeTypeMap) type Instance = Map.Map Identifier Type type Instances = Set.Set (Identifier, Instance) type IdentSet = Set.Set Identifier type UsageMap = [(Identifier, Set.Set Identifier)] convert :: [AST] -> [AST] convert files = files''' where info = execWriter $ mapM (collectDescriptionsM collectDescriptionM) files (files', instancesRaw) = runWriter $ mapM (mapM $ traverseModuleItemsM $ convertModuleItemM info) files instances = Set.toList instancesRaw -- add type parameter instantiations files'' = map (concatMap explodeDescription) files' explodeDescription :: Description -> [Description] explodeDescription (part @ (Part _ _ _ _ name _ _)) = if null theseInstances then [part] else (:) part $ filter (not . alreadyExists) $ filter isNonDefault $ map (rewriteModule part) theseInstances where theseInstances = map snd $ filter ((== name) . fst) instances isNonDefault = (name /=) . moduleName alreadyExists = (flip Map.member info) . moduleName moduleName :: Description -> Identifier moduleName (Part _ _ _ _ x _ _) = x moduleName _ = error "not possible" explodeDescription other = [other] -- remove or rewrite source modules that are no longer needed files''' = map (\a -> concatMap (replaceDefault a) a) files'' (usageMapRaw, usedTypedModulesRaw) = execWriter $ mapM (mapM collectUsageInfoM) files'' usageMap = Map.unionsWith Set.union $ map (uncurry Map.singleton) usageMapRaw usedTypedModules = Map.unionsWith Set.union $ map (uncurry Map.singleton) usedTypedModulesRaw collectUsageInfoM :: Description -> Writer (UsageMap, UsageMap) () collectUsageInfoM (part @ (Part _ _ _ _ name _ _)) = tell (makeList used, makeList usedTyped) where makeList s = zip (Set.toList s) (repeat $ Set.singleton name) (usedUntyped, usedTyped) = execWriter $ (collectModuleItemsM collectModuleItemM) part used = Set.union usedUntyped usedTyped collectUsageInfoM _ = return () collectModuleItemM :: ModuleItem -> Writer (IdentSet, IdentSet) () collectModuleItemM (Instance m bindings _ _ _) = do case Map.lookup m info of Nothing -> tell (Set.singleton m, Set.empty) Just (_, maybeTypeMap) -> if any (flip Map.member maybeTypeMap) $ map fst bindings then tell (Set.empty, Set.singleton m) else tell (Set.singleton m, Set.empty) collectModuleItemM _ = return () replaceDefault :: [Description] -> Description -> [Description] replaceDefault existing (part @ (Part _ _ _ _ name _ _)) = if Map.notMember name info then [part] else if Map.null maybeTypeMap then [part] else if Map.member name usedTypedModules && isUsed name then [part] else if all isNothing maybeTypeMap then [] else filter (not . alreadyExists) $ (:) (removeDefaultTypeParams part) $ if isNothing typeMap then [] else [rewriteModule part $ fromJust typeMap] where maybeTypeMap = snd $ info Map.! name typeMap = defaultInstance maybeTypeMap existingNames = map maybeModuleName existing alreadyExists = (flip elem existingNames) . maybeModuleName maybeModuleName :: Description -> Maybe Identifier maybeModuleName (Part _ _ _ _ x _ _) = Just x maybeModuleName _ = Nothing replaceDefault _ other = [other] removeDefaultTypeParams :: Description -> Description removeDefaultTypeParams (part @ Part{}) = Part attrs extern kw ml (moduleDefaultName name) p items where Part attrs extern kw ml name p items = traverseModuleItems (traverseDecls rewriteDecl) part rewriteDecl :: Decl -> Decl rewriteDecl (ParamType Parameter x _) = ParamType Parameter x Nothing rewriteDecl other = other removeDefaultTypeParams _ = error "not possible" isUsed :: Identifier -> Bool isUsed name = any (flip Map.notMember usedTypedModules) used where used = usageSet $ expandSet name expandSet :: Identifier -> IdentSet expandSet ident = case ( Map.lookup ident usedTypedModules , Map.lookup name usageMap) of (Just x, _) -> x (Nothing, Just x) -> x _ -> Set.empty usageSet :: IdentSet -> IdentSet usageSet names = if names' == names then names else usageSet names' where names' = Set.union names $ Set.unions $ Set.map expandSet names -- substitute in a particular instance's parameter types rewriteModule :: Description -> Instance -> Description rewriteModule part typeMap = Part attrs extern kw ml m' p items' where Part attrs extern kw ml m p items = part m' = moduleInstanceName m typeMap items' = map rewriteDecl items rewriteDecl :: ModuleItem -> ModuleItem rewriteDecl (MIPackageItem (Decl (ParamType Parameter x _))) = MIPackageItem $ Typedef (typeMap Map.! x) x rewriteDecl other = other -- TODO FIXME: Typedef conversion must be made to handle -- ParamTypes! -----items' = map (traverseDecls rewriteDecl) items -----rewriteDecl :: Decl -> Decl -----rewriteDecl (ParamType Parameter x _) = ----- ParamType Localparam x (Just $ typeMap Map.! x) -----rewriteDecl other = other -- write down module parameter names and type parameters collectDescriptionM :: Description -> Writer Info () collectDescriptionM (part @ (Part _ _ _ _ name _ _)) = tell $ Map.singleton name (paramNames, maybeTypeMap) where params = execWriter $ collectModuleItemsM (collectDeclsM collectDeclM) part paramNames = map fst params maybeTypeMap = Map.fromList $ map (\(x, y) -> (x, fromJust y)) $ filter (isJust . snd) params collectDeclM :: Decl -> Writer [(Identifier, Maybe (Maybe Type))] () collectDeclM (Param Parameter _ x _) = tell [(x, Nothing)] collectDeclM (ParamType Parameter x v) = tell [(x, Just v )] collectDeclM _ = return () collectDescriptionM _ = return () -- produces the default type mapping of a module, if there is one defaultInstance :: MaybeTypeMap -> Maybe Instance defaultInstance maybeTypeMap = if any isNothing maybeTypeMap then Nothing else Just $ Map.map fromJust maybeTypeMap -- generate a "unique" name for a particular module type instance moduleInstanceName :: Identifier -> Instance -> Identifier moduleInstanceName m inst = m ++ "_" ++ shortHash (m, inst) -- name for the module without any default type parameters moduleDefaultName :: Identifier -> Identifier moduleDefaultName m = m ++ defaultTag isDefaultName :: Identifier -> Bool isDefaultName m = defaultTag == (reverse $ (take $ length defaultTag) $ reverse m) defaultTag :: Identifier defaultTag = "_sv2v_default" -- attempt to convert an expression to syntactically equivalent type exprToType :: Expr -> Maybe Type exprToType (Ident x) = Just $ Alias Nothing x [] exprToType (PSIdent x y) = Just $ Alias (Just x) y [] exprToType (Range e NonIndexed r) = case exprToType e of Nothing -> Nothing Just t -> Just $ tf (rs ++ [r]) where (tf, rs) = typeRanges t exprToType (Bit e i) = case exprToType e of Nothing -> Nothing Just t -> Just $ tf (rs ++ [r]) where (tf, rs) = typeRanges t r = (simplify $ BinOp Sub i (Number "1"), Number "0") exprToType _ = Nothing -- checks where a type is sufficiently resolved to be substituted -- TODO: If a type parameter contains an expression, that expression should be -- substituted into the new module, or created as a new parameter. isSimpleType :: Type -> Bool isSimpleType (IntegerVector _ _ _) = True isSimpleType (IntegerAtom _ _ ) = True isSimpleType (NonInteger _ ) = True isSimpleType (Net _ _ _) = True isSimpleType (Struct _ fields _) = all (isSimpleType . fst) fields isSimpleType (Union _ fields _) = all (isSimpleType . fst) fields isSimpleType _ = False -- attempt to rewrite instantiations with type parameters convertModuleItemM :: Info -> ModuleItem -> Writer Instances ModuleItem convertModuleItemM info (orig @ (Instance m bindings x r p)) = if Map.notMember m info then return orig else if Map.null maybeTypeMap then return orig else if any (isLeft . snd) bindings' then error $ "param type resolution left type params: " ++ show orig ++ " converted to: " ++ show bindings' else if any (not . isSimpleType) resolvedTypes then do let defaults = Map.map Left resolvedTypes let bindingsDefaulted = Map.toList $ Map.union bindingsMap defaults if isDefaultName m || bindingsDefaulted == Map.toList bindingsMap then return $ Instance m bindingsNamed x r p else return $ Instance (moduleDefaultName m) bindingsDefaulted x r p else do tell $ Set.singleton (m, resolvedTypes) let m' = moduleInstanceName m resolvedTypes return $ Instance m' bindings' x r p where (paramNames, maybeTypeMap) = info Map.! m -- attach names to unnamed parameters bindingsNamed = if all (== "") (map fst bindings) then zip paramNames (map snd bindings) else if any (== "") (map fst bindings) then error $ "instance has a mix of named and unnamed params: " ++ show orig else bindings -- determine the types corresponding to each type parameter bindingsMap = Map.fromList bindingsNamed resolvedTypes = Map.mapWithKey resolveType maybeTypeMap resolveType :: Identifier -> Maybe Type -> Type resolveType paramName defaultType = case (Map.lookup paramName bindingsMap, defaultType) of (Nothing, Just t) -> t (Nothing, Nothing) -> error $ "instantiation " ++ show orig ++ " is missing a type parameter: " ++ paramName (Just (Left t), _) -> t (Just (Right e), _) -> -- Some types are parsed as expressions because of the -- ambiguities of defined type names. case exprToType e of Just t -> t Nothing -> error $ "instantiation " ++ show orig ++ " has expr " ++ show e ++ " for type param: " ++ paramName -- leave only the normal expression params behind isParamType = flip Map.member maybeTypeMap bindings' = filter (not . isParamType . fst) bindingsNamed convertModuleItemM _ other = return other