diff --git a/src/Convert.hs b/src/Convert.hs index 022169d..1101336 100644 --- a/src/Convert.hs +++ b/src/Convert.hs @@ -15,8 +15,10 @@ import qualified Convert.CaseKW import qualified Convert.Enum import qualified Convert.Logic import qualified Convert.PackedArray +import qualified Convert.Return import qualified Convert.SplitPortDecl import qualified Convert.StarPort +import qualified Convert.Struct import qualified Convert.Typedef import qualified Convert.Unique @@ -28,6 +30,8 @@ phases YOSYS = , Convert.Enum.convert , Convert.PackedArray.convert , Convert.StarPort.convert + , Convert.Struct.convert + , Convert.Return.convert , Convert.Typedef.convert , Convert.Unique.convert ] diff --git a/src/Convert/PackedArray.hs b/src/Convert/PackedArray.hs index c2de32a..c796d79 100644 --- a/src/Convert/PackedArray.hs +++ b/src/Convert/PackedArray.hs @@ -29,7 +29,6 @@ module Convert.PackedArray (convert) where -import Text.Read (readMaybe) import Control.Monad.State import Data.List (partition) import qualified Data.Set as Set @@ -174,7 +173,7 @@ unflattener writeToFlatVariant arr (t, (majorHi, majorLo)) = arrUnflat = prefix arr index = prefix "_tmp_index" (minorHi, minorLo) = head $ snd $ typeRanges t - size = simplify $ BinOp Add (BinOp Sub minorHi minorLo) (Number "1") + size = rangeSize (minorHi, minorLo) localparam :: Identifier -> Expr -> GenItem localparam x v = GenModuleItem $ MIDecl $ Localparam (Implicit []) x v origRange = ( (BinOp Add (Ident startBit) @@ -185,28 +184,6 @@ typeIsImplicit :: Type -> Bool typeIsImplicit (Implicit _) = True typeIsImplicit _ = False --- basic expression simplfication utility to help us generate nicer code in the --- common case of ranges like `[FOO-1:0]` -simplify :: Expr -> Expr -simplify (BinOp op e1 e2) = - case (op, e1', e2') of - (Add, Number "0", e) -> e - (Add, e, Number "0") -> e - (Sub, e, Number "0") -> e - (Add, BinOp Sub e (Number "1"), Number "1") -> e - (Add, e, BinOp Sub (Number "0") (Number "1")) -> BinOp Sub e (Number "1") - (_ , Number a, Number b) -> - case (op, readMaybe a :: Maybe Int, readMaybe b :: Maybe Int) of - (Add, Just x, Just y) -> Number $ show (x + y) - (Sub, Just x, Just y) -> Number $ show (x - y) - (Mul, Just x, Just y) -> Number $ show (x * y) - _ -> BinOp op e1' e2' - _ -> BinOp op e1' e2' - where - e1' = simplify e1 - e2' = simplify e2 -simplify other = other - -- prefix a string with a namespace of sorts prefix :: Identifier -> Identifier prefix ident = "_sv2v_" ++ ident @@ -220,8 +197,8 @@ flattenRanges rs = where (s1, e1) = head rs (s2, e2) = head $ tail rs - size1 = BinOp Add (BinOp Sub s1 e1) (Number "1") - size2 = BinOp Add (BinOp Sub s2 e2) (Number "1") + size1 = rangeSize (s1, e1) + size2 = rangeSize (s2, e2) upper = BinOp Add (BinOp Mul size1 size2) (BinOp Sub e1 (Number "1")) r' = (simplify upper, e1) rs' = (tail $ tail rs) ++ [r'] @@ -254,7 +231,7 @@ rewriteModuleItem info = else Range (Ident i) r where (a, b) = head $ snd $ typeRanges $ fst $ typeDims Map.! i - size = BinOp Add (BinOp Sub a b) (Number "1") + size = rangeSize (a, b) s' = BinOp Sub (BinOp Mul size (BinOp Add s (Number "1"))) (Number "1") e' = BinOp Mul size e r' = (simplify s', simplify e') diff --git a/src/Convert/Return.hs b/src/Convert/Return.hs new file mode 100644 index 0000000..0e94fa8 --- /dev/null +++ b/src/Convert/Return.hs @@ -0,0 +1,22 @@ +{- sv2v + - Author: Zachary Snow + - + - Conversion for `return` + -} + +module Convert.Return (convert) where + +import Convert.Traverse +import Language.SystemVerilog.AST + +convert :: AST -> AST +convert = traverseDescriptions $ traverseModuleItems convertFunction + +convertFunction :: ModuleItem -> ModuleItem +convertFunction (Function ml t f decls stmts) = + Function ml t f decls (map (traverseNestedStmts convertStmt) stmts) + where + convertStmt :: Stmt -> Stmt + convertStmt (Return e) = AsgnBlk (LHSIdent f) e + convertStmt other = other +convertFunction other = other diff --git a/src/Convert/Struct.hs b/src/Convert/Struct.hs new file mode 100644 index 0000000..b76d10a --- /dev/null +++ b/src/Convert/Struct.hs @@ -0,0 +1,231 @@ +{- sv2v + - Author: Zachary Snow + - + - Conversion for `packed struct` + -} + +module Convert.Struct (convert) where + +import Data.Maybe (isJust) +import Data.List (sortOn) +import Data.Tuple (swap) +import Control.Monad.Writer +import qualified Data.Map.Strict as Map + +import Convert.Traverse +import Language.SystemVerilog.AST + +type TypeFunc = [Range] -> Type +type StructInfo = (Type, Map.Map Identifier (Range, Expr)) +type Structs = Map.Map TypeFunc StructInfo +type Types = Map.Map Identifier Type + +convert :: AST -> AST +convert = traverseDescriptions convertDescription + +convertDescription :: Description -> Description +convertDescription description = + traverseModuleItems (traverseTypes $ convertType structs) $ + traverseModuleItems (traverseAsgns $ convertAsgn structs types) $ + description + where + structs = execWriter $ collectModuleItemsM + (collectTypesM collectType) description + typesA = execWriter $ collectModuleItemsM + (collectDeclsM collectDecl) description + typesB = execWriter $ collectModuleItemsM + collectFunction description + types = Map.union typesA typesB + + +-- write down unstructured versions of a packed struct type +collectType :: Type -> Writer Structs () +collectType (Struct True fields _) = do + if canUnstructure + then tell $ Map.singleton + (Struct True fields) + (unstructType, unstructFields) + else return () + where + zero = Number "0" + typeRange :: Type -> Range + typeRange t = + if null ranges then (zero, zero) else head ranges + where ranges = snd $ typeRanges t + + -- extract info about the fields + fieldTypes = map fst fields + fieldRanges = map typeRange fieldTypes + fieldSizes = map rangeSize fieldRanges + + -- layout the fields into the unstructured type; note that `scanr` is + -- used here because SystemVerilog structs are laid out backwards + fieldLos = map simplify $ tail $ scanr (BinOp Add) (Number "0") fieldSizes + fieldHis = map simplify $ init $ scanr (BinOp Add) (Number "-1") fieldSizes + + -- create the mapping structure for the unstructured fields + unstructOffsets = map simplify $ map snd fieldRanges + unstructRanges = zip fieldHis fieldLos + keys = map snd fields + vals = zip unstructRanges unstructOffsets + unstructFields = Map.fromList $ zip keys vals + + -- create the unstructured type + tf = fst $ typeRanges $ head fieldTypes + structSize = foldl1 (BinOp Add) fieldSizes + packedRange = (simplify $ BinOp Sub structSize (Number "1"), zero) + unstructType = tf [packedRange] + + -- TODO: For now, we only convert packed structs which contain fields + -- with all the same base type. We might be able to get away with + -- converting everything to a Logic type. This should work in cases of + -- mixed `wire`/`logic` or `reg`/`logic`. + fieldClasses = map (show . fst . typeRanges) fieldTypes + canUnstructure = all (head fieldClasses ==) fieldClasses + +collectType _ = return () + + +-- convert a struct type to its unstructured equivalent +convertType :: Structs -> Type -> Type +convertType structs t1 = + case Map.lookup tf1 structs of + Nothing -> t1 + Just (t2, _) -> tf2 (rs2 ++ rs1) + where (tf2, rs2) = typeRanges t2 + where (tf1, rs1) = typeRanges t1 + + +-- write down the type a declarations +collectDecl :: Decl -> Writer Types () +collectDecl (Variable _ t x a _) = + -- We add the unpacked dimensions to the type so that our type traversal can + -- correctly match-off the dimensions whenever we see a `Bit` or `Range` + -- expression. + tell $ Map.singleton x (tf $ rs ++ a) + where (tf, rs) = typeRanges t +collectDecl (Parameter t x _) = tell $ Map.singleton x t +collectDecl (Localparam t x _) = tell $ Map.singleton x t + +-- write down the return type of a function +collectFunction :: ModuleItem -> Writer Types () +collectFunction (Function _ t f _ _) = tell $ Map.singleton f t +collectFunction _ = return () + + +convertAsgn :: Structs -> Types -> (LHS, Expr) -> (LHS, Expr) +convertAsgn structs types (lhs, expr) = + (lhs', expr') + where + (typ, lhs') = convertLHS lhs + expr' = snd $ convertSubExpr $ convertExpr typ expr + + -- converting LHSs by looking at the innermost types first + convertLHS :: LHS -> (Type, LHS) + convertLHS (LHSIdent x) = + case Map.lookup x types of + Nothing -> (Implicit [], LHSIdent x) + Just t -> (t, LHSIdent x) + convertLHS (LHSBit l e) = + (tf $ tail rs, LHSBit l' e) + where + (t, l') = convertLHS l + (tf, rs) = typeRanges t + convertLHS (LHSRange l r ) = + (tf rs', LHSRange l' r) + where + (t, l') = convertLHS l + (tf, rs) = typeRanges t + rs' = r : tail rs + convertLHS (LHSDot l x ) = + case t of + InterfaceT _ _ _ -> (Implicit [], l') + Struct _ _ _ -> case Map.lookup structTf structs of + Nothing -> (fieldType, LHSDot l' x) + Just (structT, m) -> (tf [tr], LHSRange l' r) + where + (tf, _) = typeRanges structT + (r @ (hi, lo), base) = m Map.! x + hi' = BinOp Add base $ BinOp Sub hi lo + lo' = base + tr = (simplify hi', simplify lo') + _ -> error $ "convertLHS encountered dot for bad type: " ++ show l + where + (t, l') = convertLHS l + Struct p fields [] = t + structTf = Struct p fields + fieldType = lookupFieldType fields x + convertLHS (LHSConcat lhss) = + (Implicit [], LHSConcat $ map (snd . convertLHS) lhss) + + -- try expression conversion by looking at the *outermost* type first + convertExpr :: Type -> Expr -> Expr + convertExpr (Struct True fields []) (Pattern items) = + if Map.notMember structTf structs + then Pattern items'' + else Concat exprs + where + subMap = \(Just ident, subExpr) -> + (Just ident, convertExpr (lookupFieldType fields ident) subExpr) + structTf = Struct True fields + items' = + -- if the pattern does not use identifiers, use the + -- identifiers from the struct type definition in order + if not (all (isJust . fst) items) + then zip (map (Just. snd) fields) (map snd items) + else items + items'' = map subMap items' + fieldRange = \(Just x, _) -> lookupUnstructRange structTf x + exprs = map snd $ reverse $ sortOn fieldRange items'' + convertExpr _ other = other + + -- try expression conversion by looking at the *innermost* type first + convertSubExpr :: Expr -> (Type, Expr) + convertSubExpr (Ident x) = + case Map.lookup x types of + Nothing -> (Implicit [], Ident x) + Just t -> (t, Ident x) + convertSubExpr (Access e x) = + if Map.notMember structTf structs + then (fieldType, Access e' x) + else (fieldType, Range e' r) + where + (subExprType, e') = convertSubExpr e + Struct p fields [] = subExprType + structTf = Struct p fields + fieldType = lookupFieldType fields x + r = lookupUnstructRange structTf x + convertSubExpr (Range eOuter (rOuter @ (hiO, loO))) = + -- VCS doesn't allow ranges to be cascaded, so we need to combine + -- nested Ranges into a single range. My understanding of the + -- semantics are that a range return a new, zero-indexed sub-range. + case eOuter' of + Range eInner (hiI, loI) -> + (t, Range eInner (simplify hi, simplify lo)) + where + hi = BinOp Add (BinOp Sub hiI loI) hiO + lo = BinOp Add loI loO + _ -> (t, Range eOuter' rOuter) + where (t, eOuter') = convertSubExpr eOuter + convertSubExpr (Concat exprs) = + (Implicit [], Concat $ map (snd . convertSubExpr) exprs) + convertSubExpr (BinOp op e1 e2) = + (Implicit [], BinOp op e1' e2') + where + (_, e1') = convertSubExpr e1 + (_, e2') = convertSubExpr e2 + -- TODO: There are other expression cases that we probably need to + -- recurse into. That said, it's not clear to me how much we really + -- expect to see things like concatenated packed structs, for example. + convertSubExpr other = (Implicit [], other) + + -- lookup the range of a field in its unstructured type + lookupUnstructRange :: TypeFunc -> Identifier -> Range + lookupUnstructRange structTf fieldName = + fieldRangeMap Map.! fieldName + where fieldRangeMap = Map.map fst $ snd $ structs Map.! structTf + + -- lookup the type of a field in the given field list + lookupFieldType :: [(Type, Identifier)] -> Identifier -> Type + lookupFieldType fields fieldName = fieldMap Map.! fieldName + where fieldMap = Map.fromList $ map swap fields diff --git a/src/Convert/Traverse.hs b/src/Convert/Traverse.hs index 257bcd5..9b3db10 100644 --- a/src/Convert/Traverse.hs +++ b/src/Convert/Traverse.hs @@ -36,6 +36,10 @@ module Convert.Traverse , traverseGenItemsM , traverseGenItems , collectGenItemsM +, traverseAsgnsM +, traverseAsgns +, collectAsgnsM +, traverseNestedStmts ) where import Data.Maybe (fromJust) @@ -339,8 +343,25 @@ traverseTypesM :: Monad m => MapperM m Type -> MapperM m ModuleItem traverseTypesM mapper item = miMapper item >>= traverseDeclsM declMapper >>= traverseExprsM exprMapper where + fullMapper t = tm t >>= mapper + tm (Reg r) = return $ Reg r + tm (Wire r) = return $ Wire r + tm (Logic r) = return $ Logic r + tm (Alias x r) = return $ Alias x r + tm (Implicit r) = return $ Implicit r + tm (IntegerT ) = return $ IntegerT + tm (InterfaceT x my r) = return $ InterfaceT x my r + tm (Enum Nothing vals r) = + return $ Enum Nothing vals r + tm (Enum (Just t) vals r) = do + t' <- fullMapper t + return $ Enum (Just t') vals r + tm (Struct p fields r) = do + types <- mapM fullMapper $ map fst fields + let idents = map snd fields + return $ Struct p (zip types idents) r exprMapper (Cast t e) = do - t' <- mapper t + t' <- fullMapper t -- TODO HACK: If the cast type is no longer "simple", we just drop -- the case altogether. This probably doesn't work great in all -- cases. @@ -349,13 +370,13 @@ traverseTypesM mapper item = else Cast t' e exprMapper other = return other declMapper (Parameter t x e) = - mapper t >>= \t' -> return $ Parameter t' x e + fullMapper t >>= \t' -> return $ Parameter t' x e declMapper (Localparam t x e) = - mapper t >>= \t' -> return $ Localparam t' x e + fullMapper t >>= \t' -> return $ Localparam t' x e declMapper (Variable d t x a me) = - mapper t >>= \t' -> return $ Variable d t' x a me + fullMapper t >>= \t' -> return $ Variable d t' x a me miMapper (Function l t x d s) = - mapper t >>= \t' -> return $ Function l t' x d s + fullMapper t >>= \t' -> return $ Function l t' x d s miMapper other = return other traverseTypes :: Mapper Type -> Mapper ModuleItem @@ -398,3 +419,30 @@ traverseNestedGenItemsM mapper = fullMapper gim (GenModuleItem moduleItem) = return $ GenModuleItem moduleItem gim (GenNull) = return GenNull + +traverseAsgnsM :: Monad m => MapperM m (LHS, Expr) -> MapperM m ModuleItem +traverseAsgnsM mapper = moduleItemMapper + where + moduleItemMapper item = miMapperA item >>= miMapperB + + miMapperA (Assign lhs expr) = do + (lhs', expr') <- mapper (lhs, expr) + return $ Assign lhs' expr' + miMapperA other = return other + + miMapperB = traverseStmtsM stmtMapper + stmtMapper (AsgnBlk lhs expr) = do + (lhs', expr') <- mapper (lhs, expr) + return $ AsgnBlk lhs' expr' + stmtMapper (Asgn lhs expr) = do + (lhs', expr') <- mapper (lhs, expr) + return $ Asgn lhs' expr' + stmtMapper other = return other + +traverseAsgns :: Mapper (LHS, Expr) -> Mapper ModuleItem +traverseAsgns = unmonad traverseAsgnsM +collectAsgnsM :: Monad m => CollectorM m (LHS, Expr) -> CollectorM m ModuleItem +collectAsgnsM = collectify traverseAsgnsM + +traverseNestedStmts :: Mapper Stmt -> Mapper Stmt +traverseNestedStmts = unmonad traverseNestedStmtsM diff --git a/src/Language/SystemVerilog/AST.hs b/src/Language/SystemVerilog/AST.hs index c2eaae5..8fffd5e 100644 --- a/src/Language/SystemVerilog/AST.hs +++ b/src/Language/SystemVerilog/AST.hs @@ -26,11 +26,14 @@ module Language.SystemVerilog.AST , Range , GenCase , typeRanges + , simplify + , rangeSize ) where import Data.List import Data.Maybe import Text.Printf +import Text.Read (readMaybe) type Identifier = String @@ -119,10 +122,13 @@ instance Show Type where showItem (t, x) = printf "%s %s;" (show t) x instance Show ([Range] -> Type) where - show tf = show (tf []) + show tf = show (tf []) instance Eq ([Range] -> Type) where - (==) tf1 tf2 = (show $ tf1 []) == (show $ tf2 []) + (==) tf1 tf2 = (tf1 []) == (tf2 []) + +instance Ord ([Range] -> Type) where + compare tf1 tf2 = compare (show tf1) (show tf2) typeRanges :: Type -> ([Range] -> Type, [Range]) typeRanges (Reg r) = (Reg , r) @@ -130,7 +136,7 @@ typeRanges (Wire r) = (Wire , r) typeRanges (Logic r) = (Logic , r) typeRanges (Alias t r) = (Alias t, r) typeRanges (Implicit r) = (Implicit, r) -typeRanges (IntegerT ) = (error "ranges cannot be applied to IntegerT", []) +typeRanges (IntegerT ) = (\[] -> IntegerT, []) typeRanges (Enum t v r) = (Enum t v, r) typeRanges (Struct p l r) = (Struct p l, r) typeRanges (InterfaceT x my r) = (InterfaceT x my, r) @@ -523,3 +529,29 @@ instance Show Lifetime where showLifetime :: Maybe Lifetime -> String showLifetime Nothing = "" showLifetime (Just l) = show l ++ " " + +-- basic expression simplfication utility to help us generate nicer code in the +-- common case of ranges like `[FOO-1:0]` +simplify :: Expr -> Expr +simplify (BinOp op e1 e2) = + case (op, e1', e2') of + (Add, Number "0", e) -> e + (Add, e, Number "0") -> e + (Sub, e, Number "0") -> e + (Add, BinOp Sub e (Number "1"), Number "1") -> e + (Add, e, BinOp Sub (Number "0") (Number "1")) -> BinOp Sub e (Number "1") + (_ , Number a, Number b) -> + case (op, readMaybe a :: Maybe Int, readMaybe b :: Maybe Int) of + (Add, Just x, Just y) -> Number $ show (x + y) + (Sub, Just x, Just y) -> Number $ show (x - y) + (Mul, Just x, Just y) -> Number $ show (x * y) + _ -> BinOp op e1' e2' + _ -> BinOp op e1' e2' + where + e1' = simplify e1 + e2' = simplify e2 +simplify other = other + +rangeSize :: Range -> Expr +rangeSize (s, e) = + simplify $ BinOp Add (BinOp Sub s e) (Number "1") diff --git a/sv2v.cabal b/sv2v.cabal index 4788c9f..556ed7c 100644 --- a/sv2v.cabal +++ b/sv2v.cabal @@ -46,8 +46,10 @@ executable sv2v Convert.Enum Convert.Logic Convert.PackedArray + Convert.Return Convert.SplitPortDecl Convert.StarPort + Convert.Struct Convert.Typedef Convert.Traverse Convert.Unique