X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDLTools.hs;h=e7c598d498d322222821bdaf091422ca778e5f96;hb=aa23b0116eaf65b01499cd1eba93a92f7c8c36e8;hp=cc80e92ad60e00fa0c5e90c51e66d95c215c77c2;hpb=500eeddbc234537b7453f7368387977ad83f0262;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDLTools.hs b/VHDLTools.hs index cc80e92..e7c598d 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -2,9 +2,15 @@ module VHDLTools where -- 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 +import qualified Control.Arrow as Arrow +import qualified Control.Monad.Trans.State as State +import qualified Data.Monoid as Monoid +import Data.Accessor +import Debug.Trace -- ForSyDe import qualified ForSyDe.Backend.VHDL.AST as AST @@ -15,12 +21,21 @@ import qualified Name import qualified OccName import qualified Var import qualified Id +import qualified IdInfo import qualified TyCon +import qualified Type import qualified DataCon +import qualified CoreSubst -- Local imports import VHDLTypes import CoreTools +import Pretty +import Constants + +----------------------------------------------------------------------------- +-- Functions to generate concurrent statements +----------------------------------------------------------------------------- -- Create an unconditional assignment statement mkUncondAssign :: @@ -58,30 +73,20 @@ mkAssign dst cond false_expr = Nothing -> [] false_wform = AST.Wform [AST.WformElem false_expr Nothing] dst_name = case dst of - Left bndr -> AST.NSimple (bndrToVHDLId bndr) + Left bndr -> AST.NSimple (varToVHDLId bndr) Right name -> name assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing) in AST.CSSASm assign --- Create a record field selector that selects the given label from the record --- stored in the given binder. -mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName -mkSelectedName bndr label = - let - sel_prefix = AST.NSimple $ bndrToVHDLId bndr - sel_suffix = AST.SSimple $ label - in - AST.NSelected $ sel_prefix AST.:.: sel_suffix - mkAssocElems :: - [CoreSyn.CoreExpr] -- | The argument that are applied to function - -> CoreSyn.CoreBndr -- | The binder in which to store the result + [AST.Expr] -- | The argument that are applied to function + -> AST.VHDLName -- | The binder in which to store the result -> Entity -- | The entity to map against. -> [AST.AssocElem] -- | The resulting port maps mkAssocElems args res entity = -- Create the actual AssocElems - Maybe.catMaybes $ zipWith mkAssocElem ports sigs + zipWith mkAssocElem ports sigs where -- Turn the ports and signals from a map into a flat list. This works, -- since the maps must have an identical form by definition. TODO: Check @@ -89,30 +94,66 @@ mkAssocElems args res entity = arg_ports = ent_args entity res_port = ent_res entity -- Extract the id part from the (id, type) tuple - ports = map (Monad.liftM fst) (res_port : arg_ports) + ports = map fst (res_port : arg_ports) -- Translate signal numbers into names - sigs = (bndrToString res : map (bndrToString.varBndr) args) + sigs = (vhdlNameToVHDLExpr res : args) -- | Create an VHDL port -> signal association -mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem -mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal))) -mkAssocElem Nothing _ = Nothing +mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem +mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) -- | Create an VHDL port -> signal association -mkAssocElemIndexed :: Maybe AST.VHDLId -> String -> AST.VHDLId -> Maybe AST.AssocElem -mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName - (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index]))) -mkAssocElemIndexed Nothing _ _ = Nothing +mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem +mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName + (AST.NSimple signal) [AST.PrimName $ AST.NSimple index]))) + +mkComponentInst :: + String -- ^ The portmap label + -> AST.VHDLId -- ^ The entity name + -> [AST.AssocElem] -- ^ The port assignments + -> AST.ConcSm +mkComponentInst label entity_id portassigns = AST.CSISm compins + where + -- We always have a clock port, so no need to map it anywhere but here + clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk") + compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port])) + +----------------------------------------------------------------------------- +-- Functions to generate VHDL Exprs +----------------------------------------------------------------------------- -- Turn a variable reference into a AST expression -varToVHDLExpr :: Var.Var -> AST.Expr -varToVHDLExpr var = +varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr +varToVHDLExpr ty_state var = case Id.isDataConWorkId_maybe var of Just dc -> dataconToVHDLExpr dc -- This is a dataconstructor. -- Not a datacon, just another signal. Perhaps we should check for -- local/global here as well? - Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var + -- Sadly so.. tfp decimals are types, not data constructors, but instances + -- should still be translated to integer literals. It is probebly not the + -- best solution to translate them here. + -- FIXME: Find a better solution for translating instances of tfp integers + Nothing -> + let + ty = Var.varType var + res = case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> + case Name.getOccString (TyCon.tyConName tycon) of + "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) ) + otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var + in + res + + +-- Turn a VHDLName into an AST expression +vhdlNameToVHDLExpr = AST.PrimName + +-- Turn a VHDL Id into an AST expression +idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple + +-- Turn a Core expression into an AST expression +exprToVHDLExpr ty_state = (varToVHDLExpr ty_state) . exprToVar -- Turn a alternative constructor into an AST expression. For -- dataconstructors, this is only the constructor itself, not any arguments it @@ -120,8 +161,8 @@ varToVHDLExpr var = altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc -altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet" -altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!" +altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet" +altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!" -- Turn a datacon (without arguments!) into a VHDL expression. dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr @@ -135,12 +176,37 @@ dataconToVHDLExpr dc = AST.PrimLit lit "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false" --- Turns a Var CoreExpr into the Id inside it. Will of course only work for --- simple Var CoreExprs, not complexer ones. -varBndr :: CoreSyn.CoreExpr -> Var.Id -varBndr (CoreSyn.Var id) = id +----------------------------------------------------------------------------- +-- Functions dealing with names, variables and ids +----------------------------------------------------------------------------- + +-- Creates a VHDL Id from a binder +varToVHDLId :: + CoreSyn.CoreBndr + -> AST.VHDLId +varToVHDLId = mkVHDLExtId . varToString + +-- Creates a VHDL Name from a binder +varToVHDLName :: + CoreSyn.CoreBndr + -> AST.VHDLName +varToVHDLName = AST.NSimple . varToVHDLId + +-- Extracts the binder name as a String +varToString :: + CoreSyn.CoreBndr + -> String +varToString = OccName.occNameString . Name.nameOccName . Var.varName + +-- Get the string version a Var's unique +varToStringUniq :: Var.Var -> String +varToStringUniq = show . Var.varUnique + +-- Extracts the string version of the name +nameToString :: Name.Name -> String +nameToString = OccName.occNameString . Name.nameOccName --- Shortcut for +-- Shortcut for Basic VHDL Ids. -- Can only contain alphanumerics and underscores. The supplied string must be -- a valid basic id, otherwise an error value is returned. This function is -- not meant to be passed identifiers from a source file, use mkVHDLExtId for @@ -172,65 +238,300 @@ mkVHDLExtId s = allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-" strip_invalid = filter (`elem` allowed) --- Creates a VHDL Id from a binder -bndrToVHDLId :: - CoreSyn.CoreBndr - -> AST.VHDLId -bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName +-- Create a record field selector that selects the given label from the record +-- stored in the given binder. +mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName +mkSelectedName name label = + AST.NSelected $ name AST.:.: (AST.SSimple label) --- Extracts the binder name as a String -bndrToString :: - CoreSyn.CoreBndr - -> String -bndrToString = OccName.occNameString . Name.nameOccName . Var.varName +-- Create an indexed name that selects a given element from a vector. +mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName +-- Special case for already indexed names. Just add an index +mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index = + AST.NIndexed (AST.IndexedName name (indexes++[index])) +-- General case for other names +mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index]) --- Get the string version a Var's unique -varToStringUniq :: Var.Var -> String -varToStringUniq = show . Var.varUnique +----------------------------------------------------------------------------- +-- Functions dealing with VHDL types +----------------------------------------------------------------------------- --- Extracts the string version of the name -nameToString :: Name.Name -> String -nameToString = OccName.occNameString . Name.nameOccName +-- | Maps the string name (OccName) of a type to the corresponding VHDL type, +-- for a few builtin types. +builtin_types = + Map.fromList [ + ("Bit", std_logicTM), + ("Bool", booleanTM), -- TysWiredIn.boolTy + ("Dec", integerTM) + ] -recordlabels :: [AST.VHDLId] -recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] +-- Translate a Haskell type to a VHDL type, generating a new type if needed. +-- 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 -getVectorLen :: CoreSyn.CoreBndr -> Int -getVectorLen bndr = len - where - ty = Var.varType bndr - len = tfvec_len ty - -genComponentInst :: - String -- ^ The portmap label - -> AST.VHDLId -- ^ The entity name - -> [AST.AssocElem] -- ^ The port assignments - -> AST.ConcSm -genComponentInst label entity_id portassigns = AST.CSISm compins +-- 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_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" -> mk_vector_ty ty + "SizedWord" -> mk_unsigned_ty ty + "SizedInt" -> mk_signed_ty ty + "RangedWord" -> do + bound <- tfp_to_int (ranged_word_bound_ty ty) + mk_natural_ty 0 bound + -- Create a custom type from this tycon + 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 :: 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 + [] -> 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 + 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 - compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portassigns) + -- 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 + -- to work so far, though.. + tyvars = TyCon.tyConTyVars tycon + subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) + -- Generate a bunch of labels for fields of a record + recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] --- | The VHDL Bit type -bit_ty :: AST.TypeMark -bit_ty = AST.unsafeVHDLBasicId "Bit" +-- | Create a VHDL vector type +mk_vector_ty :: + 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. --- | The VHDL Boolean type -bool_ty :: AST.TypeMark -bool_ty = AST.unsafeVHDLBasicId "Boolean" +mk_vector_ty ty = do + types_map <- getA vsTypes + env <- getA vsHscEnv + let (nvec_l, nvec_el) = Type.splitAppTy ty + let (nvec, leng) = Type.splitAppTy nvec_l + let vec_ty = Type.mkAppTy nvec nvec_el + len <- tfp_to_int (tfvec_len_ty 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 --- | The VHDL std_logic -std_logic_ty :: AST.TypeMark -std_logic_ty = AST.unsafeVHDLBasicId "std_logic" +mk_natural_ty :: + Int -- ^ The minimum bound (> 0) + -> Int -- ^ The maximum bound (> minimum bound) + -> 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 (Right (ty_id, Right ty_def)) + +mk_unsigned_ty :: + Type.Type -- ^ Haskell type of the unsigned integer + -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +mk_unsigned_ty ty = do + size <- tfp_to_int (sized_word_len_ty 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 unsignedTM (Just range) + return (Right (ty_id, Right ty_def)) -builtin_types = - Map.fromList [ - ("Bit", std_logic_ty), - ("Bool", bool_ty) -- TysWiredIn.boolTy - ] +mk_signed_ty :: + Type.Type -- ^ Haskell type of the signed integer + -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +mk_signed_ty ty = do + size <- tfp_to_int (sized_int_len_ty ty) + let ty_id = mkVHDLExtId $ "signed_" ++ 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 -> 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 + -- 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 <- tfp_to_int (tfvec_len_ty 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" -> do + len <- tfp_to_int (sized_word_len_ty ty) + return $ Right $ SizedWType len + "SizedInt" -> do + len <- tfp_to_int (sized_word_len_ty ty) + return $ Right $ SizedIType len + "RangedWord" -> do + bound <- tfp_to_int (ranged_word_bound_ty ty) + return $ Right $ RangedWType bound + 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 -{- --- | Map a port specification of a builtin function to a VHDL Signal to put in --- a VHDLSignalMap -toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement -toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty) --} +tfp_to_int :: Type.Type -> TypeSession Int +tfp_to_int ty = do + lens <- getA vsTfpInts + hscenv <- getA vsHscEnv + let norm_ty = normalise_tfp_int hscenv ty + let existing_len = Map.lookup (OrdType norm_ty) lens + case existing_len of + Just len -> return len + Nothing -> do + let new_len = eval_tfp_int hscenv ty + modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len)) + return new_len \ No newline at end of file