import qualified Control.Arrow as Arrow
import qualified Data.Monoid as Monoid
import Data.Accessor
+import Debug.Trace
-- ForSyDe
import qualified ForSyDe.Backend.VHDL.AST as AST
AST.CSSASm assign
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
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 = (varToString res : map (varToString.exprToVar) 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 -> AST.VHDLId -> AST.VHDLId -> Maybe AST.AssocElem
-mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
+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])))
-mkAssocElemIndexed Nothing _ _ = Nothing
mkComponentInst ::
String -- ^ The portmap label
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 = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+ clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
-----------------------------------------------------------------------------
-- 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 $ varToVHDLId 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 (eval_tfp_int ty))
+ 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 = varToVHDLExpr . exprToVar
-- Turn a alternative constructor into an AST expression. For
-- dataconstructors, this is only the constructor itself, not any arguments it
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
varToVHDLId ::
CoreSyn.CoreBndr
-> AST.VHDLId
-varToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
+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 ::
-- 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 $ varToVHDLId bndr
- sel_suffix = AST.SSimple $ label
- in
- AST.NSelected $ sel_prefix AST.:.: sel_suffix
+mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
+mkSelectedName name label =
+ AST.NSelected $ name AST.:.: (AST.SSimple label)
+
+-- 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])
-----------------------------------------------------------------------------
-- Functions dealing with VHDL types
builtin_types =
Map.fromList [
("Bit", std_logicTM),
- ("Bool", booleanTM) -- TysWiredIn.boolTy
+ ("Bool", booleanTM), -- TysWiredIn.boolTy
+ ("Dec", integerTM)
]
-- Translate a Haskell type to a VHDL type, generating a new type if needed.
-vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
-vhdl_ty ty = do
+vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark
+vhdl_ty msg 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
Just t -> return t
-- No type yet, try to construct it
Nothing -> do
- newty_maybe <- (construct_vhdl_ty ty)
+ 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))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
return ty_id
- Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
+ 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 :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-construct_vhdl_ty ty = do
+construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty msg 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)
+ res <- mk_vector_ty ty
return $ Just $ (Arrow.second Right) res
-- "SizedWord" -> do
-- res <- mk_vector_ty (sized_word_len ty) ty
res <- mk_natural_ty 0 (ranged_word_bound ty)
return $ Just $ (Arrow.second Right) res
-- Create a custom type from this tycon
- otherwise -> mk_tycon_ty tycon args
+ otherwise -> mk_tycon_ty msg tycon args
Nothing -> return $ Nothing
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty tycon args =
+mk_tycon_ty :: String -> TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty msg tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
- [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
+ [] -> error $ "\nVHDLTools.mk_tycon_ty: 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 <- mapM vhdl_ty real_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 ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+ 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 $ "Only single constructor datatypes supported: " ++ pprString tycon
+ dcs -> error $ "\nVHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon
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
+ Type.Type -- ^ The Haskell type of the Vector
-> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-mk_vector_ty len el_ty = do
- elem_types_map <- getA vsElemTypes
- el_ty_tm <- vhdl_ty el_ty
+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
+ 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
+ let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType vec_ty) types_map
case existing_elem_ty of
Just t -> do
let ty_def = AST.SubtypeIn t (Just range)
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))
+ modA vsTypes (Map.insert (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)
getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
getFieldLabels ty = do
-- Ensure that the type is generated (but throw away it's VHDLId)
- vhdl_ty ty
+ 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
Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
- _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+ _ -> 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
projects / matthijs / master-project / cλash.git / blobdiff