5 import qualified Data.List as List
6 import qualified Data.Map as Map
7 import qualified Control.Monad as Monad
10 import qualified ForSyDe.Backend.VHDL.AST as AST
15 import qualified OccName
18 import qualified TyCon
19 import qualified DataCon
25 -- Create an unconditional assignment statement
27 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
28 -> AST.Expr -- ^ The expression to assign
29 -> AST.ConcSm -- ^ The resulting concurrent statement
30 mkUncondAssign dst expr = mkAssign dst Nothing expr
32 -- Create a conditional assignment statement
34 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
35 -> AST.Expr -- ^ The condition
36 -> AST.Expr -- ^ The value when true
37 -> AST.Expr -- ^ The value when false
38 -> AST.ConcSm -- ^ The resulting concurrent statement
39 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
41 -- Create a conditional or unconditional assignment statement
43 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
44 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
45 -- and the value to assign when true.
46 AST.Expr -> -- ^ The value to assign when false or no condition
47 AST.ConcSm -- ^ The resulting concurrent statement
48 mkAssign dst cond false_expr =
50 -- I'm not 100% how this assignment AST works, but this gets us what we
52 whenelse = case cond of
53 Just (cond_expr, true_expr) ->
55 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
57 [AST.WhenElse true_wform cond_expr]
59 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
60 dst_name = case dst of
61 Left bndr -> AST.NSimple (bndrToVHDLId bndr)
63 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
67 -- Create a record field selector that selects the given label from the record
68 -- stored in the given binder.
69 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
70 mkSelectedName bndr label =
72 sel_prefix = AST.NSimple $ bndrToVHDLId bndr
73 sel_suffix = AST.SSimple $ label
75 AST.NSelected $ sel_prefix AST.:.: sel_suffix
78 [CoreSyn.CoreExpr] -- | The argument that are applied to function
79 -> CoreSyn.CoreBndr -- | The binder in which to store the result
80 -> Entity -- | The entity to map against.
81 -> [AST.AssocElem] -- | The resulting port maps
82 mkAssocElems args res entity =
83 -- Create the actual AssocElems
84 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
86 -- Turn the ports and signals from a map into a flat list. This works,
87 -- since the maps must have an identical form by definition. TODO: Check
89 arg_ports = ent_args entity
90 res_port = ent_res entity
91 -- Extract the id part from the (id, type) tuple
92 ports = map (Monad.liftM fst) (res_port : arg_ports)
93 -- Translate signal numbers into names
94 sigs = (bndrToString res : map (bndrToString.varBndr) args)
96 -- | Create an VHDL port -> signal association
97 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
98 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
99 mkAssocElem Nothing _ = Nothing
101 -- | Create an VHDL port -> signal association
102 mkAssocElemIndexed :: Maybe AST.VHDLId -> String -> AST.VHDLId -> Maybe AST.AssocElem
103 mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
104 (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index])))
105 mkAssocElemIndexed Nothing _ _ = Nothing
107 -- Turn a variable reference into a AST expression
108 varToVHDLExpr :: Var.Var -> AST.Expr
110 case Id.isDataConWorkId_maybe var of
111 Just dc -> dataconToVHDLExpr dc
112 -- This is a dataconstructor.
113 -- Not a datacon, just another signal. Perhaps we should check for
114 -- local/global here as well?
115 Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var
117 -- Turn a alternative constructor into an AST expression. For
118 -- dataconstructors, this is only the constructor itself, not any arguments it
119 -- has. Should not be called with a DEFAULT constructor.
120 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
121 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
123 altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
124 altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
126 -- Turn a datacon (without arguments!) into a VHDL expression.
127 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
128 dataconToVHDLExpr dc = AST.PrimLit lit
130 tycon = DataCon.dataConTyCon dc
131 tyname = TyCon.tyConName tycon
132 dcname = DataCon.dataConName dc
133 lit = case Name.getOccString tyname of
134 -- TODO: Do something more robust than string matching
135 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
136 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
138 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
139 -- simple Var CoreExprs, not complexer ones.
140 varBndr :: CoreSyn.CoreExpr -> Var.Id
141 varBndr (CoreSyn.Var id) = id
144 -- Can only contain alphanumerics and underscores. The supplied string must be
145 -- a valid basic id, otherwise an error value is returned. This function is
146 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
148 mkVHDLBasicId :: String -> AST.VHDLId
150 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
152 -- Strip invalid characters.
153 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
154 -- Strip leading numbers and underscores
155 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
156 -- Strip multiple adjacent underscores
157 strip_multiscore = concat . map (\cs ->
163 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
164 -- different characters than basic ids, but can never be used to refer to
166 -- Use extended Ids for any values that are taken from the source file.
167 mkVHDLExtId :: String -> AST.VHDLId
169 AST.unsafeVHDLExtId $ strip_invalid s
171 -- Allowed characters, taken from ForSyde's mkVHDLExtId
172 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
173 strip_invalid = filter (`elem` allowed)
175 -- Creates a VHDL Id from a binder
179 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
181 -- Extracts the binder name as a String
185 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
187 -- Get the string version a Var's unique
188 varToStringUniq :: Var.Var -> String
189 varToStringUniq = show . Var.varUnique
191 -- Extracts the string version of the name
192 nameToString :: Name.Name -> String
193 nameToString = OccName.occNameString . Name.nameOccName
195 recordlabels :: [AST.VHDLId]
196 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
198 getVectorLen :: CoreSyn.CoreBndr -> Int
199 getVectorLen bndr = len
201 ty = Var.varType bndr
205 String -- ^ The portmap label
206 -> AST.VHDLId -- ^ The entity name
207 -> [AST.AssocElem] -- ^ The port assignments
209 genComponentInst label entity_id portassigns = AST.CSISm compins
211 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portassigns)
213 -- | The VHDL Bit type
214 bit_ty :: AST.TypeMark
215 bit_ty = AST.unsafeVHDLBasicId "Bit"
217 -- | The VHDL Boolean type
218 bool_ty :: AST.TypeMark
219 bool_ty = AST.unsafeVHDLBasicId "Boolean"
221 -- | The VHDL std_logic
222 std_logic_ty :: AST.TypeMark
223 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
227 ("Bit", std_logic_ty),
228 ("Bool", bool_ty) -- TysWiredIn.boolTy
232 -- | Map a port specification of a builtin function to a VHDL Signal to put in
234 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
235 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)