Merge git://github.com/darchon/clash into cλash
authorMatthijs Kooijman <m.kooijman@student.utwente.nl>
Fri, 3 Jul 2009 11:27:57 +0000 (13:27 +0200)
committerMatthijs Kooijman <m.kooijman@student.utwente.nl>
Fri, 3 Jul 2009 11:27:57 +0000 (13:27 +0200)
* git://github.com/darchon/clash:
  Keys for typemap can now deal with vector lengths based on type operators

Conflicts:
Generate.hs
VHDLTools.hs

1  2 
Generate.hs
VHDLTools.hs
VHDLTypes.hs

diff --combined Generate.hs
index 6b19bb5d729806ee0eb18e8f3a9faaa2e269ee93,dfd9fad8bbfaed867db25a8d368493387cae7c57..b3045def5bfcee16e869fac00e08e603e7335e15
@@@ -6,7 -6,6 +6,7 @@@ import qualified Data.Map as Ma
  import qualified Maybe
  import qualified Data.Either as Either
  import Data.Accessor
 +import Data.Accessor.MonadState as MonadState
  import Debug.Trace
  
  -- ForSyDe
@@@ -72,16 -71,16 +72,16 @@@ genOperator1' op _ f [arg] = return $ o
  
  -- | Generate a function call from the destination binder, function name and a
  -- list of expressions (its arguments)
- genFCall :: BuiltinBuilder 
- genFCall = genExprArgs $ genExprRes genFCall'
- genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
- genFCall' (Left res) f args = do
+ genFCall :: Bool -> BuiltinBuilder 
+ genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
+ genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+ genFCall' switch (Left res) f args = do
    let fname = varToString f
-   let el_ty = (tfvec_elem . Var.varType) res
+   let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
 -  id <- vectorFunId el_ty fname
 +  id <- MonadState.lift vsType $ vectorFunId el_ty fname
    return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
               map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
- genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+ genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
  
  -- | Generate a generate statement for the builtin function "map"
  genMap :: BuiltinBuilder
@@@ -156,7 -155,7 +156,7 @@@ genFold' left (Left res) f [folded_f, s
    -- temporary vector
    let tmp_ty = Type.mkAppTy nvec (Var.varType start)
    let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
 -  tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty
 +  tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
    -- Setup the generate scheme
    let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
    let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
@@@ -246,7 -245,7 +246,7 @@@ genZip' (Left res) f args@[arg1, arg2] 
      argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
      argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
    in do
 -    labels <- getFieldLabels (tfvec_elem (Var.varType res))
 +    labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
      let resnameA    = mkSelectedName resname' (labels!!0)
      let resnameB    = mkSelectedName resname' (labels!!1)
      let resA_assign = mkUncondAssign (Right resnameA) argexpr1
@@@ -271,8 -270,8 +271,8 @@@ genUnzip' (Left res) f args@[arg] 
      resname'        = varToVHDLName res
      argexpr'        = mkIndexedName (varToVHDLName arg) n_expr
    in do
 -    reslabels <- getFieldLabels (Var.varType res)
 -    arglabels <- getFieldLabels (tfvec_elem (Var.varType arg))
 +    reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
 +    arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
      let resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
      let resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
      let argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
@@@ -347,7 -346,7 +347,7 @@@ genIterateOrGenerate' iter (Left res) 
    -- -- temporary vector
    let tmp_ty = Var.varType res
    let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
 -  tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty
 +  tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
    -- Setup the generate scheme
    let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
    let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
@@@ -421,7 -420,7 +421,7 @@@ genApplication dst f args 
        -- It's a datacon. Create a record from its arguments.
        Left bndr -> do
          -- We have the bndr, so we can get at the type
 -        labels <- getFieldLabels (Var.varType bndr)
 +        labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
          return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args
          where
            mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
  
  -- Returns the VHDLId of the vector function with the given name for the given
  -- element type. Generates -- this function if needed.
 -vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
 +vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
  vectorFunId el_ty fname = do
    let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
    elemTM <- vhdl_ty error_msg el_ty
