mirror of https://github.com/zachjs/sv2v.git
expression traversals no longer visit types by default
This commit is contained in:
Zachary Snow
parent
de27065dba
commit
642803a707
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE TupleSections #-}
|
||||
{- sv2v
|
||||
- Author: Zachary Snow <zach@zachjs.com>
|
||||
-
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue