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
   9 -- ForSyDe
  10 import qualified ForSyDe.Backend.VHDL.AST as AST
  11
  12 -- GHC API
  13 import CoreSyn
  14 import qualified Name
  15 import qualified OccName
  16 import qualified Var
  17 import qualified Id
  18 import qualified TyCon
  19 import qualified DataCon
  20
  21 -- Local imports
  22 import VHDLTypes
  23 import CoreTools
  24
  25 -- Create an unconditional assignment statement
  26 mkUncondAssign ::
  27   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
  28   -> AST.Expr -- ^ The expression to assign
  29   -> AST.ConcSm -- ^ The resulting concurrent statement
  30 mkUncondAssign dst expr = mkAssign dst Nothing expr
  31
  32 -- Create a conditional assignment statement
  33 mkCondAssign ::
  34   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
  35   -> AST.Expr -- ^ The condition
  36   -> AST.Expr -- ^ The value when true
  37   -> AST.Expr -- ^ The value when false
  38   -> AST.ConcSm -- ^ The resulting concurrent statement
  39 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
  40
  41 -- Create a conditional or unconditional assignment statement
  42 mkAssign ::
  43   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
  44   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
  45                                  -- and the value to assign when true.
  46   AST.Expr -> -- ^ The value to assign when false or no condition
  47   AST.ConcSm -- ^ The resulting concurrent statement
  48 mkAssign dst cond false_expr =
  49   let
  50     -- I'm not 100% how this assignment AST works, but this gets us what we
  51     -- want...
  52     whenelse = case cond of
  53       Just (cond_expr, true_expr) ->
  54         let
  55           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
  56         in
  57           [AST.WhenElse true_wform cond_expr]
  58       Nothing -> []
  59     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
  60     dst_name  = case dst of
  61       Left bndr -> AST.NSimple (bndrToVHDLId bndr)
  62       Right name -> name
  63     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
  64   in
  65     AST.CSSASm assign
  66
  67 -- Create a record field selector that selects the given label from the record
  68 -- stored in the given binder.
  69 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
  70 mkSelectedName bndr label =
  71   let
  72     sel_prefix = AST.NSimple $ bndrToVHDLId bndr
  73     sel_suffix = AST.SSimple $ label
  74   in
  75     AST.NSelected $ sel_prefix AST.:.: sel_suffix
  76
  77 mkAssocElems ::
  78   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
  79   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
  80   -> Entity                     -- | The entity to map against.
  81   -> [AST.AssocElem]            -- | The resulting port maps
  82 mkAssocElems args res entity =
  83     -- Create the actual AssocElems
  84     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
  85   where
  86     -- Turn the ports and signals from a map into a flat list. This works,
  87     -- since the maps must have an identical form by definition. TODO: Check
  88     -- the similar form?
  89     arg_ports = ent_args entity
  90     res_port  = ent_res entity
  91     -- Extract the id part from the (id, type) tuple
  92     ports     = map (Monad.liftM fst) (res_port : arg_ports)
  93     -- Translate signal numbers into names
  94     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
  95
  96 -- | Create an VHDL port -> signal association
  97 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
  98 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
  99 mkAssocElem Nothing _ = Nothing
 100
 101 -- | Create an VHDL port -> signal association
 102 mkAssocElemIndexed :: Maybe AST.VHDLId -> String -> AST.VHDLId -> Maybe AST.AssocElem
 103 mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
 104                       (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index])))
 105 mkAssocElemIndexed Nothing _ _ = Nothing
 106
 107 -- Turn a variable reference into a AST expression
 108 varToVHDLExpr :: Var.Var -> AST.Expr
 109 varToVHDLExpr var =
 110   case Id.isDataConWorkId_maybe var of
 111     Just dc -> dataconToVHDLExpr dc
 112     -- This is a dataconstructor.
 113     -- Not a datacon, just another signal. Perhaps we should check for
 114     -- local/global here as well?
 115     Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var
 116
 117 -- Turn a alternative constructor into an AST expression. For
 118 -- dataconstructors, this is only the constructor itself, not any arguments it
 119 -- has. Should not be called with a DEFAULT constructor.
 120 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 121 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 122
 123 altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
 124 altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
 125
 126 -- Turn a datacon (without arguments!) into a VHDL expression.
 127 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
 128 dataconToVHDLExpr dc = AST.PrimLit lit
 129   where
 130     tycon = DataCon.dataConTyCon dc
 131     tyname = TyCon.tyConName tycon
 132     dcname = DataCon.dataConName dc
 133     lit = case Name.getOccString tyname of
 134       -- TODO: Do something more robust than string matching
 135       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
 136       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 137
 138 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 139 -- simple Var CoreExprs, not complexer ones.
 140 varBndr :: CoreSyn.CoreExpr -> Var.Id
 141 varBndr (CoreSyn.Var id) = id
 142
 143 -- Shortcut for
 144 -- Can only contain alphanumerics and underscores. The supplied string must be
 145 -- a valid basic id, otherwise an error value is returned. This function is
 146 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 147 -- that.
 148 mkVHDLBasicId :: String -> AST.VHDLId
 149 mkVHDLBasicId s =
 150   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 151   where
 152     -- Strip invalid characters.
 153     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 154     -- Strip leading numbers and underscores
 155     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 156     -- Strip multiple adjacent underscores
 157     strip_multiscore = concat . map (\cs ->
 158         case cs of
 159           ('_':_) -> "_"
 160           _ -> cs
 161       ) . List.group
 162
 163 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 164 -- different characters than basic ids, but can never be used to refer to
 165 -- basic ids.
 166 -- Use extended Ids for any values that are taken from the source file.
 167 mkVHDLExtId :: String -> AST.VHDLId
 168 mkVHDLExtId s =
 169   AST.unsafeVHDLExtId $ strip_invalid s
 170   where
 171     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 172     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 173     strip_invalid = filter (`elem` allowed)
 174
 175 -- Creates a VHDL Id from a binder
 176 bndrToVHDLId ::
 177   CoreSyn.CoreBndr
 178   -> AST.VHDLId
 179 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
 180
 181 -- Extracts the binder name as a String
 182 bndrToString ::
 183   CoreSyn.CoreBndr
 184   -> String
 185 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 186
 187 -- Get the string version a Var's unique
 188 varToStringUniq :: Var.Var -> String
 189 varToStringUniq = show . Var.varUnique
 190
 191 -- Extracts the string version of the name
 192 nameToString :: Name.Name -> String
 193 nameToString = OccName.occNameString . Name.nameOccName
 194
 195 recordlabels :: [AST.VHDLId]
 196 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 197
 198 getVectorLen :: CoreSyn.CoreBndr -> Int
 199 getVectorLen bndr = len
 200   where
 201     ty = Var.varType bndr
 202     len = tfvec_len ty
 203
 204 genComponentInst ::
 205   String -- ^ The portmap label
 206   -> AST.VHDLId -- ^ The entity name
 207   -> [AST.AssocElem] -- ^ The port assignments
 208   -> AST.ConcSm
 209 genComponentInst label entity_id portassigns = AST.CSISm compins
 210   where
 211     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portassigns)
 212
 213 -- | The VHDL Bit type
 214 bit_ty :: AST.TypeMark
 215 bit_ty = AST.unsafeVHDLBasicId "Bit"
 216
 217 -- | The VHDL Boolean type
 218 bool_ty :: AST.TypeMark
 219 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 220
 221 -- | The VHDL std_logic
 222 std_logic_ty :: AST.TypeMark
 223 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 224
 225 builtin_types =
 226   Map.fromList [
 227     ("Bit", std_logic_ty),
 228     ("Bool", bool_ty) -- TysWiredIn.boolTy
 229   ]
 230
 231 {-
 232 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 233 --   a VHDLSignalMap
 234 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
 235 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)
 236 -}