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