VHDLTools.hs

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