@@@ -875,40 -874,40 +875,40 @@@ genUnconsVectorFuns elemTM vectorTM  
  -- builder function.
  globalNameTable :: NameTable
  globalNameTable = Map.fromList
-   [ (exId             , (2, genFCall                ) )
-   , (replaceId        , (3, genFCall                ) )
-   , (headId           , (1, genFCall                ) )
-   , (lastId           , (1, genFCall                ) )
-   , (tailId           , (1, genFCall                ) )
-   , (initId           , (1, genFCall                ) )
-   , (takeId           , (2, genFCall                ) )
-   , (dropId           , (2, genFCall                ) )
-   , (selId            , (4, genFCall                ) )
-   , (plusgtId         , (2, genFCall                ) )
-   , (ltplusId         , (2, genFCall                ) )
-   , (plusplusId       , (2, genFCall                ) )
+   [ (exId             , (2, genFCall False          ) )
+   , (replaceId        , (3, genFCall False          ) )
+   , (headId           , (1, genFCall True           ) )
+   , (lastId           , (1, genFCall True           ) )
+   , (tailId           , (1, genFCall False          ) )
+   , (initId           , (1, genFCall False          ) )
+   , (takeId           , (2, genFCall False          ) )
+   , (dropId           , (2, genFCall False          ) )
+   , (selId            , (4, genFCall False          ) )
+   , (plusgtId         , (2, genFCall False          ) )
+   , (ltplusId         , (2, genFCall False          ) )
+   , (plusplusId       , (2, genFCall False          ) )
    , (mapId            , (2, genMap                  ) )
    , (zipWithId        , (3, genZipWith              ) )
    , (foldlId          , (3, genFoldl                ) )
    , (foldrId          , (3, genFoldr                ) )
    , (zipId            , (2, genZip                  ) )
    , (unzipId          , (1, genUnzip                ) )
-   , (shiftlId         , (2, genFCall                ) )
-   , (shiftrId         , (2, genFCall                ) )
-   , (rotlId           , (1, genFCall                ) )
-   , (rotrId           , (1, genFCall                ) )
+   , (shiftlId         , (2, genFCall False          ) )
+   , (shiftrId         , (2, genFCall False          ) )
+   , (rotlId           , (1, genFCall False          ) )
+   , (rotrId           , (1, genFCall False          ) )
    , (concatId         , (1, genConcat               ) )
-   , (reverseId        , (1, genFCall                ) )
+   , (reverseId        , (1, genFCall False          ) )
    , (iteratenId       , (3, genIteraten             ) )
    , (iterateId        , (2, genIterate              ) )
    , (generatenId      , (3, genGeneraten            ) )
    , (generateId       , (2, genGenerate             ) )
-   , (emptyId          , (0, genFCall                ) )
-   , (singletonId      , (1, genFCall                ) )
-   , (copynId          , (2, genFCall                ) )
+   , (emptyId          , (0, genFCall False          ) )
+   , (singletonId      , (1, genFCall False          ) )
+   , (copynId          , (2, genFCall False          ) )
    , (copyId           , (1, genCopy                 ) )
-   , (lengthTId        , (1, genFCall                ) )
-   , (nullId           , (1, genFCall                ) )
+   , (lengthTId        , (1, genFCall False          ) )
+   , (nullId           , (1, genFCall False          ) )
    , (hwxorId          , (2, genOperator2 AST.Xor    ) )
    , (hwandId          , (2, genOperator2 AST.And    ) )
    , (hworId           , (2, genOperator2 AST.Or     ) )
diff --combined VHDLTools.hs
index 5deaf45effbf579d6b5ce03f782c93e8b1c16712,cb4ea741645619d98d37f953930167f39162ab45..d560a7472bfada0303841dc0184312446109fe94
@@@ -2,7 -2,6 +2,7 @@@ module VHDLTools wher
  
  -- Standard modules
  import qualified Maybe
 +import qualified Data.Either as Either
  import qualified Data.List as List
  import qualified Data.Map as Map
  import qualified Control.Monad as Monad
@@@ -263,89 -262,74 +263,90 @@@ builtin_types 
    ]
  
  -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 -vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark
 +-- Returns an error value, using the given message, when no type could be
 +-- created.
 +vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
  vhdl_ty msg ty = do
 +  tm_either <- vhdl_ty_either ty
 +  case tm_either of
 +    Right tm -> return tm
 +    Left err -> error $ msg ++ "\n" ++ err
 +
 +-- Translate a Haskell type to a VHDL type, generating a new type if needed.
 +-- Returns either an error message or the resulting type.
 +vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
 +vhdl_ty_either ty = do
    typemap <- getA vsTypes
+   htype <- mkHType ty
    let builtin_ty = do -- See if this is a tycon and lookup its name
          (tycon, args) <- Type.splitTyConApp_maybe ty
          let name = Name.getOccString (TyCon.tyConName tycon)
          Map.lookup name builtin_types
    -- If not a builtin type, try the custom types
-   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
+   let existing_ty = (fmap fst) $ Map.lookup htype typemap
    case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
      -- Found a type, return it
 -    Just t -> return t
 +    Just t -> return (Right t)
      -- No type yet, try to construct it
      Nothing -> do
 -      newty_maybe <- (construct_vhdl_ty msg ty)
 +      newty_maybe <- (construct_vhdl_ty ty)
        case newty_maybe of
 -        Just (ty_id, ty_def) -> do
 +        Right (ty_id, ty_def) -> do
            -- TODO: Check name uniqueness
-           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+           modA vsTypes (Map.insert htype (ty_id, ty_def))
            modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
 -          return ty_id
 -        Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
 -
 --- Construct a new VHDL type for the given Haskell type.
 -construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 -construct_vhdl_ty msg ty = do
 +          return (Right ty_id)
 +        Left err -> return $ Left $
 +          "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
 +          ++ err
 +
 +-- Construct a new VHDL type for the given Haskell type. Returns an error
 +-- message or the resulting typemark and typedef.
 +construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 +construct_vhdl_ty ty = do
    case Type.splitTyConApp_maybe ty of
      Just (tycon, args) -> do
        let name = Name.getOccString (TyCon.tyConName tycon)
        case name of
 -        "TFVec" -> do
 -          res <- mk_vector_ty ty
 -          return $ Just $ (Arrow.second Right) res
 +        "TFVec" -> mk_vector_ty ty
          -- "SizedWord" -> do
          --   res <- mk_vector_ty (sized_word_len ty) ty
          --   return $ Just $ (Arrow.second Left) res
 -        "RangedWord" -> do 
 -          res <- mk_natural_ty 0 (ranged_word_bound ty)
 -          return $ Just $ (Arrow.second Right) res
 +        "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
          -- Create a custom type from this tycon
 -        otherwise -> mk_tycon_ty msg tycon args
 -    Nothing -> return $ Nothing
 +        otherwise -> mk_tycon_ty tycon args
 +    Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
  
  -- | Create VHDL type for a custom tycon
 -mk_tycon_ty :: String -> TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 -mk_tycon_ty msg tycon args =
 +mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 +mk_tycon_ty tycon args =
    case TyCon.tyConDataCons tycon of
      -- Not an algebraic type
 -    [] -> error $ "\nVHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon
 +    [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
      [dc] -> do
        let arg_tys = DataCon.dataConRepArgTys dc
        -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
        -- violation? Or does it only mean not to apply it again to the same
        -- subject?
        let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 -      let error_msg = msg ++ "\nVHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for one of the arguments."
 -      elem_tys <- mapM (vhdl_ty error_msg) real_arg_tys
 -      let elems = zipWith AST.ElementDec recordlabels elem_tys
 -      -- For a single construct datatype, build a record with one field for
 -      -- each argument.
 -      -- TODO: Add argument type ids to this, to ensure uniqueness
 -      -- TODO: Special handling for tuples?
 -      let elem_names = concat $ map prettyShow elem_tys
 -      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
 -      let ty_def = AST.TDR $ AST.RecordTypeDef elems
 -      return $ Just (ty_id, Left ty_def)
 -    dcs -> error $ "\nVHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon
 +      elem_tys_either <- mapM vhdl_ty_either real_arg_tys
 +      case Either.partitionEithers elem_tys_either of
 +        -- No errors in element types
 +        ([], elem_tys) -> do
 +          let elems = zipWith AST.ElementDec recordlabels elem_tys
 +          -- For a single construct datatype, build a record with one field for
 +          -- each argument.
 +          -- TODO: Add argument type ids to this, to ensure uniqueness
 +          -- TODO: Special handling for tuples?
 +          let elem_names = concat $ map prettyShow elem_tys
 +          let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
 +          let ty_def = AST.TDR $ AST.RecordTypeDef elems
 +          return $ Right (ty_id, Left ty_def)
 +        -- There were errors in element types
 +        (errors, _) -> return $ Left $
 +          "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 +          ++ (concat errors)
 +    dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
    where
      -- Create a subst that instantiates all types passed to the tycon
      -- TODO: I'm not 100% sure that this is the right way to do this. It seems
  -- | Create a VHDL vector type
  mk_vector_ty ::
    Type.Type -- ^ The Haskell type of the Vector
 -  -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 +  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 +      -- ^ An error message or The typemark created.
  
  mk_vector_ty ty = do
    types_map <- getA vsTypes
    let vec_ty = Type.mkAppTy nvec nvec_el
    let len = tfvec_len ty
    let el_ty = tfvec_elem ty
 -  let error_msg = "\nVHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty 
 -  el_ty_tm <- vhdl_ty error_msg el_ty
 -  let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 -  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 -  let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
 -  case existing_elem_ty of
 -    Just t -> do
 -      let ty_def = AST.SubtypeIn t (Just range)
 -      return (ty_id, ty_def)
 -    Nothing -> do
 -      let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 -      let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
 -      modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
 -      modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) 
 -      let ty_def = AST.SubtypeIn vec_id (Just range)
 -      return (ty_id, ty_def)
 +  el_ty_tm_either <- vhdl_ty_either el_ty
 +  case el_ty_tm_either of
 +    -- Could create element type
 +    Right el_ty_tm -> do
 +      let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 +      let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
-       let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType vec_ty) types_map
++      let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
 +      case existing_elem_ty of
 +        Just t -> do
 +          let ty_def = AST.SubtypeIn t (Just range)
 +          return (Right (ty_id, Right ty_def))
 +        Nothing -> do
 +          let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 +          let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
