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