ParamType.hs 11.8 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
{- sv2v
 - Author: Zachary Snow <zach@zachjs.com>
 -
 - Conversion for `parameter type` in module instantiations
 -}

module Convert.ParamType (convert) where

import Control.Monad.Writer
import Data.Either (isLeft)
11
import Data.List.Unique (complex)
12 13
import Data.Maybe (isJust, isNothing, fromJust)
import qualified Data.Map.Strict as Map
14
import qualified Data.Set as Set
15 16 17 18 19 20 21 22 23 24

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 = [(Identifier, Instance)]

25 26 27
type IdentSet = Set.Set Identifier
type UsageMap = [(Identifier, Set.Set Identifier)]

28 29
convert :: [AST] -> [AST]
convert files =
30
    files'''
31 32 33 34
    where
        info = execWriter $
            mapM (collectDescriptionsM collectDescriptionM) files
        (files', instancesRaw) = runWriter $ mapM
35
            (mapM $ traverseModuleItemsM $ convertModuleItemM info) files
36 37
        instances = uniq instancesRaw
        uniq l = l' where (l', _, _) = complex l
38

39 40
        -- add type parameter instantiations
        files'' = map (concatMap explodeDescription) files'
41
        explodeDescription :: Description -> [Description]
42
        explodeDescription (part @ (Part _ _ _ _ name _ _)) =
43 44 45 46 47 48 49 50 51 52 53 54
            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
55
                moduleName (Part _ _ _ _ x _ _) = x
56
                moduleName _ = error "not possible"
57 58
        explodeDescription other = [other]

59
        -- remove or rewrite source modules that are no longer needed
60
        files''' = map (uniq . concatMap replaceDefault) files''
61 62 63 64 65 66 67
        (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) ()
68
        collectUsageInfoM (part @ (Part _ _ _ _ name _ _)) =
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
            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]
86
        replaceDefault (part @ (Part _ _ _ _ name _ _)) =
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
            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
                (:) (removeDefaultTypeParams part) $
                if isNothing typeMap
                    then []
                    else [rewriteModule part $ fromJust typeMap]
            where
                maybeTypeMap = snd $ info Map.! name
                typeMap = defaultInstance maybeTypeMap
        replaceDefault other = [other]

        removeDefaultTypeParams :: Description -> Description
106 107
        removeDefaultTypeParams (part @ Part{}) =
            Part attrs extern kw ml (moduleDefaultName name) p items
108
            where
109
                Part attrs extern kw ml name p items =
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
                    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
138

139
        -- substitute in a particular instance's parameter types
140 141
        rewriteModule :: Description -> Instance -> Description
        rewriteModule part typeMap =
142
            Part attrs extern kw ml m' p items'
143
            where
144
                Part attrs extern kw ml m p items = part
145
                m' = moduleInstanceName m typeMap
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
                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 ()
161
collectDescriptionM (part @ (Part _ _ _ _ name _ _)) =
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
    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
184 185
moduleInstanceName :: Identifier -> Instance -> Identifier
moduleInstanceName m inst = m ++ "_" ++ shortHash (m, inst)
186

187 188 189 190 191 192 193 194
-- 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"
195

196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
-- 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
221
isSimpleType (Net           _ _ _) = True
222 223 224 225 226
isSimpleType _ = False

-- attempt to rewrite instantiations with type parameters
convertModuleItemM :: Info -> ModuleItem -> Writer Instances ModuleItem
convertModuleItemM info (orig @ (Instance m bindings x r p)) =
227 228
    if Map.notMember m info then
        return orig
229 230
    else if Map.null maybeTypeMap then
        return $ Instance m bindingsNamed x r p
231 232 233
    else if any (isLeft . snd) bindings' then
        error $ "param type resolution left type params: " ++ show orig
            ++ " converted to: " ++ show bindings'
234 235 236 237 238 239
    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
            then return $ Instance m bindingsNamed x r p
            else return $ Instance (moduleDefaultName m) bindingsDefaulted x r p
240 241
    else do
        tell [(m, resolvedTypes)]
242
        let m' = moduleInstanceName m resolvedTypes
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
        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), _) ->
266 267 268 269 270 271 272 273 274
                    -- 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

275 276 277
        -- leave only the normal expression params behind
        isParamType = flip Map.member maybeTypeMap
        bindings' = filter (not . isParamType . fst) bindingsNamed
278
convertModuleItemM _ other = return other