5 import qualified Data.Either as Either
6 import qualified Data.List as List
7 import qualified Data.Map as Map
8 import qualified Control.Monad as Monad
9 import qualified Control.Arrow as Arrow
10 import qualified Data.Monoid as Monoid
15 import qualified ForSyDe.Backend.VHDL.AST as AST
20 import qualified OccName
23 import qualified TyCon
25 import qualified DataCon
26 import qualified CoreSubst
34 -----------------------------------------------------------------------------
35 -- Functions to generate concurrent statements
36 -----------------------------------------------------------------------------
38 -- Create an unconditional assignment statement
40 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
41 -> AST.Expr -- ^ The expression to assign
42 -> AST.ConcSm -- ^ The resulting concurrent statement
43 mkUncondAssign dst expr = mkAssign dst Nothing expr
45 -- Create a conditional assignment statement
47 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
48 -> AST.Expr -- ^ The condition
49 -> AST.Expr -- ^ The value when true
50 -> AST.Expr -- ^ The value when false
51 -> AST.ConcSm -- ^ The resulting concurrent statement
52 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
54 -- Create a conditional or unconditional assignment statement
56 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
57 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
58 -- and the value to assign when true.
59 AST.Expr -> -- ^ The value to assign when false or no condition
60 AST.ConcSm -- ^ The resulting concurrent statement
61 mkAssign dst cond false_expr =
63 -- I'm not 100% how this assignment AST works, but this gets us what we
65 whenelse = case cond of
66 Just (cond_expr, true_expr) ->
68 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
70 [AST.WhenElse true_wform cond_expr]
72 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
73 dst_name = case dst of
74 Left bndr -> AST.NSimple (varToVHDLId bndr)
76 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
81 [AST.Expr] -- | The argument that are applied to function
82 -> AST.VHDLName -- | The binder in which to store the result
83 -> Entity -- | The entity to map against.
84 -> [AST.AssocElem] -- | The resulting port maps
85 mkAssocElems args res entity =
86 -- Create the actual AssocElems
87 zipWith mkAssocElem ports sigs
89 -- Turn the ports and signals from a map into a flat list. This works,
90 -- since the maps must have an identical form by definition. TODO: Check
92 arg_ports = ent_args entity
93 res_port = ent_res entity
94 -- Extract the id part from the (id, type) tuple
95 ports = map fst (res_port : arg_ports)
96 -- Translate signal numbers into names
97 sigs = (vhdlNameToVHDLExpr res : args)
99 -- | Create an VHDL port -> signal association
100 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
101 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
103 -- | Create an VHDL port -> signal association
104 mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
105 mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
106 (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
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 = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "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 -- Sadly so.. tfp decimals are types, not data constructors, but instances
132 -- should still be translated to integer literals. It is probebly not the
133 -- best solution to translate them here.
134 -- FIXME: Find a better solution for translating instances of tfp integers
138 res = case Type.splitTyConApp_maybe ty of
139 Just (tycon, args) ->
140 case Name.getOccString (TyCon.tyConName tycon) of
141 "Dec" -> AST.PrimLit $ (show (eval_tfp_int ty))
142 otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
146 -- Turn a VHDLName into an AST expression
147 vhdlNameToVHDLExpr = AST.PrimName
149 -- Turn a VHDL Id into an AST expression
150 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
152 -- Turn a Core expression into an AST expression
153 exprToVHDLExpr = varToVHDLExpr . exprToVar
155 -- Turn a alternative constructor into an AST expression. For
156 -- dataconstructors, this is only the constructor itself, not any arguments it
157 -- has. Should not be called with a DEFAULT constructor.
158 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
159 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
161 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
162 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
164 -- Turn a datacon (without arguments!) into a VHDL expression.
165 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
166 dataconToVHDLExpr dc = AST.PrimLit lit
168 tycon = DataCon.dataConTyCon dc
169 tyname = TyCon.tyConName tycon
170 dcname = DataCon.dataConName dc
171 lit = case Name.getOccString tyname of
172 -- TODO: Do something more robust than string matching
173 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
174 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
176 -----------------------------------------------------------------------------
177 -- Functions dealing with names, variables and ids
178 -----------------------------------------------------------------------------
180 -- Creates a VHDL Id from a binder
184 varToVHDLId = mkVHDLExtId . varToString
186 -- Creates a VHDL Name from a binder
190 varToVHDLName = AST.NSimple . varToVHDLId
192 -- Extracts the binder name as a String
196 varToString = OccName.occNameString . Name.nameOccName . Var.varName
198 -- Get the string version a Var's unique
199 varToStringUniq :: Var.Var -> String
200 varToStringUniq = show . Var.varUnique
202 -- Extracts the string version of the name
203 nameToString :: Name.Name -> String
204 nameToString = OccName.occNameString . Name.nameOccName
206 -- Shortcut for Basic VHDL Ids.
207 -- Can only contain alphanumerics and underscores. The supplied string must be
208 -- a valid basic id, otherwise an error value is returned. This function is
209 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
211 mkVHDLBasicId :: String -> AST.VHDLId
213 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
215 -- Strip invalid characters.
216 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
217 -- Strip leading numbers and underscores
218 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
219 -- Strip multiple adjacent underscores
220 strip_multiscore = concat . map (\cs ->
226 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
227 -- different characters than basic ids, but can never be used to refer to
229 -- Use extended Ids for any values that are taken from the source file.
230 mkVHDLExtId :: String -> AST.VHDLId
232 AST.unsafeVHDLExtId $ strip_invalid s
234 -- Allowed characters, taken from ForSyde's mkVHDLExtId
235 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
236 strip_invalid = filter (`elem` allowed)
238 -- Create a record field selector that selects the given label from the record
239 -- stored in the given binder.
240 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
241 mkSelectedName name label =
242 AST.NSelected $ name AST.:.: (AST.SSimple label)
244 -- Create an indexed name that selects a given element from a vector.
245 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
246 -- Special case for already indexed names. Just add an index
247 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
248 AST.NIndexed (AST.IndexedName name (indexes++[index]))
249 -- General case for other names
250 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
252 -----------------------------------------------------------------------------
253 -- Functions dealing with VHDL types
254 -----------------------------------------------------------------------------
256 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
257 -- for a few builtin types.
260 ("Bit", std_logicTM),
261 ("Bool", booleanTM), -- TysWiredIn.boolTy
265 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
266 -- Returns an error value, using the given message, when no type could be
268 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
270 tm_either <- vhdl_ty_either ty
272 Right tm -> return tm
273 Left err -> error $ msg ++ "\n" ++ err
275 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
276 -- Returns either an error message or the resulting type.
277 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
278 vhdl_ty_either ty = do
279 typemap <- getA vsTypes
281 let builtin_ty = do -- See if this is a tycon and lookup its name
282 (tycon, args) <- Type.splitTyConApp_maybe ty
283 let name = Name.getOccString (TyCon.tyConName tycon)
284 Map.lookup name builtin_types
285 -- If not a builtin type, try the custom types
286 let existing_ty = (fmap fst) $ Map.lookup htype typemap
287 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
288 -- Found a type, return it
289 Just t -> return (Right t)
290 -- No type yet, try to construct it
292 newty_maybe <- (construct_vhdl_ty ty)
294 Right (ty_id, ty_def) -> do
295 -- TODO: Check name uniqueness
296 modA vsTypes (Map.insert htype (ty_id, ty_def))
297 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
299 Left err -> return $ Left $
300 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
303 -- Construct a new VHDL type for the given Haskell type. Returns an error
304 -- message or the resulting typemark and typedef.
305 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
306 construct_vhdl_ty ty = do
307 case Type.splitTyConApp_maybe ty of
308 Just (tycon, args) -> do
309 let name = Name.getOccString (TyCon.tyConName tycon)
311 "TFVec" -> mk_vector_ty ty
313 -- res <- mk_vector_ty (sized_word_len ty) ty
314 -- return $ Just $ (Arrow.second Left) res
315 "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
316 -- Create a custom type from this tycon
317 otherwise -> mk_tycon_ty tycon args
318 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
320 -- | Create VHDL type for a custom tycon
321 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
322 mk_tycon_ty tycon args =
323 case TyCon.tyConDataCons tycon of
324 -- Not an algebraic type
325 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
327 let arg_tys = DataCon.dataConRepArgTys dc
328 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
329 -- violation? Or does it only mean not to apply it again to the same
331 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
332 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
333 case Either.partitionEithers elem_tys_either of
334 -- No errors in element types
336 let elems = zipWith AST.ElementDec recordlabels elem_tys
337 -- For a single construct datatype, build a record with one field for
339 -- TODO: Add argument type ids to this, to ensure uniqueness
340 -- TODO: Special handling for tuples?
341 let elem_names = concat $ map prettyShow elem_tys
342 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
343 let ty_def = AST.TDR $ AST.RecordTypeDef elems
344 return $ Right (ty_id, Left ty_def)
345 -- There were errors in element types
346 (errors, _) -> return $ Left $
347 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
349 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
351 -- Create a subst that instantiates all types passed to the tycon
352 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
353 -- to work so far, though..
354 tyvars = TyCon.tyConTyVars tycon
355 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
356 -- Generate a bunch of labels for fields of a record
357 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
359 -- | Create a VHDL vector type
361 Type.Type -- ^ The Haskell type of the Vector
362 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
363 -- ^ An error message or The typemark created.
366 types_map <- getA vsTypes
367 let (nvec_l, nvec_el) = Type.splitAppTy ty
368 let (nvec, leng) = Type.splitAppTy nvec_l
369 let vec_ty = Type.mkAppTy nvec nvec_el
370 let len = tfvec_len ty
371 let el_ty = tfvec_elem ty
372 el_ty_tm_either <- vhdl_ty_either el_ty
373 case el_ty_tm_either of
374 -- Could create element type
376 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
377 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
378 let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
379 case existing_elem_ty of
381 let ty_def = AST.SubtypeIn t (Just range)
382 return (Right (ty_id, Right ty_def))
384 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
385 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
386 modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
387 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
388 let ty_def = AST.SubtypeIn vec_id (Just range)
389 return (Right (ty_id, Right ty_def))
390 -- Could not create element type
391 Left err -> return $ Left $
392 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
396 Int -- ^ The minimum bound (> 0)
397 -> Int -- ^ The maximum bound (> minimum bound)
398 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
399 -- ^ An error message or The typemark created.
400 mk_natural_ty min_bound max_bound = do
401 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
402 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
403 let ty_def = AST.SubtypeIn naturalTM (Just range)
404 return (Right (ty_id, Right ty_def))
406 -- Finds the field labels for VHDL type generated for the given Core type,
407 -- which must result in a record type.
408 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
409 getFieldLabels ty = do
410 -- Ensure that the type is generated (but throw away it's VHDLId)
411 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
413 -- Get the types map, lookup and unpack the VHDL TypeDef
414 types <- getA vsTypes
416 case Map.lookup htype types of
417 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
418 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
420 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
421 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
422 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
424 mkHType :: Type.Type -> TypeSession HType
426 -- FIXME: Do we really need to do this here again?
427 let builtin_ty = do -- See if this is a tycon and lookup its name
428 (tycon, args) <- Type.splitTyConApp_maybe ty
429 let name = Name.getOccString (TyCon.tyConName tycon)
430 Map.lookup name builtin_types
433 return $ BuiltinType $ prettyShow typ
435 case Type.splitTyConApp_maybe ty of
436 Just (tycon, args) -> do
437 let name = Name.getOccString (TyCon.tyConName tycon)
440 elem_htype <- mkHType (tfvec_elem ty)
441 return $ VecType (tfvec_len ty) elem_htype
443 mkTyConHType tycon args
444 Nothing -> return $ StdType $ OrdType ty
446 -- FIXME: Do we really need to do this here again?
447 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType
448 mkTyConHType tycon args =
449 case TyCon.tyConDataCons tycon of
450 -- Not an algebraic type
451 [] -> error $ "\nVHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon
453 let arg_tys = DataCon.dataConRepArgTys dc
454 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
455 elem_htys <- mapM mkHType real_arg_tys
456 return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
457 dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
459 tyvars = TyCon.tyConTyVars tycon
460 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)