X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FVHDLTools.hs;h=716663025e9698753f3a3ce55be5c366f74fba7d;hb=470b9fcfe0743054e2a1adb435e2806a140c732e;hp=e273da8bd3a9f26512389ea468cda228d2adcac8;hpb=6a83cf67b0711acdf5a3215ff096c392f2d5d7bf;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index e273da8..7166630 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -8,23 +8,17 @@ import qualified Data.List as List import qualified Data.Char as Char 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 Data.Accessor.MonadState as MonadState -import Debug.Trace - --- ForSyDe +import qualified Data.Accessor.Monad.Trans.State as MonadState + +-- VHDL Imports import qualified Language.VHDL.AST as AST -- GHC API -import CoreSyn +import qualified CoreSyn import qualified Name import qualified OccName import qualified Var import qualified Id -import qualified IdInfo import qualified TyCon import qualified Type import qualified DataCon @@ -45,14 +39,14 @@ import CLasH.VHDL.Constants -- Create an unconditional assignment statement mkUncondAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to -> AST.Expr -- ^ The expression to assign -> AST.ConcSm -- ^ The resulting concurrent statement mkUncondAssign dst expr = mkAssign dst Nothing expr -- Create a conditional assignment statement mkCondAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to -> AST.Expr -- ^ The condition -> AST.Expr -- ^ The value when true -> AST.Expr -- ^ The value when false @@ -61,7 +55,7 @@ mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false -- Create a conditional or unconditional assignment statement mkAssign :: - Either CoreBndr AST.VHDLName -- ^ The signal to assign to + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for -- and the value to assign when true. -> AST.Expr -- ^ The value to assign when false or no condition @@ -73,7 +67,7 @@ mkAssign dst cond false_expr = whenelse = case cond of Just (cond_expr, true_expr) -> let - true_wform = AST.Wform [AST.WformElem true_expr Nothing] + true_wform = AST.Wform [AST.WformElem true_expr Nothing] in [AST.WhenElse true_wform cond_expr] Nothing -> [] @@ -85,6 +79,31 @@ mkAssign dst cond false_expr = in AST.CSSASm assign +mkAltsAssign :: + Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to + -> [AST.Expr] -- ^ The conditions + -> [AST.Expr] -- ^ The expressions + -> AST.ConcSm -- ^ The Alt assigns +mkAltsAssign dst conds exprs + | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch" + | otherwise = + let + whenelses = zipWith mkWhenElse conds exprs + false_wform = AST.Wform [AST.WformElem (last exprs) Nothing] + dst_name = case dst of + Left bndr -> AST.NSimple (varToVHDLId bndr) + Right name -> name + assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing) + in + AST.CSSASm assign + where + mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse + mkWhenElse cond true_expr = + let + true_wform = AST.Wform [AST.WformElem true_expr Nothing] + in + AST.WhenElse true_wform cond + mkAssocElems :: [AST.Expr] -- ^ The argument that are applied to function -> AST.VHDLName -- ^ The binder in which to store the result @@ -127,25 +146,12 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins ----------------------------------------------------------------------------- varToVHDLExpr :: Var.Var -> TypeSession AST.Expr -varToVHDLExpr var = do +varToVHDLExpr var = case Id.isDataConWorkId_maybe var of - Just dc -> return $ dataconToVHDLExpr dc -- This is a dataconstructor. - -- Not a datacon, just another signal. Perhaps we should check for - -- local/global here as well? - -- 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 -> do - let ty = Var.varType var - case Type.splitTyConApp_maybe ty of - Just (tycon, args) -> - case Name.getOccString (TyCon.tyConName tycon) of - "Dec" -> do - len <- tfp_to_int ty - return $ AST.PrimLit $ (show len) - otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var + Just dc -> dataconToVHDLExpr dc + -- Not a datacon, just another signal. + Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var -- Turn a VHDLName into an AST expression vhdlNameToVHDLExpr = AST.PrimName @@ -159,23 +165,33 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core) -- Turn a alternative constructor into an AST expression. For -- dataconstructors, this is only the constructor itself, not any arguments it -- has. Should not be called with a DEFAULT constructor. -altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr -altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc +altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr +altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc -altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet" -altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!" +altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet" +altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!" -- Turn a datacon (without arguments!) into a VHDL expression. -dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr -dataconToVHDLExpr dc = AST.PrimLit lit - where - tycon = DataCon.dataConTyCon dc - tyname = TyCon.tyConName tycon - dcname = DataCon.dataConName dc - lit = case Name.getOccString tyname of - -- TODO: Do something more robust than string matching - "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" - "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false" +dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr +dataconToVHDLExpr dc = do + typemap <- MonadState.get tsTypes + htype_either <- mkHTypeEither (DataCon.dataConRepType dc) + case htype_either of + -- No errors + Right htype -> do + let dcname = DataCon.dataConName dc + case htype of + (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'" + (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false" + otherwise -> do + let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap + case existing_ty of + Just ty -> do + let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname + return lit + Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc + -- Error when constructing htype + Left err -> error err ----------------------------------------------------------------------------- -- Functions dealing with names, variables and ids @@ -185,7 +201,7 @@ dataconToVHDLExpr dc = AST.PrimLit lit varToVHDLId :: CoreSyn.CoreBndr -> AST.VHDLId -varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var)) +varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var)) where lowers :: String -> Int lowers xs = length [x | x <- xs, Char.isLower x] @@ -224,7 +240,7 @@ mkVHDLBasicId s = -- Strip leading numbers and underscores strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_") -- Strip multiple adjacent underscores - strip_multiscore = concat . map (\cs -> + strip_multiscore = concatMap (\cs -> case cs of ('_':_) -> "_" _ -> cs @@ -259,209 +275,240 @@ mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index]) ----------------------------------------------------------------------------- -- Functions dealing with VHDL types ----------------------------------------------------------------------------- - --- | Maps the string name (OccName) of a type to the corresponding VHDL type, --- for a few builtin types. +builtin_types :: TypeMap builtin_types = Map.fromList [ - ("Bit", Just std_logicTM), - ("Bool", Just booleanTM), -- TysWiredIn.boolTy - ("Dec", Just integerTM) + (BuiltinType "Bit", Just (std_logicTM, Nothing)), + (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy ] --- 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. Returns Nothing when the type is valid, but empty. -vhdl_ty :: (TypedThing t, Outputable.Outputable t) => - String -> t -> TypeSession (Maybe 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 :: (TypedThing t, Outputable.Outputable t) => - t -> TypeSession (Either String (Maybe AST.TypeMark)) -vhdl_ty_either tything = - case getType tything of - Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything - Just ty -> vhdl_ty_either' ty +-- Is the given type representable at runtime? +isReprType :: Type.Type -> TypeSession Bool +isReprType ty = do + ty_either <- mkHTypeEither ty + return $ case ty_either of + Left _ -> False + Right _ -> True -vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark)) -vhdl_ty_either' ty = do - typemap <- getA tsTypes - htype_either <- mkHType ty +-- | Turn a Core type into a HType, returning an error using the given +-- error string if the type was not representable. +mkHType :: (TypedThing t, Outputable.Outputable t) => + String -> t -> TypeSession HType +mkHType msg ty = do + htype_either <- mkHTypeEither 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 = (Monad.liftM $ 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_either <- (construct_vhdl_ty ty) - case newty_either of - Right newty -> do - -- TODO: Check name uniqueness - modA tsTypes (Map.insert htype newty) - case newty of - Just (ty_id, ty_def) -> do - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) - return (Right $ Just ty_id) - Nothing -> return $ Right Nothing - Left err -> return $ Left $ - "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n" - ++ err - -- Error when constructing htype - Left err -> return $ Left err + Right htype -> return htype + Left err -> error $ msg ++ err + +-- | Turn a Core type into a HType. Returns either an error message if +-- the type was not representable, or the HType generated. +mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => + t -> TypeSession (Either String HType) +mkHTypeEither tything = + case getType tything of + Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything + Just ty -> mkHTypeEither' ty --- 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 (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) --- State types don't generate VHDL -construct_vhdl_ty ty | isStateType ty = return $ Right Nothing -construct_vhdl_ty ty = do +mkHTypeEither' :: Type.Type -> TypeSession (Either String HType) +mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty + | isStateType ty = return $ Right StateType + | otherwise = case Type.splitTyConApp_maybe ty of Just (tycon, args) -> do + typemap <- MonadState.get tsTypes 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 ty tycon args - Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n") + let builtinTyMaybe = Map.lookup (BuiltinType name) typemap + case builtinTyMaybe of + (Just x) -> return $ Right $ BuiltinType name + Nothing -> + case name of + "TFVec" -> do + let el_ty = tfvec_elem ty + elem_htype_either <- mkHTypeEither 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 $ + "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ 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 -> + mkTyConHType tycon args + Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty --- | Create VHDL type for a custom tycon -mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -mk_tycon_ty ty tycon args = +mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType) +mkTyConHType 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") + [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon [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 + let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys + elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate + case Either.partitionEithers elem_htys_either of + ([], [elem_hty]) -> + return $ Right elem_hty -- No errors in element types - ([], elem_tys') -> do - -- Throw away all empty members - case Maybe.catMaybes elem_tys' of - [] -> -- No non-empty members - return $ Right Nothing - 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 - let tupshow = mkTupleShow elem_tys ty_id - modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow) - return $ Right $ Just (ty_id, Left ty_def) + ([], elem_htys) -> + return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys -- 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" + "\nVHDLTools.mkTyConHType: 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" + dcs -> do + let arg_tys = concatMap DataCon.dataConRepArgTys dcs + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + case real_arg_tys of + [] -> + return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs) + xs -> return $ Left $ + "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\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 - -- to work so far, though.. tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) + +-- 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. Returns Nothing when the type is valid, but empty. +vhdlTy :: (TypedThing t, Outputable.Outputable t) => + String -> t -> TypeSession (Maybe AST.TypeMark) +vhdlTy msg ty = do + htype <- mkHType msg ty + vhdlTyMaybe htype + +vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark) +vhdlTyMaybe htype = do + typemap <- MonadState.get tsTypes + -- If not a builtin type, try the custom types + let existing_ty = Map.lookup htype typemap + case existing_ty of + -- Found a type, return it + Just (Just (t, _)) -> return $ Just t + Just (Nothing) -> return Nothing + -- No type yet, try to construct it + Nothing -> do + newty <- (construct_vhdl_ty htype) + MonadState.modify tsTypes (Map.insert htype newty) + case newty of + Just (ty_id, ty_def) -> do + MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) + return $ Just ty_id + Nothing -> return Nothing + +-- Construct a new VHDL type for the given Haskell type. Returns an error +-- message or the resulting typemark and typedef. +construct_vhdl_ty :: HType -> TypeSession TypeMapRec +-- State types don't generate VHDL +construct_vhdl_ty htype = + case htype of + StateType -> return Nothing + (SizedWType w) -> mkUnsignedTy w + (SizedIType i) -> mkSignedTy i + (RangedWType u) -> mkNaturalTy 0 u + (VecType n e) -> mkVectorTy (VecType n e) + -- Create a custom type from this tycon + otherwise -> mkTyconTy htype + +-- | Create VHDL type for a custom tycon +mkTyconTy :: HType -> TypeSession TypeMapRec +mkTyconTy htype = + case htype of + (AggrType tycon args) -> do + elemTysMaybe <- mapM vhdlTyMaybe args + case Maybe.catMaybes elemTysMaybe of + [] -> -- No non-empty members + return Nothing + elem_tys -> do + let elems = zipWith AST.ElementDec recordlabels elem_tys + let elem_names = concatMap prettyShow elem_tys + let ty_id = mkVHDLExtId $ tycon ++ elem_names + let ty_def = AST.TDR $ AST.RecordTypeDef elems + let tupshow = mkTupleShow elem_tys ty_id + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow) + return $ Just (ty_id, Just $ Left ty_def) + (EnumType tycon dcs) -> do + let elems = map mkVHDLExtId dcs + let ty_id = mkVHDLExtId tycon + let ty_def = AST.TDE $ AST.EnumTypeDef elems + let enumShow = mkEnumShow elems ty_id + MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) + return $ Just (ty_id, Just $ Left ty_def) + otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype + where -- Generate a bunch of labels for fields of a record recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] -- | Create a VHDL vector type -mk_vector_ty :: - Type.Type -- ^ The Haskell type of the Vector - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) +mkVectorTy :: + HType -- ^ The Haskell type of the Vector + -> TypeSession TypeMapRec -- ^ An error message or The typemark created. -mk_vector_ty ty = do - types_map <- getA tsTypes - env <- getA tsHscEnv - 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 (Just el_ty_tm) -> do - let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) +mkVectorTy (VecType len elHType) = do + typesMap <- MonadState.get tsTypes + elTyTmMaybe <- vhdlTyMaybe elHType + case elTyTmMaybe of + (Just elTyTm) -> do + let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-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 $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map - case existing_elem_ty of + let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap + case existing_uvec_ty of Just (Just t) -> do let ty_def = AST.SubtypeIn t (Just range) - return (Right $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ 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 tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def)))) - modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) - let vecShowFuns = mkVectorShow el_ty_tm vec_id - mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns + let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm) + let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm + MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def)))) + MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))]) + let vecShowFuns = mkVectorShow elTyTm vec_id + mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns let ty_def = AST.SubtypeIn vec_id (Just range) - return (Right $ Just (ty_id, Right ty_def)) - -- Empty element type? Empty vector type then. TODO: Does this make sense? - -- Probably needs changes in the builtin functions as well... - Right Nothing -> return $ Right Nothing - -- 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 :: + return (Just (ty_id, Just $ Right ty_def)) + -- Vector of empty elements becomes empty itself. + Nothing -> return Nothing +mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype + +mkNaturalTy :: Int -- ^ The minimum bound (> 0) -> Int -- ^ The maximum bound (> minimum bound) - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) + -> TypeSession TypeMapRec -- ^ An error message or The typemark created. -mk_natural_ty min_bound max_bound = do +mkNaturalTy min_bound max_bound = do let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound))) let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)] let ty_def = AST.SubtypeIn unsignedTM (Just range) - return (Right $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right ty_def)) -mk_unsigned_ty :: - Type.Type -- ^ Haskell type of the unsigned integer - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -mk_unsigned_ty ty = do - size <- tfp_to_int (sized_word_len_ty ty) +mkUnsignedTy :: + Int -- ^ Haskell type of the unsigned integer + -> TypeSession TypeMapRec +mkUnsignedTy size = do 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 $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right ty_def)) -mk_signed_ty :: - Type.Type -- ^ Haskell type of the signed integer - -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))) -mk_signed_ty ty = do - size <- tfp_to_int (sized_int_len_ty ty) +mkSignedTy :: + Int -- ^ Haskell type of the signed integer + -> TypeSession TypeMapRec +mkSignedTy size = do 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 $ Just (ty_id, Right ty_def)) + return (Just (ty_id, Just $ Right ty_def)) -- Finds the field labels for VHDL type generated for the given Core type, -- which must result in a record type. @@ -469,121 +516,22 @@ 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 + vhdlTy error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef - types <- getA tsTypes + types <- MonadState.get tsTypes -- Assume the type for which we want labels is really translatable - Right htype <- mkHType ty + htype <- mkHType error_msg ty case Map.lookup htype types of - Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems + Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype) Just Nothing -> return [] -- The type is empty - _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty) + Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems + Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty) -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 - +mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem +mytydecl (_, Nothing) = Nothing +mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def +mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def -tfp_to_int :: Type.Type -> TypeSession Int -tfp_to_int ty = do - hscenv <- getA tsHscEnv - let norm_ty = normalise_tfp_int hscenv ty - case Type.splitTyConApp_maybe norm_ty of - Just (tycon, args) -> do - let name = Name.getOccString (TyCon.tyConName tycon) - case name of - "Dec" -> do - len <- tfp_to_int' ty - return len - otherwise -> do - modA tsTfpInts (Map.insert (OrdType norm_ty) (-1)) - return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) - Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) - -tfp_to_int' :: Type.Type -> TypeSession Int -tfp_to_int' ty = do - lens <- getA tsTfpInts - hscenv <- getA tsHscEnv - 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 tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) - return new_len - mkTupleShow :: [AST.TypeMark] -- ^ type of each tuple element -> AST.TypeMark -- ^ type of the tuple @@ -608,6 +556,17 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr] recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] tupSize = length elemTMs +mkEnumShow :: + [AST.VHDLId] + -> AST.TypeMark + -> AST.SubProgBody +mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr] + where + enumPar = AST.unsafeVHDLBasicId "enum" + showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM + showExpr = AST.ReturnSm (Just $ + AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM)) + mkVectorShow :: AST.TypeMark -- ^ elemtype -> AST.TypeMark -- ^ vectype @@ -622,7 +581,7 @@ mkVectorShow elemTM vectorTM = resId = AST.unsafeVHDLBasicId "res" headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM -- return vec(0); - headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName + headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [AST.PrimLit "0"]))) vecSlice init last = AST.PrimName (AST.NSlice (AST.SliceName @@ -708,13 +667,13 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr] AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing ) where - signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar) + signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar) showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM showUnsignedExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing ) where - unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar) + unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar) -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM -- showNaturalExpr = AST.ReturnSm (Just $ -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) @@ -734,7 +693,7 @@ genExprPCall2 entid arg1 arg2 = mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec) mkSigDec bndr = do let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr - type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr) + type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr) case type_mark_maybe of Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing) Nothing -> return Nothing @@ -742,4 +701,4 @@ mkSigDec bndr = do -- | Does the given thing have a non-empty type? hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => t -> TranslatorSession Bool -hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing) +hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)