-- 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
]
-- 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
- 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
- case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
- -- Found a type, return it
- Just t -> return t
- -- No type yet, try to construct it
- Nothing -> do
- newty_maybe <- (construct_vhdl_ty msg ty)
- case newty_maybe of
- Just (ty_id, ty_def) -> do
- -- TODO: Check name uniqueness
- modA vsTypes (Map.insert (OrdType ty) (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
+ htype_either <- mkHType ty
+ case htype_either of
+ -- No errors
+ Right htype -> do
+ 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 htype typemap
+ case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+ -- Found a type, return it
+ Just t -> return (Right t)
+ -- No type yet, try to construct it
+ Nothing -> do
+ newty_maybe <- (construct_vhdl_ty ty)
+ case newty_maybe of
+ Right (ty_id, ty_def) -> do
+ -- TODO: Check name uniqueness
+ modA vsTypes (Map.insert htype (ty_id, ty_def))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ return (Right ty_id)
+ Left err -> return $ Left $
+ "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
+ ++ err
+ -- Error when constructing htype
+ Left err -> return $ Left 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 (tfvec_len ty) (tfvec_elem ty)
- return $ Just $ (Arrow.second Right) res
- -- "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
+ "TFVec" -> mk_vector_ty ty
+ "SizedWord" -> mk_unsigned_ty ty
+ "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 ::
- Int -- ^ The length of the vector
- -> Type.Type -- ^ The Haskell element type of the Vector
- -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-
-mk_vector_ty len el_ty = do
- elem_types_map <- getA vsElemTypes
- 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 (OrdType el_ty) elem_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 vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
- --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
- let ty_def = AST.SubtypeIn vec_id (Just range)
- return (ty_id, ty_def)
+ Type.Type -- ^ The Haskell type of the Vector
+ -> 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 (nvec_l, nvec_el) = Type.splitAppTy ty
+ let (nvec, leng) = Type.splitAppTy nvec_l
+ let vec_ty = Type.mkAppTy nvec nvec_el
+ let len = tfvec_len ty
+ let el_ty = tfvec_elem ty
+ 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 (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 (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))
+
+mk_unsigned_ty ::
+ Type.Type -- ^ Haskell type of the signed integer
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_unsigned_ty ty = do
+ let size = sized_word_len ty
+ let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_def = AST.SubtypeIn signedTM (Just range)
+ 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
+ -- Assume the type for which we want labels is really translatable
+ Right 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 -> TypeSession (Either String 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 $ Right $ 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
+ let el_ty = tfvec_elem ty
+ elem_htype_either <- mkHType el_ty
+ case elem_htype_either of
+ -- Could create element type
+ Right elem_htype -> do
+ len <- vec_len ty
+ return $ Right $ VecType len elem_htype
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
+ "SizedWord" -> return $ Right $ StdType $ OrdType ty
+ "RangedWord" -> return $ Right $ StdType $ OrdType ty
+ otherwise -> do
+ mkTyConHType tycon args
+ Nothing -> return $ Right $ StdType $ OrdType ty
+
+-- FIXME: Do we really need to do this here again?
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
+mkTyConHType tycon args =
+ case TyCon.tyConDataCons tycon of
+ -- Not an algebraic type
+ [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+ [dc] -> do
+ let arg_tys = DataCon.dataConRepArgTys dc
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ elem_htys_either <- mapM mkHType real_arg_tys
+ case Either.partitionEithers elem_htys_either of
+ -- No errors in element types
+ ([], elem_htys) -> do
+ return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+ -- There were errors in element types
+ (errors, _) -> return $ Left $
+ "VHDLTools.mkHType: 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.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+ where
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+ ty_either <- vhdl_ty_either ty
+ return $ case ty_either of
+ Left _ -> False
+ Right _ -> True
+
+vec_len :: Type.Type -> TypeSession Int
+vec_len ty = do
+ veclens <- getA vsTfpInts
+ let len_ty = tfvec_len_ty ty
+ let existing_len = Map.lookup (OrdType len_ty) veclens
+ case existing_len of
+ Just len -> return len
+ Nothing -> do
+ let new_len = tfvec_len ty
+ modA vsTfpInts (Map.insert (OrdType len_ty) (new_len))
+ return new_len
\ No newline at end of file
projects / matthijs / master-project / cλash.git / blobdiff