diff --git a/src/Convert/HierConst.hs b/src/Convert/HierConst.hs index f48bb72..5683d69 100644 --- a/src/Convert/HierConst.hs +++ b/src/Convert/HierConst.hs @@ -82,10 +82,13 @@ traverseDeclM decl = do scopeExpr :: Expr -> ST Expr scopeExpr expr = do expr' <- traverseSinglyNestedExprsM scopeExpr expr + >>= traverseExprTypesM scopeType details <- lookupElemM expr' case details of Just (accesses, _, _) -> return $ accessesToExpr accesses _ -> return expr' +scopeType :: Type -> ST Type +scopeType = traverseNestedTypesM $ traverseTypeExprsM scopeExpr -- substitute hierarchical references to constants traverseExprM :: Expr -> ST Expr diff --git a/src/Convert/Scoper.hs b/src/Convert/Scoper.hs index 7713ee5..691c787 100644 --- a/src/Convert/Scoper.hs +++ b/src/Convert/Scoper.hs @@ -171,8 +171,11 @@ replaceInType :: Replacements -> Type -> Type replaceInType replacements = if Map.null replacements then id - else traverseNestedTypes $ traverseTypeExprs $ - replaceInExpr' replacements + else replaceInType' replacements + +replaceInType' :: Replacements -> Type -> Type +replaceInType' replacements = + traverseNestedTypes $ traverseTypeExprs $ replaceInExpr' replacements replaceInExpr :: Replacements -> Expr -> Expr replaceInExpr replacements = @@ -184,7 +187,8 @@ replaceInExpr' :: Replacements -> Expr -> Expr replaceInExpr' replacements (Ident x) = Map.findWithDefault (Ident x) x replacements replaceInExpr' replacements other = - traverseSinglyNestedExprs (replaceInExpr replacements) other + traverseExprTypes (replaceInType' replacements) $ + traverseSinglyNestedExprs (replaceInExpr' replacements) other class ScopePath k where toTiers :: Scopes a -> k -> [Tier] diff --git a/src/Convert/Simplify.hs b/src/Convert/Simplify.hs index eb175f3..ff03741 100644 --- a/src/Convert/Simplify.hs +++ b/src/Convert/Simplify.hs @@ -36,7 +36,7 @@ traverseDeclM decl = do case decl' of Param Localparam UnknownType x e -> insertExpr x e - Param Localparam (Implicit Signed [(RawNum 31, RawNum 0)]) x e -> + Param Localparam (Implicit _ [(RawNum 31, RawNum 0)]) x e -> insertExpr x e Param Localparam (Implicit sg rs) x e -> insertExpr x $ Cast (Left t) e @@ -81,6 +81,11 @@ substituteExprM :: Expr -> Scoper Expr Expr substituteExprM = embedScopes substitute convertExpr :: Scopes Expr -> Expr -> Expr +convertExpr info (Cast (Left t) e) = + Cast (Left t') e' + where + t' = traverseNestedTypes (traverseTypeExprs $ substitute info) t + e' = convertExpr info e convertExpr info (Cast (Right c) e) = Cast (Right c') e' where diff --git a/src/Convert/Struct.hs b/src/Convert/Struct.hs index 89981a7..6bd8843 100644 --- a/src/Convert/Struct.hs +++ b/src/Convert/Struct.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} {- sv2v - Author: Zachary Snow - @@ -150,33 +151,29 @@ traverseStmtM' = traverseStmtAsgnsM traverseAsgnM traverseExprM :: Expr -> Scoper Type Expr -traverseExprM = traverseNestedExprsM $ - embedScopes convertSubExpr >=> return . snd +traverseExprM = embedScopes convertSubExpr >=> return . snd traverseLHSM :: LHS -> Scoper Type LHS -traverseLHSM = traverseNestedLHSsM $ convertLHS >=> return . snd +traverseLHSM = convertLHS >=> return . snd -- removes the innermost range from the given type, if possible dropInnerTypeRange :: Type -> Type dropInnerTypeRange t = case typeRanges t of - (_, []) -> unknownType + (_, []) -> UnknownType (tf, rs) -> tf $ tail rs -- produces the type of the given part select, if possible replaceInnerTypeRange :: PartSelectMode -> Range -> Type -> Type replaceInnerTypeRange NonIndexed r t = case typeRanges t of - (_, []) -> unknownType + (_, []) -> UnknownType (tf, rs) -> tf $ r : tail rs replaceInnerTypeRange IndexedPlus r t = replaceInnerTypeRange NonIndexed (snd r, RawNum 1) t replaceInnerTypeRange IndexedMinus r t = replaceInnerTypeRange NonIndexed (snd r, RawNum 1) t -unknownType :: Type -unknownType = Implicit Unspecified [] - traverseAsgnM :: (LHS, Expr) -> Scoper Type (LHS, Expr) traverseAsgnM (lhs, expr) = do -- convert the LHS using the innermost type information @@ -319,9 +316,11 @@ convertExpr _ other = other fallbackType :: Scopes Type -> Expr -> (Type, Expr) fallbackType scopes e = - case lookupElem scopes e of - Nothing -> (unknownType, e) - Just (_, _, t) -> (t, e) + (t, e) + where + t = case lookupElem scopes e of + Nothing -> UnknownType + Just (_, _, typ) -> typ -- converting LHSs by looking at the innermost types first convertLHS :: LHS -> Scoper Type (Type, LHS) @@ -354,65 +353,78 @@ convertSubExpr scopes (Range (Dot e x) NonIndexed rOuter) = if isntStruct subExprType then fallbackType scopes orig' else if structIsntReady subExprType then - (replaceInnerTypeRange NonIndexed rOuter fieldType, orig') + (replaceInnerTypeRange NonIndexed rOuter' fieldType, orig') else - (replaceInnerTypeRange NonIndexed rOuter fieldType, undotted) + (replaceInnerTypeRange NonIndexed rOuter' fieldType, undotted) where + (roLeft, roRight) = rOuter (subExprType, e') = convertSubExpr scopes e - orig' = Range (Dot e' x) NonIndexed rOuter + (_, roLeft') = convertSubExpr scopes roLeft + (_, roRight') = convertSubExpr scopes roRight + rOuter' = (roLeft', roRight') + orig' = Range (Dot e' x) NonIndexed rOuter' (fieldType, bounds, dims) = lookupFieldInfo subExprType x [dim] = dims - rangeLeft = ( BinOp Sub (fst bounds) $ BinOp Sub (fst dim) (fst rOuter) - , BinOp Sub (fst bounds) $ BinOp Sub (fst dim) (snd rOuter) ) - rangeRight =( BinOp Add (snd bounds) $ BinOp Sub (snd dim) (fst rOuter) - , BinOp Add (snd bounds) $ BinOp Sub (snd dim) (snd rOuter) ) + rangeLeft = ( BinOp Sub (fst bounds) $ BinOp Sub (fst dim) roLeft' + , BinOp Sub (fst bounds) $ BinOp Sub (fst dim) roRight' ) + rangeRight =( BinOp Add (snd bounds) $ BinOp Sub (snd dim) roLeft' + , BinOp Add (snd bounds) $ BinOp Sub (snd dim) roRight' ) undotted = Range e' NonIndexed $ endianCondRange dim rangeLeft rangeRight convertSubExpr scopes (Range (Dot e x) mode (baseO, lenO)) = if isntStruct subExprType then fallbackType scopes orig' else if structIsntReady subExprType then - (replaceInnerTypeRange mode (baseO, lenO) fieldType, orig') + (replaceInnerTypeRange mode (baseO', lenO') fieldType, orig') else - (replaceInnerTypeRange mode (baseO, lenO) fieldType, undotted) + (replaceInnerTypeRange mode (baseO', lenO') fieldType, undotted) where (subExprType, e') = convertSubExpr scopes e - orig' = Range (Dot e' x) mode (baseO, lenO) + (_, baseO') = convertSubExpr scopes baseO + (_, lenO') = convertSubExpr scopes lenO + orig' = Range (Dot e' x) mode (baseO', lenO') (fieldType, bounds, dims) = lookupFieldInfo subExprType x [dim] = dims - baseLeft = BinOp Sub (fst bounds) $ BinOp Sub (fst dim) baseO - baseRight = BinOp Add (snd bounds) $ BinOp Sub (snd dim) baseO + baseLeft = BinOp Sub (fst bounds) $ BinOp Sub (fst dim) baseO' + baseRight = BinOp Add (snd bounds) $ BinOp Sub (snd dim) baseO' baseDec = baseLeft baseInc = case mode of - IndexedPlus -> BinOp Add (BinOp Sub baseRight lenO) one - IndexedMinus -> BinOp Sub (BinOp Add baseRight lenO) one + IndexedPlus -> BinOp Add (BinOp Sub baseRight lenO') one + IndexedMinus -> BinOp Sub (BinOp Add baseRight lenO') one NonIndexed -> error "invariant violated" base = endianCondExpr dim baseDec baseInc - undotted = Range e' mode (base, lenO) + undotted = Range e' mode (base, lenO') one = RawNum 1 -convertSubExpr scopes (Range e mode r) = - (replaceInnerTypeRange mode r t, Range e' mode r) - where (t, e') = convertSubExpr scopes e +convertSubExpr scopes (Range e mode (left, right)) = + (replaceInnerTypeRange mode r' t, Range e' mode r') + where + (t, e') = convertSubExpr scopes e + (_, left') = convertSubExpr scopes left + (_, right') = convertSubExpr scopes right + r' = (left', right') convertSubExpr scopes (Bit (Dot e x) i) = if isntStruct subExprType then fallbackType scopes orig' else if structIsntReady subExprType then (dropInnerTypeRange fieldType, orig') else - (dropInnerTypeRange fieldType, Bit e' i') + (dropInnerTypeRange fieldType, Bit e' iFlat) where (subExprType, e') = convertSubExpr scopes e - orig' = Bit (Dot e' x) i + (_, i') = convertSubExpr scopes i + orig' = Bit (Dot e' x) i' (fieldType, bounds, dims) = lookupFieldInfo subExprType x [dim] = dims - iLeft = BinOp Sub (fst bounds) $ BinOp Sub (fst dim) i - iRight = BinOp Add (snd bounds) $ BinOp Sub (snd dim) i - i' = endianCondExpr dim iLeft iRight + left = BinOp Sub (fst bounds) $ BinOp Sub (fst dim) i' + right = BinOp Add (snd bounds) $ BinOp Sub (snd dim) i' + iFlat = endianCondExpr dim left right convertSubExpr scopes (Bit e i) = - if t == unknownType - then fallbackType scopes $ Bit e' i - else (dropInnerTypeRange t, Bit e' i) - where (t, e') = convertSubExpr scopes e + if t == UnknownType + then fallbackType scopes $ Bit e' i' + else (dropInnerTypeRange t, Bit e' i') + where + (t, e') = convertSubExpr scopes e + (_, i') = convertSubExpr scopes i convertSubExpr scopes (Call e args) = (retType, Call e args') where @@ -423,8 +435,8 @@ convertSubExpr scopes (Cast (Left t) e) = where (_, e') = convertSubExpr scopes e convertSubExpr scopes (Pattern items) = if all (== "") $ map fst items' - then (unknownType, Concat $ map snd items') - else (unknownType, Pattern items') + then (UnknownType, Concat $ map snd items') + else (UnknownType, Pattern items') where items' = map mapItem items mapItem (x, e) = (x, e') @@ -435,8 +447,15 @@ convertSubExpr scopes (Mux a b c) = (_, a') = convertSubExpr scopes a (t, b') = convertSubExpr scopes b (_, c') = convertSubExpr scopes c -convertSubExpr scopes other = - fallbackType scopes other +convertSubExpr scopes (Ident x) = + fallbackType scopes (Ident x) +convertSubExpr scopes e = + (UnknownType, ) $ + traverseExprTypes typeMapper $ + traverseSinglyNestedExprs exprMapper e + where + exprMapper = snd . convertSubExpr scopes + typeMapper = traverseNestedTypes $ traverseTypeExprs exprMapper -- get the fields and type function of a struct or union getFields :: Type -> Maybe [Field] @@ -478,6 +497,6 @@ convertCall scopes fn (Args pnArgs kwArgs) = (x, e') where details = lookupElem scopes $ LHSDot lhs x - typ = maybe unknownType thd3 details + typ = maybe UnknownType thd3 details thd3 (_, _, c) = c (_, e') = convertSubExpr scopes $ convertExpr typ e diff --git a/src/Convert/Traverse.hs b/src/Convert/Traverse.hs index 541848c..41b2e27 100644 --- a/src/Convert/Traverse.hs +++ b/src/Convert/Traverse.hs @@ -402,9 +402,7 @@ collectNestedExprsM = collectify traverseNestedExprsM traverseSinglyNestedExprsM :: Monad m => MapperM m Expr -> MapperM m Expr traverseSinglyNestedExprsM exprMapper = em where - typeMapper = traverseNestedTypesM (traverseTypeExprsM exprMapper) - typeOrExprMapper (Left t) = - typeMapper t >>= return . Left + typeOrExprMapper (Left t) = return $ Left t typeOrExprMapper (Right e) = exprMapper e >>= return . Right exprOrRangeMapper (Left e) = diff --git a/src/Convert/TypeOf.hs b/src/Convert/TypeOf.hs index a73b38f..305b748 100644 --- a/src/Convert/TypeOf.hs +++ b/src/Convert/TypeOf.hs @@ -71,7 +71,7 @@ traverseDeclM decl = do -- rewrite and store a non-genvar data declaration's type information insertType :: Identifier -> Type -> ST () insertType ident typ = do - typ' <- traverseNestedTypesM (traverseTypeExprsM scopeExpr) typ + typ' <- scopeType typ insertElem ident (typ', False) -- rewrite an expression so that any identifiers it contains unambiguously refer @@ -79,10 +79,13 @@ insertType ident typ = do scopeExpr :: Expr -> ST Expr scopeExpr expr = do expr' <- traverseSinglyNestedExprsM scopeExpr expr + >>= traverseExprTypesM scopeType details <- lookupElemM expr' case details of Just (accesses, _, (_, False)) -> return $ accessesToExpr accesses _ -> return expr' +scopeType :: Type -> ST Type +scopeType = traverseNestedTypesM $ traverseTypeExprsM scopeExpr -- convert TypeOf in a ModuleItem traverseModuleItemM :: ModuleItem -> ST ModuleItem @@ -135,8 +138,8 @@ traverseExprM (Cast (Right size) expr) = do size' <- traverseExprM size elaborateSizeCast size' expr' traverseExprM other = - traverseExprTypesM traverseTypeM other - >>= traverseSinglyNestedExprsM traverseExprM + traverseSinglyNestedExprsM traverseExprM other + >>= traverseExprTypesM traverseTypeM -- carry forward the signedness of the expression when cast to the given size elaborateSizeCast :: Expr -> Expr -> ST Expr @@ -151,8 +154,8 @@ traverseTypeM :: Type -> ST Type traverseTypeM (TypeOf expr) = traverseExprM expr >>= typeof traverseTypeM other = - traverseTypeExprsM traverseExprM other - >>= traverseSinglyNestedTypesM traverseTypeM + traverseSinglyNestedTypesM traverseTypeM other + >>= traverseTypeExprsM traverseExprM -- attempts to find the given (potentially hierarchical or generate-scoped) -- expression in the available scope information diff --git a/src/Convert/UnbasedUnsized.hs b/src/Convert/UnbasedUnsized.hs index 790a3cc..b38e44e 100644 --- a/src/Convert/UnbasedUnsized.hs +++ b/src/Convert/UnbasedUnsized.hs @@ -124,7 +124,11 @@ substituteExpr mapping (Ident x) = Nothing -> Ident x Just expr -> substituteExpr mapping expr substituteExpr mapping expr = - traverseSinglyNestedExprs (substituteExpr mapping) expr + traverseExprTypes typeMapper $ + traverseSinglyNestedExprs exprMapper expr + where + exprMapper = substituteExpr mapping + typeMapper = traverseNestedTypes $ traverseTypeExprs exprMapper tagExpr :: Expr -> Expr tagExpr (Ident x) = Ident (':' : x) @@ -254,7 +258,7 @@ pattern UU ch = Number (UnbasedUnsized ch) convertType :: Type -> Type convertType (TypeOf e) = TypeOf $ convertExpr SelfDetermined e -convertType other = other +convertType other = traverseTypeExprs (convertExpr SelfDetermined) other isParentSizedBinOp :: BinOp -> Bool isParentSizedBinOp BitAnd = True