preliminary struct conversion; return conversion

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
     ]

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')

src/Convert/Return.hs

+{- sv2v
+ - Author: Zachary Snow <zach@zachjs.com>
+ -
+ - 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

src/Convert/Struct.hs

+{- sv2v
+ - Author: Zachary Snow <zach@zachjs.com>
+ -
+ - 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

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

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")

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