1 module CLasH.VHDL.VHDLTools where
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 Control.Monad.Trans.State as State
11 import qualified Data.Monoid as Monoid
16 import qualified Language.VHDL.AST as AST
21 import qualified OccName
24 import qualified IdInfo
25 import qualified TyCon
27 import qualified DataCon
28 import qualified CoreSubst
31 import CLasH.VHDL.VHDLTypes
32 import CLasH.Utils.Core.CoreTools
33 import CLasH.Utils.Pretty
34 import CLasH.VHDL.Constants
36 -----------------------------------------------------------------------------
37 -- Functions to generate concurrent statements
38 -----------------------------------------------------------------------------
40 -- Create an unconditional assignment statement
42 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
43 -> AST.Expr -- ^ The expression to assign
44 -> AST.ConcSm -- ^ The resulting concurrent statement
45 mkUncondAssign dst expr = mkAssign dst Nothing expr
47 -- Create a conditional assignment statement
49 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
50 -> AST.Expr -- ^ The condition
51 -> AST.Expr -- ^ The value when true
52 -> AST.Expr -- ^ The value when false
53 -> AST.ConcSm -- ^ The resulting concurrent statement
54 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
56 -- Create a conditional or unconditional assignment statement
58 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
59 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
60 -- and the value to assign when true.
61 AST.Expr -> -- ^ The value to assign when false or no condition
62 AST.ConcSm -- ^ The resulting concurrent statement
63 mkAssign dst cond false_expr =
65 -- I'm not 100% how this assignment AST works, but this gets us what we
67 whenelse = case cond of
68 Just (cond_expr, true_expr) ->
70 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
72 [AST.WhenElse true_wform cond_expr]
74 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
75 dst_name = case dst of
76 Left bndr -> AST.NSimple (varToVHDLId bndr)
78 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
83 [AST.Expr] -- | The argument that are applied to function
84 -> AST.VHDLName -- | The binder in which to store the result
85 -> Entity -- | The entity to map against.
86 -> [AST.AssocElem] -- | The resulting port maps
87 mkAssocElems args res entity =
88 -- Create the actual AssocElems
89 zipWith mkAssocElem ports sigs
91 -- Turn the ports and signals from a map into a flat list. This works,
92 -- since the maps must have an identical form by definition. TODO: Check
94 arg_ports = ent_args entity
95 res_port = ent_res entity
96 -- Extract the id part from the (id, type) tuple
97 ports = map fst (res_port : arg_ports)
98 -- Translate signal numbers into names
99 sigs = (vhdlNameToVHDLExpr res : args)
101 -- | Create an VHDL port -> signal association
102 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
103 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
105 -- | Create an VHDL port -> signal association
106 mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
107 mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
108 (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
111 String -- ^ The portmap label
112 -> AST.VHDLId -- ^ The entity name
113 -> [AST.AssocElem] -- ^ The port assignments
115 mkComponentInst label entity_id portassigns = AST.CSISm compins
117 -- We always have a clock port, so no need to map it anywhere but here
118 clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
119 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
121 -----------------------------------------------------------------------------
122 -- Functions to generate VHDL Exprs
123 -----------------------------------------------------------------------------
125 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
126 varToVHDLExpr var = do
127 case Id.isDataConWorkId_maybe var of
128 Just dc -> return $ dataconToVHDLExpr dc
129 -- This is a dataconstructor.
130 -- Not a datacon, just another signal. Perhaps we should check for
131 -- local/global here as well?
132 -- Sadly so.. tfp decimals are types, not data constructors, but instances
133 -- should still be translated to integer literals. It is probebly not the
134 -- best solution to translate them here.
135 -- FIXME: Find a better solution for translating instances of tfp integers
137 let ty = Var.varType var
138 case Type.splitTyConApp_maybe ty of
139 Just (tycon, args) ->
140 case Name.getOccString (TyCon.tyConName tycon) of
143 return $ AST.PrimLit $ (show len)
144 otherwise -> return $ 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 core = varToVHDLExpr (exprToVar core)
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
280 htype_either <- mkHType ty
284 let builtin_ty = do -- See if this is a tycon and lookup its name
285 (tycon, args) <- Type.splitTyConApp_maybe ty
286 let name = Name.getOccString (TyCon.tyConName tycon)
287 Map.lookup name builtin_types
288 -- If not a builtin type, try the custom types
289 let existing_ty = (fmap fst) $ Map.lookup htype typemap
290 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
291 -- Found a type, return it
292 Just t -> return (Right t)
293 -- No type yet, try to construct it
295 newty_maybe <- (construct_vhdl_ty ty)
297 Right (ty_id, ty_def) -> do
298 -- TODO: Check name uniqueness
299 modA vsTypes (Map.insert htype (ty_id, ty_def))
300 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
302 Left err -> return $ Left $
303 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
305 -- Error when constructing htype
306 Left err -> return $ Left err
308 -- Construct a new VHDL type for the given Haskell type. Returns an error
309 -- message or the resulting typemark and typedef.
310 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
311 construct_vhdl_ty ty = do
312 case Type.splitTyConApp_maybe ty of
313 Just (tycon, args) -> do
314 let name = Name.getOccString (TyCon.tyConName tycon)
316 "TFVec" -> mk_vector_ty ty
317 "SizedWord" -> mk_unsigned_ty ty
318 "SizedInt" -> mk_signed_ty ty
320 bound <- tfp_to_int (ranged_word_bound_ty ty)
321 mk_natural_ty 0 bound
322 -- Create a custom type from this tycon
323 otherwise -> mk_tycon_ty tycon args
324 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
326 -- | Create VHDL type for a custom tycon
327 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
328 mk_tycon_ty tycon args =
329 case TyCon.tyConDataCons tycon of
330 -- Not an algebraic type
331 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
333 let arg_tys = DataCon.dataConRepArgTys dc
334 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
335 -- violation? Or does it only mean not to apply it again to the same
337 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
338 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
339 case Either.partitionEithers elem_tys_either of
340 -- No errors in element types
342 let elems = zipWith AST.ElementDec recordlabels elem_tys
343 -- For a single construct datatype, build a record with one field for
345 -- TODO: Add argument type ids to this, to ensure uniqueness
346 -- TODO: Special handling for tuples?
347 let elem_names = concat $ map prettyShow elem_tys
348 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
349 let ty_def = AST.TDR $ AST.RecordTypeDef elems
350 return $ Right (ty_id, Left ty_def)
351 -- There were errors in element types
352 (errors, _) -> return $ Left $
353 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
355 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
357 -- Create a subst that instantiates all types passed to the tycon
358 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
359 -- to work so far, though..
360 tyvars = TyCon.tyConTyVars tycon
361 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
362 -- Generate a bunch of labels for fields of a record
363 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
365 -- | Create a VHDL vector type
367 Type.Type -- ^ The Haskell type of the Vector
368 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
369 -- ^ An error message or The typemark created.
372 types_map <- getA vsTypes
374 let (nvec_l, nvec_el) = Type.splitAppTy ty
375 let (nvec, leng) = Type.splitAppTy nvec_l
376 let vec_ty = Type.mkAppTy nvec nvec_el
377 len <- tfp_to_int (tfvec_len_ty ty)
378 let el_ty = tfvec_elem ty
379 el_ty_tm_either <- vhdl_ty_either el_ty
380 case el_ty_tm_either of
381 -- Could create element type
383 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
384 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
385 let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
386 case existing_elem_ty of
388 let ty_def = AST.SubtypeIn t (Just range)
389 return (Right (ty_id, Right ty_def))
391 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
392 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
393 modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
394 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
395 let ty_def = AST.SubtypeIn vec_id (Just range)
396 return (Right (ty_id, Right ty_def))
397 -- Could not create element type
398 Left err -> return $ Left $
399 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
403 Int -- ^ The minimum bound (> 0)
404 -> Int -- ^ The maximum bound (> minimum bound)
405 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
406 -- ^ An error message or The typemark created.
407 mk_natural_ty min_bound max_bound = do
408 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
409 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
410 let ty_def = AST.SubtypeIn naturalTM (Just range)
411 return (Right (ty_id, Right ty_def))
414 Type.Type -- ^ Haskell type of the unsigned integer
415 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
416 mk_unsigned_ty ty = do
417 size <- tfp_to_int (sized_word_len_ty ty)
418 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
419 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
420 let ty_def = AST.SubtypeIn unsignedTM (Just range)
421 return (Right (ty_id, Right ty_def))
424 Type.Type -- ^ Haskell type of the signed integer
425 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
427 size <- tfp_to_int (sized_int_len_ty ty)
428 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
429 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
430 let ty_def = AST.SubtypeIn signedTM (Just range)
431 return (Right (ty_id, Right ty_def))
433 -- Finds the field labels for VHDL type generated for the given Core type,
434 -- which must result in a record type.
435 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
436 getFieldLabels ty = do
437 -- Ensure that the type is generated (but throw away it's VHDLId)
438 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
440 -- Get the types map, lookup and unpack the VHDL TypeDef
441 types <- getA vsTypes
442 -- Assume the type for which we want labels is really translatable
443 Right htype <- mkHType ty
444 case Map.lookup htype types of
445 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
446 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
448 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
449 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
450 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
452 mkHType :: Type.Type -> TypeSession (Either String HType)
454 -- FIXME: Do we really need to do this here again?
455 let builtin_ty = do -- See if this is a tycon and lookup its name
456 (tycon, args) <- Type.splitTyConApp_maybe ty
457 let name = Name.getOccString (TyCon.tyConName tycon)
458 Map.lookup name builtin_types
461 return $ Right $ BuiltinType $ prettyShow typ
463 case Type.splitTyConApp_maybe ty of
464 Just (tycon, args) -> do
465 let name = Name.getOccString (TyCon.tyConName tycon)
468 let el_ty = tfvec_elem ty
469 elem_htype_either <- mkHType el_ty
470 case elem_htype_either of
471 -- Could create element type
472 Right elem_htype -> do
473 len <- tfp_to_int (tfvec_len_ty ty)
474 return $ Right $ VecType len elem_htype
475 -- Could not create element type
476 Left err -> return $ Left $
477 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
480 len <- tfp_to_int (sized_word_len_ty ty)
481 return $ Right $ SizedWType len
483 len <- tfp_to_int (sized_word_len_ty ty)
484 return $ Right $ SizedIType len
486 bound <- tfp_to_int (ranged_word_bound_ty ty)
487 return $ Right $ RangedWType bound
489 mkTyConHType tycon args
490 Nothing -> return $ Right $ StdType $ OrdType ty
492 -- FIXME: Do we really need to do this here again?
493 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
494 mkTyConHType tycon args =
495 case TyCon.tyConDataCons tycon of
496 -- Not an algebraic type
497 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
499 let arg_tys = DataCon.dataConRepArgTys dc
500 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
501 elem_htys_either <- mapM mkHType real_arg_tys
502 case Either.partitionEithers elem_htys_either of
503 -- No errors in element types
504 ([], elem_htys) -> do
505 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
506 -- There were errors in element types
507 (errors, _) -> return $ Left $
508 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
510 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
512 tyvars = TyCon.tyConTyVars tycon
513 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
515 -- Is the given type representable at runtime?
516 isReprType :: Type.Type -> TypeSession Bool
518 ty_either <- vhdl_ty_either ty
519 return $ case ty_either of
523 tfp_to_int :: Type.Type -> TypeSession Int
525 lens <- getA vsTfpInts
526 hscenv <- getA vsHscEnv
527 let norm_ty = normalise_tfp_int hscenv ty
528 let existing_len = Map.lookup (OrdType norm_ty) lens
530 Just len -> return len
532 let new_len = eval_tfp_int hscenv ty
533 modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))