+{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
module CLasH.VHDL.VHDLTools where
-- Standard modules
import qualified Maybe
import qualified Data.Either as Either
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 Type
import qualified DataCon
import qualified CoreSubst
+import qualified Outputable
-- Local imports
import CLasH.VHDL.VHDLTypes
import CLasH.Translator.TranslatorTypes
import CLasH.Utils.Core.CoreTools
+import CLasH.Utils
import CLasH.Utils.Pretty
import CLasH.VHDL.Constants
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 -> []
in
AST.CSSASm assign
+mkAltsAssign ::
+ Either 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
-> Entity -- ^ The entity to map against.
-> [AST.AssocElem] -- ^ The resulting port maps
mkAssocElems args res entity =
- -- Create the actual AssocElems
- zipWith mkAssocElem ports sigs
+ arg_maps ++ (Maybe.maybeToList res_map_maybe)
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
- -- the similar form?
arg_ports = ent_args entity
- res_port = ent_res entity
- -- Extract the id part from the (id, type) tuple
- ports = map fst (res_port : arg_ports)
- -- Translate signal numbers into names
- sigs = (vhdlNameToVHDLExpr res : args)
+ res_port_maybe = ent_res entity
+ -- Create an expression of res to map against the output port
+ res_expr = vhdlNameToVHDLExpr res
+ -- Map each of the input ports
+ arg_maps = zipWith mkAssocElem (map fst arg_ports) args
+ -- Map the output port, if present
+ res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
-- | Create an VHDL port -> signal association
mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
--- | Create an VHDL port -> signal association
-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])))
-
-- | Create an aggregate signal
mkAggregateSignal :: [AST.Expr] -> AST.Expr
mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
where
-- We always have a clock port, so no need to map it anywhere but here
clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
- compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
+ resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
+ compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
-----------------------------------------------------------------------------
-- Functions to generate VHDL Exprs
varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
varToVHDLExpr var = do
case Id.isDataConWorkId_maybe var of
- Just dc -> return $ dataconToVHDLExpr dc
+ Just dc -> dataconToVHDLExpr dc
-- This is a dataconstructor.
-- Not a datacon, just another signal. Perhaps we should check for
-- local/global here as well?
-- 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 :: CoreSyn.AltCon -> TypeSession AST.Expr
altconToVHDLExpr (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!"
-- 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 <- getA tsTypes
+ htype_either <- mkHType (DataCon.dataConRepType dc)
+ case htype_either of
+ -- No errors
+ Right htype -> do
+ let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
+ case existing_ty of
+ Just ty -> do
+ let dcname = DataCon.dataConName dc
+ let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+ return lit
+ Nothing -> do
+ let tycon = DataCon.dataConTyCon dc
+ let tyname = TyCon.tyConName tycon
+ let dcname = DataCon.dataConName dc
+ let 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"
+ return $ AST.PrimLit lit
+ -- Error when constructing htype
+ Left err -> error err
-----------------------------------------------------------------------------
-- Functions dealing with names, variables and ids
varToVHDLId ::
CoreSyn.CoreBndr
-> AST.VHDLId
-varToVHDLId = mkVHDLExtId . varToString
+varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+ where
+ lowers :: String -> Int
+ lowers xs = length [x | x <- xs, Char.isLower x]
-- Creates a VHDL Name from a binder
varToVHDLName ::
AST.unsafeVHDLExtId $ strip_invalid s
where
-- Allowed characters, taken from ForSyde's mkVHDLExtId
- allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+ allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
strip_invalid = filter (`elem` allowed)
-- Create a record field selector that selects the given label from the record
-- 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 :: String -> Type.Type -> TypeSession (Maybe AST.TypeMark)
+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
-- 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 (Maybe AST.TypeMark))
-vhdl_ty_either ty = do
+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
+
+vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty
+ | otherwise = do
typemap <- getA tsTypes
htype_either <- mkHType ty
case htype_either of
-- 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
case Type.splitTyConApp_maybe ty of
Just (tycon, args) -> do
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)
+ let htype = ADTType (nameToString (TyCon.tyConName tycon)) (map (\x -> StdType (OrdType x)) real_arg_tys)
+ modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
return $ Right $ Just (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"
+ dcs -> do
+ let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ case real_arg_tys of
+ [] -> do
+ let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
+ let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+ let ty_def = AST.TDE $ AST.EnumTypeDef elems
+ let enumShow = mkEnumShow elems ty_id
+ let htype = EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
+ modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
+ return $ Right $ Just (ty_id, Left ty_def)
+ 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
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
+ mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, 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?
-> TypeSession (Either String (Maybe (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)
+ 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))
mk_unsigned_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)
- let unsignedshow = mkIntegerShow ty_id
- modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
return (Right $ Just (ty_id, Right ty_def))
mk_signed_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)
- let signedshow = mkIntegerShow ty_id
- modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
return (Right $ Just (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
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"
+ [] -> return $ Left $ "VHDLTools.mkTyConHType: 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
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"
+ "VHDLTools.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.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+ dcs -> do
+ let arg_tys = concat $ map 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
tyvars = TyCon.tyConTyVars tycon
subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
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
genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
AST.PrimLit "'>'" )
-mkIntegerShow ::
- AST.TypeMark -- ^ The specific signed
- -> AST.SubProgBody
-mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
- where
- signedPar = AST.unsafeVHDLBasicId "sint"
- showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
- showExpr = AST.ReturnSm (Just $
- 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)
-
mkBuiltInShow :: [AST.SubProgBody]
mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
, AST.SubProgBody showBoolSpec [] [showBoolExpr]
+ , AST.SubProgBody showSingedSpec [] [showSignedExpr]
+ , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
+ -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
]
where
- bitPar = AST.unsafeVHDLBasicId "s"
- boolPar = AST.unsafeVHDLBasicId "b"
+ bitPar = AST.unsafeVHDLBasicId "s"
+ boolPar = AST.unsafeVHDLBasicId "b"
+ signedPar = AST.unsafeVHDLBasicId "sint"
+ unsignedPar = AST.unsafeVHDLBasicId "uint"
+ -- naturalPar = AST.unsafeVHDLBasicId "nat"
showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
-- if s = '1' then return "'1'" else return "'0'"
showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
[AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
[]
(Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
+ showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+ showSignedExpr = AST.ReturnSm (Just $
+ 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)
+ 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)
+ -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
+ -- showNaturalExpr = AST.ReturnSm (Just $
+ -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+ -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
+
genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
genExprFCall fName args =
case type_mark_maybe of
Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
Nothing -> return Nothing
+
+-- | 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)
projects / matthijs / master-project / cλash.git / blobdiff