VHDLTools.hs

   1 module VHDLTools where
   2
   3 -- Standard modules
   4 import qualified Maybe
   5 import qualified Data.List as List
   6 import qualified Data.Map as Map
   7 import qualified Control.Monad as Monad
   8 import qualified Control.Arrow as Arrow
   9 import qualified Data.Monoid as Monoid
  10 import Data.Accessor
  11
  12 -- ForSyDe
  13 import qualified ForSyDe.Backend.VHDL.AST as AST
  14
  15 -- GHC API
  16 import CoreSyn
  17 import qualified Name
  18 import qualified OccName
  19 import qualified Var
  20 import qualified Id
  21 import qualified TyCon
  22 import qualified Type
  23 import qualified DataCon
  24 import qualified CoreSubst
  25
  26 -- Local imports
  27 import VHDLTypes
  28 import CoreTools
  29 import Pretty
  30 import Constants
  31
  32 -----------------------------------------------------------------------------
  33 -- Functions to generate concurrent statements
  34 -----------------------------------------------------------------------------
  35
  36 -- Create an unconditional assignment statement
  37 mkUncondAssign ::
  38   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
  39   -> AST.Expr -- ^ The expression to assign
  40   -> AST.ConcSm -- ^ The resulting concurrent statement
  41 mkUncondAssign dst expr = mkAssign dst Nothing expr
  42
  43 -- Create a conditional assignment statement
  44 mkCondAssign ::
  45   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
  46   -> AST.Expr -- ^ The condition
  47   -> AST.Expr -- ^ The value when true
  48   -> AST.Expr -- ^ The value when false
  49   -> AST.ConcSm -- ^ The resulting concurrent statement
  50 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
  51
  52 -- Create a conditional or unconditional assignment statement
  53 mkAssign ::
  54   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
  55   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
  56                                  -- and the value to assign when true.
  57   AST.Expr -> -- ^ The value to assign when false or no condition
  58   AST.ConcSm -- ^ The resulting concurrent statement
  59 mkAssign dst cond false_expr =
  60   let
  61     -- I'm not 100% how this assignment AST works, but this gets us what we
  62     -- want...
  63     whenelse = case cond of
  64       Just (cond_expr, true_expr) ->
  65         let
  66           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
  67         in
  68           [AST.WhenElse true_wform cond_expr]
  69       Nothing -> []
  70     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
  71     dst_name  = case dst of
  72       Left bndr -> AST.NSimple (varToVHDLId bndr)
  73       Right name -> name
  74     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
  75   in
  76     AST.CSSASm assign
  77
  78 mkAssocElems ::
  79   [AST.Expr]                    -- | The argument that are applied to function
  80   -> AST.VHDLName               -- | The binder in which to store the result
  81   -> Entity                     -- | The entity to map against.
  82   -> [AST.AssocElem]            -- | The resulting port maps
  83 mkAssocElems args res entity =
  84     -- Create the actual AssocElems
  85     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
  86   where
  87     -- Turn the ports and signals from a map into a flat list. This works,
  88     -- since the maps must have an identical form by definition. TODO: Check
  89     -- the similar form?
  90     arg_ports = ent_args entity
  91     res_port  = ent_res entity
  92     -- Extract the id part from the (id, type) tuple
  93     ports     = map (Monad.liftM fst) (res_port : arg_ports)
  94     -- Translate signal numbers into names
  95     sigs      = (vhdlNameToVHDLExpr res : args)
  96
  97 -- | Create an VHDL port -> signal association
  98 mkAssocElem :: Maybe AST.VHDLId -> AST.Expr -> Maybe AST.AssocElem
  99 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADExpr signal)
 100 mkAssocElem Nothing _ = Nothing
 101
 102 -- | Create an VHDL port -> signal association
 103 mkAssocElemIndexed :: Maybe AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> Maybe AST.AssocElem
 104 mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
 105                       (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
 106 mkAssocElemIndexed Nothing _ _ = Nothing
 107
 108 mkComponentInst ::
 109   String -- ^ The portmap label
 110   -> AST.VHDLId -- ^ The entity name
 111   -> [AST.AssocElem] -- ^ The port assignments
 112   -> AST.ConcSm
 113 mkComponentInst label entity_id portassigns = AST.CSISm compins
 114   where
 115     -- We always have a clock port, so no need to map it anywhere but here
 116     clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
 117     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
 118
 119 -----------------------------------------------------------------------------
 120 -- Functions to generate VHDL Exprs
 121 -----------------------------------------------------------------------------
 122
 123 -- Turn a variable reference into a AST expression
 124 varToVHDLExpr :: Var.Var -> AST.Expr
 125 varToVHDLExpr var =
 126   case Id.isDataConWorkId_maybe var of
 127     Just dc -> dataconToVHDLExpr dc
 128     -- This is a dataconstructor.
 129     -- Not a datacon, just another signal. Perhaps we should check for
 130     -- local/global here as well?
 131     Nothing -> AST.PrimName $ AST.NSimple $ varToVHDLId var
 132
 133 -- Turn a VHDLName into an AST expression
 134 vhdlNameToVHDLExpr = AST.PrimName
 135
 136 -- Turn a VHDL Id into an AST expression
 137 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 138
 139 -- Turn a Core expression into an AST expression
 140 exprToVHDLExpr = varToVHDLExpr . exprToVar
 141
 142 -- Turn a alternative constructor into an AST expression. For
 143 -- dataconstructors, this is only the constructor itself, not any arguments it
 144 -- has. Should not be called with a DEFAULT constructor.
 145 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 146 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 147
 148 altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
 149 altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
 150
 151 -- Turn a datacon (without arguments!) into a VHDL expression.
 152 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
 153 dataconToVHDLExpr dc = AST.PrimLit lit
 154   where
 155     tycon = DataCon.dataConTyCon dc
 156     tyname = TyCon.tyConName tycon
 157     dcname = DataCon.dataConName dc
 158     lit = case Name.getOccString tyname of
 159       -- TODO: Do something more robust than string matching
 160       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 161       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 162
 163 -----------------------------------------------------------------------------
 164 -- Functions dealing with names, variables and ids
 165 -----------------------------------------------------------------------------
 166
 167 -- Creates a VHDL Id from a binder
 168 varToVHDLId ::
 169   CoreSyn.CoreBndr
 170   -> AST.VHDLId
 171 varToVHDLId = mkVHDLExtId . varToString
 172
 173 -- Creates a VHDL Name from a binder
 174 varToVHDLName ::
 175   CoreSyn.CoreBndr
 176   -> AST.VHDLName
 177 varToVHDLName = AST.NSimple . varToVHDLId
 178
 179 -- Extracts the binder name as a String
 180 varToString ::
 181   CoreSyn.CoreBndr
 182   -> String
 183 varToString = OccName.occNameString . Name.nameOccName . Var.varName
 184
 185 -- Get the string version a Var's unique
 186 varToStringUniq :: Var.Var -> String
 187 varToStringUniq = show . Var.varUnique
 188
 189 -- Extracts the string version of the name
 190 nameToString :: Name.Name -> String
 191 nameToString = OccName.occNameString . Name.nameOccName
 192
 193 -- Shortcut for Basic VHDL Ids.
 194 -- Can only contain alphanumerics and underscores. The supplied string must be
 195 -- a valid basic id, otherwise an error value is returned. This function is
 196 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 197 -- that.
 198 mkVHDLBasicId :: String -> AST.VHDLId
 199 mkVHDLBasicId s =
 200   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 201   where
 202     -- Strip invalid characters.
 203     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 204     -- Strip leading numbers and underscores
 205     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 206     -- Strip multiple adjacent underscores
 207     strip_multiscore = concat . map (\cs ->
 208         case cs of
 209           ('_':_) -> "_"
 210           _ -> cs
 211       ) . List.group
 212
 213 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 214 -- different characters than basic ids, but can never be used to refer to
 215 -- basic ids.
 216 -- Use extended Ids for any values that are taken from the source file.
 217 mkVHDLExtId :: String -> AST.VHDLId
 218 mkVHDLExtId s =
 219   AST.unsafeVHDLExtId $ strip_invalid s
 220   where
 221     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 222     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 223     strip_invalid = filter (`elem` allowed)
 224
 225 -- Create a record field selector that selects the given label from the record
 226 -- stored in the given binder.
 227 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
 228 mkSelectedName name label =
 229    AST.NSelected $ name AST.:.: (AST.SSimple label)
 230
 231 -- Create an indexed name that selects a given element from a vector.
 232 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
 233 -- Special case for already indexed names. Just add an index
 234 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
 235  AST.NIndexed (AST.IndexedName name (indexes++[index]))
 236 -- General case for other names
 237 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 238
 239 -----------------------------------------------------------------------------
 240 -- Functions dealing with VHDL types
 241 -----------------------------------------------------------------------------
 242
 243 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
 244 -- for a few builtin types.
 245 builtin_types =
 246   Map.fromList [
 247     ("Bit", std_logicTM),
 248     ("Bool", booleanTM) -- TysWiredIn.boolTy
 249   ]
 250
 251 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 252 vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
 253 vhdl_ty ty = do
 254   typemap <- getA vsTypes
 255   let builtin_ty = do -- See if this is a tycon and lookup its name
 256         (tycon, args) <- Type.splitTyConApp_maybe ty
 257         let name = Name.getOccString (TyCon.tyConName tycon)
 258         Map.lookup name builtin_types
 259   -- If not a builtin type, try the custom types
 260   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 261   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 262     -- Found a type, return it
 263     Just t -> return t
 264     -- No type yet, try to construct it
 265     Nothing -> do
 266       newty_maybe <- (construct_vhdl_ty ty)
 267       case newty_maybe of
 268         Just (ty_id, ty_def) -> do
 269           -- TODO: Check name uniqueness
 270           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
 271           return ty_id
 272         Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
 273
 274 -- Construct a new VHDL type for the given Haskell type.
 275 construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 276 construct_vhdl_ty ty = do
 277   case Type.splitTyConApp_maybe ty of
 278     Just (tycon, args) -> do
 279       let name = Name.getOccString (TyCon.tyConName tycon)
 280       case name of
 281         "TFVec" -> do
 282           res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
 283           return $ Just $ (Arrow.second Right) res
 284         -- "SizedWord" -> do
 285         --   res <- mk_vector_ty (sized_word_len ty) ty
 286         --   return $ Just $ (Arrow.second Left) res
 287         "RangedWord" -> do
 288           res <- mk_natural_ty 0 (ranged_word_bound ty)
 289           return $ Just $ (Arrow.second Right) res
 290         -- Create a custom type from this tycon
 291         otherwise -> mk_tycon_ty tycon args
 292     Nothing -> return $ Nothing
 293
 294 -- | Create VHDL type for a custom tycon
 295 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 296 mk_tycon_ty tycon args =
 297   case TyCon.tyConDataCons tycon of
 298     -- Not an algebraic type
 299     [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
 300     [dc] -> do
 301       let arg_tys = DataCon.dataConRepArgTys dc
 302       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 303       -- violation? Or does it only mean not to apply it again to the same
 304       -- subject?
 305       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 306       elem_tys <- mapM vhdl_ty real_arg_tys
 307       let elems = zipWith AST.ElementDec recordlabels elem_tys
 308       -- For a single construct datatype, build a record with one field for
 309       -- each argument.
 310       -- TODO: Add argument type ids to this, to ensure uniqueness
 311       -- TODO: Special handling for tuples?
 312       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
 313       let ty_def = AST.TDR $ AST.RecordTypeDef elems
 314       return $ Just (ty_id, Left ty_def)
 315     dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
 316   where
 317     -- Create a subst that instantiates all types passed to the tycon
 318     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 319     -- to work so far, though..
 320     tyvars = TyCon.tyConTyVars tycon
 321     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 322     -- Generate a bunch of labels for fields of a record
 323     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 324
 325 -- | Create a VHDL vector type
 326 mk_vector_ty ::
 327   Int -- ^ The length of the vector
 328   -> Type.Type -- ^ The Haskell element type of the Vector
 329   -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 330
 331 mk_vector_ty len el_ty = do
 332   elem_types_map <- getA vsElemTypes
 333   el_ty_tm <- vhdl_ty el_ty
 334   let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 335   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 336   let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
 337   case existing_elem_ty of
 338     Just t -> do
 339       let ty_def = AST.SubtypeIn t (Just range)
 340       return (ty_id, ty_def)
 341     Nothing -> do
 342       let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 343       let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
 344       modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
 345       --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
 346       let ty_def = AST.SubtypeIn vec_id (Just range)
 347       return (ty_id, ty_def)
 348
 349 mk_natural_ty ::
 350   Int -- ^ The minimum bound (> 0)
 351   -> Int -- ^ The maximum bound (> minimum bound)
 352   -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 353 mk_natural_ty min_bound max_bound = do
 354   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 355   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
 356   let ty_def = AST.SubtypeIn naturalTM (Just range)
 357   return (ty_id, ty_def)
 358
 359 -- Finds the field labels for VHDL type generated for the given Core type,
 360 -- which must result in a record type.
 361 getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
 362 getFieldLabels ty = do
 363   -- Ensure that the type is generated (but throw away it's VHDLId)
 364   vhdl_ty ty
 365   -- Get the types map, lookup and unpack the VHDL TypeDef
 366   types <- getA vsTypes
 367   case Map.lookup (OrdType ty) types of
 368     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 369     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)