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