VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module VHDL where
   5
   6 -- Standard modules
   7 import qualified Data.List as List
   8 import qualified Data.Map as Map
   9 import qualified Maybe
  10 import qualified Control.Monad as Monad
  11 import qualified Control.Arrow as Arrow
  12 import qualified Control.Monad.Trans.State as State
  13 import qualified Data.Monoid as Monoid
  14 import Data.Accessor
  15
  16 -- ForSyDe
  17 import qualified ForSyDe.Backend.VHDL.AST as AST
  18
  19 -- GHC API
  20 import CoreSyn
  21 import qualified Type
  22 import qualified Name
  23 import qualified Var
  24 import qualified Id
  25 import qualified IdInfo
  26 import qualified TyCon
  27 import qualified DataCon
  28 import qualified CoreSubst
  29 import qualified CoreUtils
  30 import Outputable ( showSDoc, ppr )
  31
  32 -- Local imports
  33 import VHDLTypes
  34 import VHDLTools
  35 import Pretty
  36 import CoreTools
  37 import Constants
  38 import Generate
  39 import GlobalNameTable
  40
  41 createDesignFiles ::
  42   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  43   -> [(AST.VHDLId, AST.DesignFile)]
  44
  45 createDesignFiles binds =
  46   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
  47   map (Arrow.second $ AST.DesignFile full_context) units
  48
  49   where
  50     init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
  51     (units, final_session) =
  52       State.runState (createLibraryUnits binds) init_session
  53     tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
  54     ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
  55     vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
  56     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
  57     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
  58     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
  59     ieee_context = [
  60         AST.Library $ mkVHDLBasicId "IEEE",
  61         mkUseAll ["IEEE", "std_logic_1164"],
  62         mkUseAll ["IEEE", "numeric_std"]
  63       ]
  64     full_context =
  65       mkUseAll ["work", "types"]
  66       : (mkUseAll ["work"]
  67       : ieee_context)
  68     type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
  69     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
  70     subProgSpecs = concat (map subProgSpec tyfun_decls)
  71     subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
  72     mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
  73     mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
  74     mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
  75
  76 -- Create a use foo.bar.all statement. Takes a list of components in the used
  77 -- name. Must contain at least two components
  78 mkUseAll :: [String] -> AST.ContextItem
  79 mkUseAll ss =
  80   AST.Use $ from AST.:.: AST.All
  81   where
  82     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  83     from = foldl select base_prefix (tail ss)
  84     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  85
  86 createLibraryUnits ::
  87   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  88   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
  89
  90 createLibraryUnits binds = do
  91   entities <- Monad.mapM createEntity binds
  92   archs <- Monad.mapM createArchitecture binds
  93   return $ zipWith
  94     (\ent arch ->
  95       let AST.EntityDec id _ = ent in
  96       (id, [AST.LUEntity ent, AST.LUArch arch])
  97     )
  98     entities archs
  99
 100 -- | Create an entity for a given function
 101 createEntity ::
 102   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
 103   -> VHDLState AST.EntityDec -- | The resulting entity
 104
 105 createEntity (fname, expr) = do
 106       -- Strip off lambda's, these will be arguments
 107       let (args, letexpr) = CoreSyn.collectBinders expr
 108       args' <- Monad.mapM mkMap args
 109       -- There must be a let at top level
 110       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
 111       res' <- mkMap res
 112       let vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname
 113       let ent_decl' = createEntityAST vhdl_id args' res'
 114       let AST.EntityDec entity_id _ = ent_decl'
 115       let signature = Entity entity_id args' res'
 116       modA vsSignatures (Map.insert fname signature)
 117       return ent_decl'
 118   where
 119     mkMap ::
 120       --[(SignalId, SignalInfo)]
 121       CoreSyn.CoreBndr
 122       -> VHDLState VHDLSignalMapElement
 123     -- We only need the vsTypes element from the state
 124     mkMap = (\bndr ->
 125       let
 126         --info = Maybe.fromMaybe
 127         --  (error $ "Signal not found in the name map? This should not happen!")
 128         --  (lookup id sigmap)
 129         --  Assume the bndr has a valid VHDL id already
 130         id = bndrToVHDLId bndr
 131         ty = Var.varType bndr
 132       in
 133         if True -- isPortSigUse $ sigUse info
 134           then do
 135             type_mark <- vhdl_ty ty
 136             return $ Just (id, type_mark)
 137           else
 138             return $ Nothing
 139        )
 140
 141   -- | Create the VHDL AST for an entity
 142 createEntityAST ::
 143   AST.VHDLId                   -- | The name of the function
 144   -> [VHDLSignalMapElement]    -- | The entity's arguments
 145   -> VHDLSignalMapElement      -- | The entity's result
 146   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 147
 148 createEntityAST vhdl_id args res =
 149   AST.EntityDec vhdl_id ports
 150   where
 151     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
 152     ports = Maybe.catMaybes $
 153               map (mkIfaceSigDec AST.In) args
 154               ++ [mkIfaceSigDec AST.Out res]
 155               ++ [clk_port]
 156     -- Add a clk port if we have state
 157     clk_port = if True -- hasState hsfunc
 158       then
 159         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logic_ty
 160       else
 161         Nothing
 162
 163 -- | Create a port declaration
 164 mkIfaceSigDec ::
 165   AST.Mode                         -- | The mode for the port (In / Out)
 166   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 167   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 168
 169 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 170 mkIfaceSigDec _ Nothing = Nothing
 171
 172 {-
 173 -- | Generate a VHDL entity name for the given hsfunc
 174 mkEntityId hsfunc =
 175   -- TODO: This doesn't work for functions with multiple signatures!
 176   -- Use a Basic Id, since using extended id's for entities throws off
 177   -- precision and causes problems when generating filenames.
 178   mkVHDLBasicId $ hsFuncName hsfunc
 179 -}
 180
 181 -- | Create an architecture for a given function
 182 createArchitecture ::
 183   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
 184   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 185
 186 createArchitecture (fname, expr) = do
 187   signaturemap <- getA vsSignatures
 188   let signature = Maybe.fromMaybe
 189         (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
 190         (Map.lookup fname signaturemap)
 191   let entity_id = ent_id signature
 192   -- Strip off lambda's, these will be arguments
 193   let (args, letexpr) = CoreSyn.collectBinders expr
 194   -- There must be a let at top level
 195   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
 196
 197   -- Create signal declarations for all binders in the let expression, except
 198   -- for the output port (that will already have an output port declared in
 199   -- the entity).
 200   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
 201   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 202
 203   statementss <- Monad.mapM mkConcSm binds
 204   let statements = concat statementss
 205   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 206   where
 207     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
 208     procs' = map AST.CSPSm procs
 209     -- mkSigDec only uses vsTypes from the state
 210     mkSigDec' = mkSigDec
 211
 212 {-
 213 -- | Looks up all pairs of old state, new state signals, together with
 214 --   the state id they represent.
 215 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 216 makeStatePairs flatfunc =
 217   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 218     | old_info <- map snd (flat_sigs flatfunc)
 219     , new_info <- map snd (flat_sigs flatfunc)
 220         -- old_info must be an old state (and, because of the next equality,
 221         -- new_info must be a new state).
 222         , Maybe.isJust $ oldStateId $ sigUse old_info
 223         -- And the state numbers must match
 224     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 225
 226     -- Replace the second tuple element with the corresponding SignalInfo
 227     --args_states = map (Arrow.second $ signalInfo sigs) args
 228 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 229 mkStateProcSm (num, old, new) =
 230   AST.ProcSm label [clk] [statement]
 231   where
 232     label       = mkVHDLExtId $ "state_" ++ (show num)
 233     clk         = mkVHDLExtId "clk"
 234     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 235     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 236     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 237     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 238     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 239
 240 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 241 --   is not named.
 242 getSignalId :: SignalInfo -> AST.VHDLId
 243 getSignalId info =
 244   mkVHDLExtId $ Maybe.fromMaybe
 245     (error $ "Unnamed signal? This should not happen!")
 246     (sigName info)
 247 -}
 248
 249 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
 250 mkSigDec bndr =
 251   if True then do --isInternalSigUse use || isStateSigUse use then do
 252     type_mark <- vhdl_ty $ Var.varType bndr
 253     return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
 254   else
 255     return Nothing
 256
 257 -- | Transforms a core binding into a VHDL concurrent statement
 258 mkConcSm ::
 259   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 260   -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 261
 262
 263 -- Ignore Cast expressions, they should not longer have any meaning as long as
 264 -- the type works out.
 265 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 266
 267 -- For simple a = b assignments, just generate an unconditional signal
 268 -- assignment. This should only happen for dataconstructors without arguments.
 269 -- TODO: Integrate this with the below code for application (essentially this
 270 -- is an application without arguments)
 271 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
 272
 273 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 274   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 275   let valargs' = filter isValArg args
 276   let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
 277   case Var.globalIdVarDetails f of
 278     IdInfo.DataConWorkId dc ->
 279         -- It's a datacon. Create a record from its arguments.
 280         -- First, filter out type args. TODO: Is this the best way to do this?
 281         -- The types should already have been taken into acocunt when creating
 282         -- the signal, so this should probably work...
 283         --let valargs = filter isValArg args in
 284         if all is_var valargs then do
 285           labels <- getFieldLabels (CoreUtils.exprType app)
 286           return $ zipWith mkassign labels valargs
 287         else
 288           error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
 289       where
 290         mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
 291         mkassign label (Var arg) =
 292           let sel_name = mkSelectedName bndr label in
 293           mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
 294     IdInfo.VanillaGlobal -> do
 295       -- It's a global value imported from elsewhere. These can be builtin
 296       -- functions.
 297       funSignatures <- getA vsNameTable
 298       signatures <- getA vsSignatures
 299       case (Map.lookup (bndrToString f) funSignatures) of
 300         Just (arg_count, builder) ->
 301           if length valargs == arg_count then
 302             case builder of
 303               Left funBuilder ->
 304                 let
 305                   sigs = map (varToVHDLExpr.varBndr) valargs
 306                   func = funBuilder sigs
 307                   src_wform = AST.Wform [AST.WformElem func Nothing]
 308                   dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
 309                   assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 310                 in
 311                   return [AST.CSSASm assign]
 312               Right genBuilder ->
 313                 let
 314                   sigs = map varBndr valargs
 315                   signature = Maybe.fromMaybe
 316                     (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!")
 317                     (Map.lookup (head sigs) signatures)
 318                   arg = tail sigs
 319                   genSm = genBuilder signature (arg ++ [bndr])
 320                 in return [AST.CSGSm genSm]
 321           else
 322             error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
 323         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
 324     IdInfo.NotGlobalId -> do
 325       signatures <- getA vsSignatures
 326       -- This is a local id, so it should be a function whose definition we
 327       -- have and which can be turned into a component instantiation.
 328       let
 329         signature = Maybe.fromMaybe
 330           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
 331           (Map.lookup f signatures)
 332         entity_id = ent_id signature
 333         label = "comp_ins_" ++ bndrToString bndr
 334         -- Add a clk port if we have state
 335         --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 336         clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 337         --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 338         portmaps = clk_port : mkAssocElems args bndr signature
 339         in
 340           return [genComponentInst label entity_id portmaps]
 341     details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 342
 343 -- A single alt case must be a selector. This means thee scrutinee is a simple
 344 -- variable, the alternative is a dataalt with a single non-wild binder that
 345 -- is also returned.
 346 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 347   case alt of
 348     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
 349       case List.elemIndex sel_bndr bndrs of
 350         Just i -> do
 351           labels <- getFieldLabels (Id.idType scrut)
 352           let label = labels!!i
 353           let sel_name = mkSelectedName scrut label
 354           let sel_expr = AST.PrimName sel_name
 355           return [mkUncondAssign (Left bndr) sel_expr]
 356         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 357
 358     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 359
 360 -- Multiple case alt are be conditional assignments and have only wild
 361 -- binders in the alts and only variables in the case values and a variable
 362 -- for a scrutinee. We check the constructor of the second alt, since the
 363 -- first is the default case, if there is any.
 364 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
 365   let
 366     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
 367     true_expr  = (varToVHDLExpr true)
 368     false_expr  = (varToVHDLExpr false)
 369   in
 370     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
 371 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 372 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
 373 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 374
 375 -- Finds the field labels for VHDL type generated for the given Core type,
 376 -- which must result in a record type.
 377 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
 378 getFieldLabels ty = do
 379   -- Ensure that the type is generated (but throw away it's VHDLId)
 380   vhdl_ty ty
 381   -- Get the types map, lookup and unpack the VHDL TypeDef
 382   types <- getA vsTypes
 383   case Map.lookup (OrdType ty) types of
 384     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 385     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 386
 387 {-
 388 mkConcSm sigs (UncondDef src dst) _ = do
 389   src_expr <- vhdl_expr src
 390   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 391   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 392   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 393   return $ AST.CSSASm assign
 394   where
 395     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 396     vhdl_expr (Right expr) =
 397       case expr of
 398         (EqLit id lit) ->
 399           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 400         (Literal lit Nothing) ->
 401           return $ AST.PrimLit lit
 402         (Literal lit (Just ty)) -> do
 403           -- Create a cast expression, which is just a function call using the
 404           -- type name as the function name.
 405           let litexpr = AST.PrimLit lit
 406           ty_id <- vhdl_ty ty
 407           let ty_name = AST.NSimple ty_id
 408           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 409           return $ AST.PrimFCall $ AST.FCall ty_name args
 410         (Eq a b) ->
 411          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 412
 413 mkConcSm sigs (CondDef cond true false dst) _ =
 414   let
 415     cond_expr  = mkIdExpr sigs cond
 416     true_expr  = mkIdExpr sigs true
 417     false_expr  = mkIdExpr sigs false
 418     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 419     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 420     whenelse = AST.WhenElse true_wform cond_expr
 421     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 422     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 423   in
 424     return $ AST.CSSASm assign
 425
 426 | Turn a SignalId into a VHDL Expr
 427 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 428 mkIdExpr sigs id =
 429   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 430   AST.PrimName src_name
 431
 432 -- | Look up a signal in the signal name map
 433 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 434 lookupSigName sigs sig = name
 435   where
 436     info = Maybe.fromMaybe
 437       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 438       (lookup sig sigs)
 439     name = Maybe.fromMaybe
 440       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 441       (sigName info)
 442 -}
 443
 444 -- Translate a Haskell type to a VHDL type
 445 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 446 vhdl_ty ty = do
 447   typemap <- getA vsTypes
 448   let builtin_ty = do -- See if this is a tycon and lookup its name
 449         (tycon, args) <- Type.splitTyConApp_maybe ty
 450         let name = Name.getOccString (TyCon.tyConName tycon)
 451         Map.lookup name builtin_types
 452   -- If not a builtin type, try the custom types
 453   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 454   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 455     -- Found a type, return it
 456     Just t -> return t
 457     -- No type yet, try to construct it
 458     Nothing -> do
 459       newty_maybe <- (construct_vhdl_ty ty)
 460       case newty_maybe of
 461         Just (ty_id, ty_def) -> do
 462           -- TODO: Check name uniqueness
 463           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
 464           return ty_id
 465         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
 466
 467 -- Construct a new VHDL type for the given Haskell type.
 468 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 469 construct_vhdl_ty ty = do
 470   case Type.splitTyConApp_maybe ty of
 471     Just (tycon, args) -> do
 472       let name = Name.getOccString (TyCon.tyConName tycon)
 473       case name of
 474         "TFVec" -> do
 475           res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
 476           return $ Just $ (Arrow.second Right) res
 477         -- "SizedWord" -> do
 478         --   res <- mk_vector_ty (sized_word_len ty) ty
 479         --   return $ Just $ (Arrow.second Left) res
 480         "RangedWord" -> do
 481           res <- mk_natural_ty 0 (ranged_word_bound ty)
 482           return $ Just $ (Arrow.second Right) res
 483         -- Create a custom type from this tycon
 484         otherwise -> mk_tycon_ty tycon args
 485     Nothing -> return $ Nothing
 486
 487 -- | Create VHDL type for a custom tycon
 488 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 489 mk_tycon_ty tycon args =
 490   case TyCon.tyConDataCons tycon of
 491     -- Not an algebraic type
 492     [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
 493     [dc] -> do
 494       let arg_tys = DataCon.dataConRepArgTys dc
 495       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 496       -- violation? Or does it only mean not to apply it again to the same
 497       -- subject?
 498       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 499       elem_tys <- mapM vhdl_ty real_arg_tys
 500       let elems = zipWith AST.ElementDec recordlabels elem_tys
 501       -- For a single construct datatype, build a record with one field for
 502       -- each argument.
 503       -- TODO: Add argument type ids to this, to ensure uniqueness
 504       -- TODO: Special handling for tuples?
 505       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
 506       let ty_def = AST.TDR $ AST.RecordTypeDef elems
 507       return $ Just (ty_id, Left ty_def)
 508     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
 509   where
 510     -- Create a subst that instantiates all types passed to the tycon
 511     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 512     -- to work so far, though..
 513     tyvars = TyCon.tyConTyVars tycon
 514     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 515
 516 -- | Create a VHDL vector type
 517 mk_vector_ty ::
 518   Int -- ^ The length of the vector
 519   -> Type.Type -- ^ The Haskell element type of the Vector
 520   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 521
 522 mk_vector_ty len el_ty = do
 523   elem_types_map <- getA vsElemTypes
 524   el_ty_tm <- vhdl_ty el_ty
 525   let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 526   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 527   let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
 528   case existing_elem_ty of
 529     Just t -> do
 530       let ty_def = AST.SubtypeIn t (Just range)
 531       return (ty_id, ty_def)
 532     Nothing -> do
 533       let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 534       let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
 535       modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
 536       modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
 537       let ty_def = AST.SubtypeIn vec_id (Just range)
 538       return (ty_id, ty_def)
 539
 540 mk_natural_ty ::
 541   Int -- ^ The minimum bound (> 0)
 542   -> Int -- ^ The maximum bound (> minimum bound)
 543   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 544 mk_natural_ty min_bound max_bound = do
 545   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 546   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
 547   let ty_def = AST.SubtypeIn naturalTM (Just range)
 548   return (ty_id, ty_def)