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 ForSyDe.Backend.VHDL.AST as AST
21 import qualified OccName
24 import qualified IdInfo
25 import qualified TyCon
27 import qualified DataCon
28 import qualified CoreSubst
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 -- Turn a variable reference into a AST expression
126 varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr
127 varToVHDLExpr ty_state var =
128 case Id.isDataConWorkId_maybe var of
129 Just dc -> dataconToVHDLExpr dc
130 -- This is a dataconstructor.
131 -- Not a datacon, just another signal. Perhaps we should check for
132 -- local/global here as well?
133 -- Sadly so.. tfp decimals are types, not data constructors, but instances
134 -- should still be translated to integer literals. It is probebly not the
135 -- best solution to translate them here.
136 -- FIXME: Find a better solution for translating instances of tfp integers
140 res = case Type.splitTyConApp_maybe ty of
141 Just (tycon, args) ->
142 case Name.getOccString (TyCon.tyConName tycon) of
143 "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) )
144 otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
149 -- Turn a VHDLName into an AST expression
150 vhdlNameToVHDLExpr = AST.PrimName
152 -- Turn a VHDL Id into an AST expression
153 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
155 -- Turn a Core expression into an AST expression
156 exprToVHDLExpr ty_state = (varToVHDLExpr ty_state) . exprToVar
158 -- Turn a alternative constructor into an AST expression. For
159 -- dataconstructors, this is only the constructor itself, not any arguments it
160 -- has. Should not be called with a DEFAULT constructor.
161 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
162 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
164 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
165 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
167 -- Turn a datacon (without arguments!) into a VHDL expression.
168 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
169 dataconToVHDLExpr dc = AST.PrimLit lit
171 tycon = DataCon.dataConTyCon dc
172 tyname = TyCon.tyConName tycon
173 dcname = DataCon.dataConName dc
174 lit = case Name.getOccString tyname of
175 -- TODO: Do something more robust than string matching
176 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
177 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
179 -----------------------------------------------------------------------------
180 -- Functions dealing with names, variables and ids
181 -----------------------------------------------------------------------------
183 -- Creates a VHDL Id from a binder
187 varToVHDLId = mkVHDLExtId . varToString
189 -- Creates a VHDL Name from a binder
193 varToVHDLName = AST.NSimple . varToVHDLId
195 -- Extracts the binder name as a String
199 varToString = OccName.occNameString . Name.nameOccName . Var.varName
201 -- Get the string version a Var's unique
202 varToStringUniq :: Var.Var -> String
203 varToStringUniq = show . Var.varUnique
205 -- Extracts the string version of the name
206 nameToString :: Name.Name -> String
207 nameToString = OccName.occNameString . Name.nameOccName
209 -- Shortcut for Basic VHDL Ids.
210 -- Can only contain alphanumerics and underscores. The supplied string must be
211 -- a valid basic id, otherwise an error value is returned. This function is
212 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
214 mkVHDLBasicId :: String -> AST.VHDLId
216 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
218 -- Strip invalid characters.
219 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
220 -- Strip leading numbers and underscores
221 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
222 -- Strip multiple adjacent underscores
223 strip_multiscore = concat . map (\cs ->
229 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
230 -- different characters than basic ids, but can never be used to refer to
232 -- Use extended Ids for any values that are taken from the source file.
233 mkVHDLExtId :: String -> AST.VHDLId
235 AST.unsafeVHDLExtId $ strip_invalid s
237 -- Allowed characters, taken from ForSyde's mkVHDLExtId
238 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
239 strip_invalid = filter (`elem` allowed)
241 -- Create a record field selector that selects the given label from the record
242 -- stored in the given binder.
243 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
244 mkSelectedName name label =
245 AST.NSelected $ name AST.:.: (AST.SSimple label)
247 -- Create an indexed name that selects a given element from a vector.
248 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
249 -- Special case for already indexed names. Just add an index
250 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
251 AST.NIndexed (AST.IndexedName name (indexes++[index]))
252 -- General case for other names
253 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
255 -----------------------------------------------------------------------------
256 -- Functions dealing with VHDL types
257 -----------------------------------------------------------------------------
259 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
260 -- for a few builtin types.
263 ("Bit", std_logicTM),
264 ("Bool", booleanTM), -- TysWiredIn.boolTy
268 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
269 -- Returns an error value, using the given message, when no type could be
271 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
273 tm_either <- vhdl_ty_either ty
275 Right tm -> return tm
276 Left err -> error $ msg ++ "\n" ++ err
278 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
279 -- Returns either an error message or the resulting type.
280 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
281 vhdl_ty_either ty = do
282 typemap <- getA vsTypes
283 htype_either <- mkHType ty
287 let builtin_ty = do -- See if this is a tycon and lookup its name
288 (tycon, args) <- Type.splitTyConApp_maybe ty
289 let name = Name.getOccString (TyCon.tyConName tycon)
290 Map.lookup name builtin_types
291 -- If not a builtin type, try the custom types
292 let existing_ty = (fmap fst) $ Map.lookup htype typemap
293 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
294 -- Found a type, return it
295 Just t -> return (Right t)
296 -- No type yet, try to construct it
298 newty_maybe <- (construct_vhdl_ty ty)
300 Right (ty_id, ty_def) -> do
301 -- TODO: Check name uniqueness
302 modA vsTypes (Map.insert htype (ty_id, ty_def))
303 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
305 Left err -> return $ Left $
306 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
308 -- Error when constructing htype
309 Left err -> return $ Left err
311 -- Construct a new VHDL type for the given Haskell type. Returns an error
312 -- message or the resulting typemark and typedef.
313 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
314 construct_vhdl_ty ty = do
315 case Type.splitTyConApp_maybe ty of
316 Just (tycon, args) -> do
317 let name = Name.getOccString (TyCon.tyConName tycon)
319 "TFVec" -> mk_vector_ty ty
320 "SizedWord" -> mk_unsigned_ty ty
321 "SizedInt" -> mk_signed_ty ty
323 bound <- tfp_to_int (ranged_word_bound_ty ty)
324 mk_natural_ty 0 bound
325 -- Create a custom type from this tycon
326 otherwise -> mk_tycon_ty tycon args
327 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
329 -- | Create VHDL type for a custom tycon
330 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
331 mk_tycon_ty tycon args =
332 case TyCon.tyConDataCons tycon of
333 -- Not an algebraic type
334 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
336 let arg_tys = DataCon.dataConRepArgTys dc
337 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
338 -- violation? Or does it only mean not to apply it again to the same
340 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
341 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
342 case Either.partitionEithers elem_tys_either of
343 -- No errors in element types
345 let elems = zipWith AST.ElementDec recordlabels elem_tys
346 -- For a single construct datatype, build a record with one field for
348 -- TODO: Add argument type ids to this, to ensure uniqueness
349 -- TODO: Special handling for tuples?
350 let elem_names = concat $ map prettyShow elem_tys
351 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
352 let ty_def = AST.TDR $ AST.RecordTypeDef elems
353 return $ Right (ty_id, Left ty_def)
354 -- There were errors in element types
355 (errors, _) -> return $ Left $
356 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
358 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
360 -- Create a subst that instantiates all types passed to the tycon
361 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
362 -- to work so far, though..
363 tyvars = TyCon.tyConTyVars tycon
364 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
365 -- Generate a bunch of labels for fields of a record
366 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
368 -- | Create a VHDL vector type
370 Type.Type -- ^ The Haskell type of the Vector
371 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
372 -- ^ An error message or The typemark created.
375 types_map <- getA vsTypes
377 let (nvec_l, nvec_el) = Type.splitAppTy ty
378 let (nvec, leng) = Type.splitAppTy nvec_l
379 let vec_ty = Type.mkAppTy nvec nvec_el
380 len <- tfp_to_int (tfvec_len_ty ty)
381 let el_ty = tfvec_elem ty
382 el_ty_tm_either <- vhdl_ty_either el_ty
383 case el_ty_tm_either of
384 -- Could create element type
386 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
387 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
388 let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
389 case existing_elem_ty of
391 let ty_def = AST.SubtypeIn t (Just range)
392 return (Right (ty_id, Right ty_def))
394 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
395 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
396 modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
397 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
398 let ty_def = AST.SubtypeIn vec_id (Just range)
399 return (Right (ty_id, Right ty_def))
400 -- Could not create element type
401 Left err -> return $ Left $
402 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
406 Int -- ^ The minimum bound (> 0)
407 -> Int -- ^ The maximum bound (> minimum bound)
408 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
409 -- ^ An error message or The typemark created.
410 mk_natural_ty min_bound max_bound = do
411 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
412 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
413 let ty_def = AST.SubtypeIn naturalTM (Just range)
414 return (Right (ty_id, Right ty_def))
417 Type.Type -- ^ Haskell type of the unsigned integer
418 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
419 mk_unsigned_ty ty = do
420 size <- tfp_to_int (sized_word_len_ty ty)
421 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
422 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
423 let ty_def = AST.SubtypeIn unsignedTM (Just range)
424 return (Right (ty_id, Right ty_def))
427 Type.Type -- ^ Haskell type of the signed integer
428 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
430 size <- tfp_to_int (sized_int_len_ty ty)
431 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
432 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
433 let ty_def = AST.SubtypeIn signedTM (Just range)
434 return (Right (ty_id, Right ty_def))
436 -- Finds the field labels for VHDL type generated for the given Core type,
437 -- which must result in a record type.
438 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
439 getFieldLabels ty = do
440 -- Ensure that the type is generated (but throw away it's VHDLId)
441 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
443 -- Get the types map, lookup and unpack the VHDL TypeDef
444 types <- getA vsTypes
445 -- Assume the type for which we want labels is really translatable
446 Right htype <- mkHType ty
447 case Map.lookup htype types of
448 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
449 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
451 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
452 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
453 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
455 mkHType :: Type.Type -> TypeSession (Either String HType)
457 -- FIXME: Do we really need to do this here again?
458 let builtin_ty = do -- See if this is a tycon and lookup its name
459 (tycon, args) <- Type.splitTyConApp_maybe ty
460 let name = Name.getOccString (TyCon.tyConName tycon)
461 Map.lookup name builtin_types
464 return $ Right $ BuiltinType $ prettyShow typ
466 case Type.splitTyConApp_maybe ty of
467 Just (tycon, args) -> do
468 let name = Name.getOccString (TyCon.tyConName tycon)
471 let el_ty = tfvec_elem ty
472 elem_htype_either <- mkHType el_ty
473 case elem_htype_either of
474 -- Could create element type
475 Right elem_htype -> do
477 let norm_ty = normalise_tfp_int env (tfvec_len_ty ty)
478 return $ Right $ VecType (OrdType norm_ty) elem_htype
479 -- Could not create element type
480 Left err -> return $ Left $
481 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
484 len <- tfp_to_int (sized_word_len_ty ty)
485 return $ Right $ SizedWType len
487 len <- tfp_to_int (sized_word_len_ty ty)
488 return $ Right $ SizedIType len
490 bound <- tfp_to_int (ranged_word_bound_ty ty)
491 return $ Right $ RangedWType bound
493 mkTyConHType tycon args
494 Nothing -> return $ Right $ StdType $ OrdType ty
496 -- FIXME: Do we really need to do this here again?
497 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
498 mkTyConHType tycon args =
499 case TyCon.tyConDataCons tycon of
500 -- Not an algebraic type
501 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
503 let arg_tys = DataCon.dataConRepArgTys dc
504 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
505 elem_htys_either <- mapM mkHType real_arg_tys
506 case Either.partitionEithers elem_htys_either of
507 -- No errors in element types
508 ([], elem_htys) -> do
509 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
510 -- There were errors in element types
511 (errors, _) -> return $ Left $
512 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
514 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
516 tyvars = TyCon.tyConTyVars tycon
517 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
519 -- Is the given type representable at runtime?
520 isReprType :: Type.Type -> TypeSession Bool
522 ty_either <- vhdl_ty_either ty
523 return $ case ty_either of
527 tfp_to_int :: Type.Type -> TypeSession Int
529 lens <- getA vsTfpInts
530 let existing_len = Map.lookup (OrdType ty) lens
532 Just len -> return len
534 let new_len = eval_tfp_int ty
535 modA vsTfpInts (Map.insert (OrdType ty) (new_len))