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