-           modA vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def)))
++          modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
 +          modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) 
 +          let ty_def = AST.SubtypeIn vec_id (Just range)
 +          return (Right (ty_id, Right ty_def))
 +    -- Could not create element type
 +    Left err -> return $ Left $ 
 +      "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
 +      ++ err
  
  mk_natural_ty ::
    Int -- ^ The minimum bound (> 0)
    -> Int -- ^ The maximum bound (> minimum bound)
 -  -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 +  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 +      -- ^ An error message or The typemark created.
  mk_natural_ty min_bound max_bound = do
    let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
    let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
    let ty_def = AST.SubtypeIn naturalTM (Just range)
 -  return (ty_id, ty_def)
 +  return (Right (ty_id, Right ty_def))
  
  -- Finds the field labels for VHDL type generated for the given Core type,
  -- which must result in a record type.
 -getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
 +getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
  getFieldLabels ty = do
    -- Ensure that the type is generated (but throw away it's VHDLId)
    let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
    vhdl_ty error_msg ty
    -- Get the types map, lookup and unpack the VHDL TypeDef
    types <- getA vsTypes
-   case Map.lookup (OrdType ty) types of
+   htype <- mkHType ty
+   case Map.lookup htype types of
      Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
      _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
      
  mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
  mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
  mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
 -mkHType :: Type.Type -> VHDLSession HType
 -mkTyConHType :: TyCon.TyCon -> [Type.Type] -> VHDLSession HType
++mkHType :: Type.Type -> TypeSession HType
+ mkHType ty = do
+   -- FIXME: Do we really need to do this here again?
+   let builtin_ty = do -- See if this is a tycon and lookup its name
+         (tycon, args) <- Type.splitTyConApp_maybe ty
+         let name = Name.getOccString (TyCon.tyConName tycon)
+         Map.lookup name builtin_types
+   case builtin_ty of
+     Just typ -> 
+       return $ BuiltinType $ prettyShow typ
+     Nothing ->
+       case Type.splitTyConApp_maybe ty of
+         Just (tycon, args) -> do
+           let name = Name.getOccString (TyCon.tyConName tycon)
+           case name of
+             "TFVec" -> do
+               elem_htype <- mkHType (tfvec_elem ty)
+               return $ VecType (tfvec_len ty) elem_htype
+             otherwise -> do
+               mkTyConHType tycon args
+         Nothing -> return $ StdType $ OrdType ty
+ -- FIXME: Do we really need to do this here again?
 -    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
++mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType
+ mkTyConHType tycon args =
+   case TyCon.tyConDataCons tycon of
+     -- Not an algebraic type
+     [] -> error $ "\nVHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon
+     [dc] -> do
+       let arg_tys = DataCon.dataConRepArgTys dc
+       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+       elem_htys <- mapM mkHType real_arg_tys
+       return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+     dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
+   where
+     tyvars = TyCon.tyConTyVars tycon
++    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
diff --combined VHDLTypes.hs
index 0a81b7bf75534d314c928ca5e1b3f1f2ca0a89db,4a1b01719300f0cc9dab8de620a19ed18b2dc21f..ff159fa895a6f4c51318eaaf636c2d390e36e2f6
@@@ -38,8 -38,14 +38,14 @@@ instance Eq OrdType wher
  instance Ord OrdType where
    compare (OrdType a) (OrdType b) = Type.tcCmpType a b
  
+ data HType = StdType OrdType |
+              ADTType String [HType] |
+              VecType Int HType |
+              BuiltinType String
+   deriving (Eq, Ord)
  -- A map of a Core type to the corresponding type name
- type TypeMap = Map.Map OrdType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
+ type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
  
  -- A map of a vector Core element type and function name to the coressponding
  -- VHDLId of the function and the function body.
@@@ -48,24 -54,13 +54,24 @@@ type TypeFunMap = Map.Map (OrdType, Str
  -- A map of a Haskell function to a hardware signature
  type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
  
 -data VHDLState = VHDLState {
 +data TypeState = TypeState {
    -- | A map of Core type -> VHDL Type
    vsTypes_      :: TypeMap,
    -- | A list of type declarations
    vsTypeDecls_  :: [AST.PackageDecItem],
    -- | A map of vector Core type -> VHDL type function
 -  vsTypeFuns_   :: TypeFunMap,
 +  vsTypeFuns_   :: TypeFunMap
 +}
 +-- Derive accessors
 +$( Data.Accessor.Template.deriveAccessors ''TypeState )
 +-- Define an empty TypeState
 +emptyTypeState = TypeState Map.empty [] Map.empty
 +-- Define a session
 +type TypeSession = State.State TypeState
 +
 +data VHDLState = VHDLState {
 +  -- | A subtype with typing info
 +  vsType_       :: TypeState,
    -- | A map of HsFunction -> hardware signature (entity name, port names,
    --   etc.)
    vsSignatures_ :: SignatureMap
@@@ -77,6 -72,9 +83,6 @@@ $( Data.Accessor.Template.deriveAccesso
  -- | The state containing a VHDL Session
  type VHDLSession = State.State VHDLState
  
 --- | A substate containing just the types
 -type TypeState = State.State TypeMap
 -
  -- A function that generates VHDL for a builtin function
  type BuiltinBuilder = 
    (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type