5 import qualified Data.List as List
6 import qualified Data.Map as Map
7 import qualified Control.Monad as Monad
8 import qualified Control.Arrow as Arrow
9 import qualified Data.Monoid as Monoid
13 import qualified ForSyDe.Backend.VHDL.AST as AST
18 import qualified OccName
21 import qualified TyCon
23 import qualified DataCon
24 import qualified CoreSubst
32 -----------------------------------------------------------------------------
33 -- Functions to generate concurrent statements
34 -----------------------------------------------------------------------------
36 -- Create an unconditional assignment statement
38 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
39 -> AST.Expr -- ^ The expression to assign
40 -> AST.ConcSm -- ^ The resulting concurrent statement
41 mkUncondAssign dst expr = mkAssign dst Nothing expr
43 -- Create a conditional assignment statement
45 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
46 -> AST.Expr -- ^ The condition
47 -> AST.Expr -- ^ The value when true
48 -> AST.Expr -- ^ The value when false
49 -> AST.ConcSm -- ^ The resulting concurrent statement
50 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
52 -- Create a conditional or unconditional assignment statement
54 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
55 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
56 -- and the value to assign when true.
57 AST.Expr -> -- ^ The value to assign when false or no condition
58 AST.ConcSm -- ^ The resulting concurrent statement
59 mkAssign dst cond false_expr =
61 -- I'm not 100% how this assignment AST works, but this gets us what we
63 whenelse = case cond of
64 Just (cond_expr, true_expr) ->
66 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
68 [AST.WhenElse true_wform cond_expr]
70 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
71 dst_name = case dst of
72 Left bndr -> AST.NSimple (varToVHDLId bndr)
74 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
79 [CoreSyn.CoreExpr] -- | The argument that are applied to function
80 -> CoreSyn.CoreBndr -- | The binder in which to store the result
81 -> Entity -- | The entity to map against.
82 -> [AST.AssocElem] -- | The resulting port maps
83 mkAssocElems args res entity =
84 -- Create the actual AssocElems
85 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
87 -- Turn the ports and signals from a map into a flat list. This works,
88 -- since the maps must have an identical form by definition. TODO: Check
90 arg_ports = ent_args entity
91 res_port = ent_res entity
92 -- Extract the id part from the (id, type) tuple
93 ports = map (Monad.liftM fst) (res_port : arg_ports)
94 -- Translate signal numbers into names
95 sigs = (varToString res : map (varToString.exprToVar) args)
97 -- | Create an VHDL port -> signal association
98 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
99 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
100 mkAssocElem Nothing _ = Nothing
102 -- | Create an VHDL port -> signal association
103 mkAssocElemIndexed :: Maybe AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> Maybe AST.AssocElem
104 mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
105 (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
106 mkAssocElemIndexed Nothing _ _ = Nothing
109 String -- ^ The portmap label
110 -> AST.VHDLId -- ^ The entity name
111 -> [AST.AssocElem] -- ^ The port assignments
113 mkComponentInst label entity_id portassigns = AST.CSISm compins
115 -- We always have a clock port, so no need to map it anywhere but here
116 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
117 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
119 -----------------------------------------------------------------------------
120 -- Functions to generate VHDL Exprs
121 -----------------------------------------------------------------------------
123 -- Turn a variable reference into a AST expression
124 varToVHDLExpr :: Var.Var -> AST.Expr
126 case Id.isDataConWorkId_maybe var of
127 Just dc -> dataconToVHDLExpr dc
128 -- This is a dataconstructor.
129 -- Not a datacon, just another signal. Perhaps we should check for
130 -- local/global here as well?
131 Nothing -> AST.PrimName $ AST.NSimple $ varToVHDLId var
133 -- Turn a alternative constructor into an AST expression. For
134 -- dataconstructors, this is only the constructor itself, not any arguments it
135 -- has. Should not be called with a DEFAULT constructor.
136 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
137 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
139 altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
140 altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
142 -- Turn a datacon (without arguments!) into a VHDL expression.
143 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
144 dataconToVHDLExpr dc = AST.PrimLit lit
146 tycon = DataCon.dataConTyCon dc
147 tyname = TyCon.tyConName tycon
148 dcname = DataCon.dataConName dc
149 lit = case Name.getOccString tyname of
150 -- TODO: Do something more robust than string matching
151 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
152 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
154 -----------------------------------------------------------------------------
155 -- Functions dealing with names, variables and ids
156 -----------------------------------------------------------------------------
158 -- Creates a VHDL Id from a binder
162 varToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
164 -- Extracts the binder name as a String
168 varToString = OccName.occNameString . Name.nameOccName . Var.varName
170 -- Get the string version a Var's unique
171 varToStringUniq :: Var.Var -> String
172 varToStringUniq = show . Var.varUnique
174 -- Extracts the string version of the name
175 nameToString :: Name.Name -> String
176 nameToString = OccName.occNameString . Name.nameOccName
178 -- Shortcut for Basic VHDL Ids.
179 -- Can only contain alphanumerics and underscores. The supplied string must be
180 -- a valid basic id, otherwise an error value is returned. This function is
181 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
183 mkVHDLBasicId :: String -> AST.VHDLId
185 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
187 -- Strip invalid characters.
188 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
189 -- Strip leading numbers and underscores
190 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
191 -- Strip multiple adjacent underscores
192 strip_multiscore = concat . map (\cs ->
198 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
199 -- different characters than basic ids, but can never be used to refer to
201 -- Use extended Ids for any values that are taken from the source file.
202 mkVHDLExtId :: String -> AST.VHDLId
204 AST.unsafeVHDLExtId $ strip_invalid s
206 -- Allowed characters, taken from ForSyde's mkVHDLExtId
207 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
208 strip_invalid = filter (`elem` allowed)
210 -- Create a record field selector that selects the given label from the record
211 -- stored in the given binder.
212 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
213 mkSelectedName bndr label =
215 sel_prefix = AST.NSimple $ varToVHDLId bndr
216 sel_suffix = AST.SSimple $ label
218 AST.NSelected $ sel_prefix AST.:.: sel_suffix
220 -----------------------------------------------------------------------------
221 -- Functions dealing with VHDL types
222 -----------------------------------------------------------------------------
224 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
225 -- for a few builtin types.
228 ("Bit", std_logicTM),
229 ("Bool", booleanTM) -- TysWiredIn.boolTy
232 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
233 vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
235 typemap <- getA vsTypes
236 let builtin_ty = do -- See if this is a tycon and lookup its name
237 (tycon, args) <- Type.splitTyConApp_maybe ty
238 let name = Name.getOccString (TyCon.tyConName tycon)
239 Map.lookup name builtin_types
240 -- If not a builtin type, try the custom types
241 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
242 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
243 -- Found a type, return it
245 -- No type yet, try to construct it
247 newty_maybe <- (construct_vhdl_ty ty)
249 Just (ty_id, ty_def) -> do
250 -- TODO: Check name uniqueness
251 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
253 Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
255 -- Construct a new VHDL type for the given Haskell type.
256 construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
257 construct_vhdl_ty ty = do
258 case Type.splitTyConApp_maybe ty of
259 Just (tycon, args) -> do
260 let name = Name.getOccString (TyCon.tyConName tycon)
263 res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
264 return $ Just $ (Arrow.second Right) res
266 -- res <- mk_vector_ty (sized_word_len ty) ty
267 -- return $ Just $ (Arrow.second Left) res
269 res <- mk_natural_ty 0 (ranged_word_bound ty)
270 return $ Just $ (Arrow.second Right) res
271 -- Create a custom type from this tycon
272 otherwise -> mk_tycon_ty tycon args
273 Nothing -> return $ Nothing
275 -- | Create VHDL type for a custom tycon
276 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
277 mk_tycon_ty tycon args =
278 case TyCon.tyConDataCons tycon of
279 -- Not an algebraic type
280 [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
282 let arg_tys = DataCon.dataConRepArgTys dc
283 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
284 -- violation? Or does it only mean not to apply it again to the same
286 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
287 elem_tys <- mapM vhdl_ty real_arg_tys
288 let elems = zipWith AST.ElementDec recordlabels elem_tys
289 -- For a single construct datatype, build a record with one field for
291 -- TODO: Add argument type ids to this, to ensure uniqueness
292 -- TODO: Special handling for tuples?
293 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
294 let ty_def = AST.TDR $ AST.RecordTypeDef elems
295 return $ Just (ty_id, Left ty_def)
296 dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
298 -- Create a subst that instantiates all types passed to the tycon
299 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
300 -- to work so far, though..
301 tyvars = TyCon.tyConTyVars tycon
302 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
303 -- Generate a bunch of labels for fields of a record
304 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
306 -- | Create a VHDL vector type
308 Int -- ^ The length of the vector
309 -> Type.Type -- ^ The Haskell element type of the Vector
310 -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
312 mk_vector_ty len el_ty = do
313 elem_types_map <- getA vsElemTypes
314 el_ty_tm <- vhdl_ty el_ty
315 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
316 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
317 let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
318 case existing_elem_ty of
320 let ty_def = AST.SubtypeIn t (Just range)
321 return (ty_id, ty_def)
323 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
324 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
325 modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
326 --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
327 let ty_def = AST.SubtypeIn vec_id (Just range)
328 return (ty_id, ty_def)
331 Int -- ^ The minimum bound (> 0)
332 -> Int -- ^ The maximum bound (> minimum bound)
333 -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
334 mk_natural_ty min_bound max_bound = do
335 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
336 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
337 let ty_def = AST.SubtypeIn naturalTM (Just range)
338 return (ty_id, ty_def)
340 -- Finds the field labels for VHDL type generated for the given Core type,
341 -- which must result in a record type.
342 getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
343 getFieldLabels ty = do
344 -- Ensure that the type is generated (but throw away it's VHDLId)
346 -- Get the types map, lookup and unpack the VHDL TypeDef
347 types <- getA vsTypes
348 case Map.lookup (OrdType ty) types of
349 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
350 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)