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
13 import Data.Accessor.MonadState as MonadState
17 import qualified Language.VHDL.AST as AST
22 import qualified OccName
25 import qualified IdInfo
26 import qualified TyCon
28 import qualified DataCon
29 import qualified CoreSubst
32 import CLasH.VHDL.VHDLTypes
33 import CLasH.Utils.Core.CoreTools
34 import CLasH.Utils.Pretty
35 import CLasH.VHDL.Constants
37 -----------------------------------------------------------------------------
38 -- Functions to generate concurrent statements
39 -----------------------------------------------------------------------------
41 -- Create an unconditional assignment statement
43 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
44 -> AST.Expr -- ^ The expression to assign
45 -> AST.ConcSm -- ^ The resulting concurrent statement
46 mkUncondAssign dst expr = mkAssign dst Nothing expr
48 -- Create a conditional assignment statement
50 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
51 -> AST.Expr -- ^ The condition
52 -> AST.Expr -- ^ The value when true
53 -> AST.Expr -- ^ The value when false
54 -> AST.ConcSm -- ^ The resulting concurrent statement
55 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
57 -- Create a conditional or unconditional assignment statement
59 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
60 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
61 -- and the value to assign when true.
62 -> AST.Expr -- ^ The value to assign when false or no condition
63 -> AST.ConcSm -- ^ The resulting concurrent statement
64 mkAssign dst cond false_expr =
66 -- I'm not 100% how this assignment AST works, but this gets us what we
68 whenelse = case cond of
69 Just (cond_expr, true_expr) ->
71 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
73 [AST.WhenElse true_wform cond_expr]
75 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
76 dst_name = case dst of
77 Left bndr -> AST.NSimple (varToVHDLId bndr)
79 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
84 [AST.Expr] -- ^ The argument that are applied to function
85 -> AST.VHDLName -- ^ The binder in which to store the result
86 -> Entity -- ^ The entity to map against.
87 -> [AST.AssocElem] -- ^ The resulting port maps
88 mkAssocElems args res entity =
89 -- Create the actual AssocElems
90 zipWith mkAssocElem ports sigs
92 -- Turn the ports and signals from a map into a flat list. This works,
93 -- since the maps must have an identical form by definition. TODO: Check
95 arg_ports = ent_args entity
96 res_port = ent_res entity
97 -- Extract the id part from the (id, type) tuple
98 ports = map fst (res_port : arg_ports)
99 -- Translate signal numbers into names
100 sigs = (vhdlNameToVHDLExpr res : args)
102 -- | Create an VHDL port -> signal association
103 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
104 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
106 -- | Create an VHDL port -> signal association
107 mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
108 mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
109 (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
111 -- | Create an aggregate signal
112 mkAggregateSignal :: [AST.Expr] -> AST.Expr
113 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
116 String -- ^ The portmap label
117 -> AST.VHDLId -- ^ The entity name
118 -> [AST.AssocElem] -- ^ The port assignments
120 mkComponentInst label entity_id portassigns = AST.CSISm compins
122 -- We always have a clock port, so no need to map it anywhere but here
123 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
124 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
126 -----------------------------------------------------------------------------
127 -- Functions to generate VHDL Exprs
128 -----------------------------------------------------------------------------
130 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
131 varToVHDLExpr var = do
132 case Id.isDataConWorkId_maybe var of
133 Just dc -> return $ dataconToVHDLExpr dc
134 -- This is a dataconstructor.
135 -- Not a datacon, just another signal. Perhaps we should check for
136 -- local/global here as well?
137 -- Sadly so.. tfp decimals are types, not data constructors, but instances
138 -- should still be translated to integer literals. It is probebly not the
139 -- best solution to translate them here.
140 -- FIXME: Find a better solution for translating instances of tfp integers
142 let ty = Var.varType var
143 case Type.splitTyConApp_maybe ty of
144 Just (tycon, args) ->
145 case Name.getOccString (TyCon.tyConName tycon) of
148 return $ AST.PrimLit $ (show len)
149 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
151 -- Turn a VHDLName into an AST expression
152 vhdlNameToVHDLExpr = AST.PrimName
154 -- Turn a VHDL Id into an AST expression
155 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
157 -- Turn a Core expression into an AST expression
158 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
160 -- Turn a alternative constructor into an AST expression. For
161 -- dataconstructors, this is only the constructor itself, not any arguments it
162 -- has. Should not be called with a DEFAULT constructor.
163 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
164 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
166 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
167 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
169 -- Turn a datacon (without arguments!) into a VHDL expression.
170 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
171 dataconToVHDLExpr dc = AST.PrimLit lit
173 tycon = DataCon.dataConTyCon dc
174 tyname = TyCon.tyConName tycon
175 dcname = DataCon.dataConName dc
176 lit = case Name.getOccString tyname of
177 -- TODO: Do something more robust than string matching
178 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
179 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
181 -----------------------------------------------------------------------------
182 -- Functions dealing with names, variables and ids
183 -----------------------------------------------------------------------------
185 -- Creates a VHDL Id from a binder
189 varToVHDLId = mkVHDLExtId . varToString
191 -- Creates a VHDL Name from a binder
195 varToVHDLName = AST.NSimple . varToVHDLId
197 -- Extracts the binder name as a String
201 varToString = OccName.occNameString . Name.nameOccName . Var.varName
203 -- Get the string version a Var's unique
204 varToStringUniq :: Var.Var -> String
205 varToStringUniq = show . Var.varUnique
207 -- Extracts the string version of the name
208 nameToString :: Name.Name -> String
209 nameToString = OccName.occNameString . Name.nameOccName
211 -- Shortcut for Basic VHDL Ids.
212 -- Can only contain alphanumerics and underscores. The supplied string must be
213 -- a valid basic id, otherwise an error value is returned. This function is
214 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
216 mkVHDLBasicId :: String -> AST.VHDLId
218 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
220 -- Strip invalid characters.
221 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
222 -- Strip leading numbers and underscores
223 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
224 -- Strip multiple adjacent underscores
225 strip_multiscore = concat . map (\cs ->
231 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
232 -- different characters than basic ids, but can never be used to refer to
234 -- Use extended Ids for any values that are taken from the source file.
235 mkVHDLExtId :: String -> AST.VHDLId
237 AST.unsafeVHDLExtId $ strip_invalid s
239 -- Allowed characters, taken from ForSyde's mkVHDLExtId
240 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
241 strip_invalid = filter (`elem` allowed)
243 -- Create a record field selector that selects the given label from the record
244 -- stored in the given binder.
245 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
246 mkSelectedName name label =
247 AST.NSelected $ name AST.:.: (AST.SSimple label)
249 -- Create an indexed name that selects a given element from a vector.
250 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
251 -- Special case for already indexed names. Just add an index
252 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
253 AST.NIndexed (AST.IndexedName name (indexes++[index]))
254 -- General case for other names
255 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
257 -----------------------------------------------------------------------------
258 -- Functions dealing with VHDL types
259 -----------------------------------------------------------------------------
261 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
262 -- for a few builtin types.
265 ("Bit", std_logicTM),
266 ("Bool", booleanTM), -- TysWiredIn.boolTy
270 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
271 -- Returns an error value, using the given message, when no type could be
273 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
275 tm_either <- vhdl_ty_either ty
277 Right tm -> return tm
278 Left err -> error $ msg ++ "\n" ++ err
280 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
281 -- Returns either an error message or the resulting type.
282 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
283 vhdl_ty_either ty = do
284 typemap <- getA vsTypes
285 htype_either <- mkHType ty
289 let builtin_ty = do -- See if this is a tycon and lookup its name
290 (tycon, args) <- Type.splitTyConApp_maybe ty
291 let name = Name.getOccString (TyCon.tyConName tycon)
292 Map.lookup name builtin_types
293 -- If not a builtin type, try the custom types
294 let existing_ty = (fmap fst) $ Map.lookup htype typemap
295 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
296 -- Found a type, return it
297 Just t -> return (Right t)
298 -- No type yet, try to construct it
300 newty_maybe <- (construct_vhdl_ty ty)
302 Right (ty_id, ty_def) -> do
303 -- TODO: Check name uniqueness
304 modA vsTypes (Map.insert htype (ty_id, ty_def))
305 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
307 Left err -> return $ Left $
308 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
310 -- Error when constructing htype
311 Left err -> return $ Left err
313 -- Construct a new VHDL type for the given Haskell type. Returns an error
314 -- message or the resulting typemark and typedef.
315 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
316 construct_vhdl_ty ty = do
317 case Type.splitTyConApp_maybe ty of
318 Just (tycon, args) -> do
319 let name = Name.getOccString (TyCon.tyConName tycon)
321 "TFVec" -> mk_vector_ty ty
322 "SizedWord" -> mk_unsigned_ty ty
323 "SizedInt" -> mk_signed_ty ty
325 bound <- tfp_to_int (ranged_word_bound_ty ty)
326 mk_natural_ty 0 bound
327 -- Create a custom type from this tycon
328 otherwise -> mk_tycon_ty ty tycon args
329 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
331 -- | Create VHDL type for a custom tycon
332 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
333 mk_tycon_ty ty tycon args =
334 case TyCon.tyConDataCons tycon of
335 -- Not an algebraic type
336 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
338 let arg_tys = DataCon.dataConRepArgTys dc
339 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
340 -- violation? Or does it only mean not to apply it again to the same
342 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
343 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
344 case Either.partitionEithers elem_tys_either of
345 -- No errors in element types
347 let elems = zipWith AST.ElementDec recordlabels elem_tys
348 -- For a single construct datatype, build a record with one field for
350 -- TODO: Add argument type ids to this, to ensure uniqueness
351 -- TODO: Special handling for tuples?
352 let elem_names = concat $ map prettyShow elem_tys
353 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
354 let ty_def = AST.TDR $ AST.RecordTypeDef elems
355 let tupshow = mkTupleShow elem_tys ty_id
356 modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
357 return $ Right (ty_id, Left ty_def)
358 -- There were errors in element types
359 (errors, _) -> return $ Left $
360 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
362 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
364 -- Create a subst that instantiates all types passed to the tycon
365 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
366 -- to work so far, though..
367 tyvars = TyCon.tyConTyVars tycon
368 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
369 -- Generate a bunch of labels for fields of a record
370 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
372 -- | Create a VHDL vector type
374 Type.Type -- ^ The Haskell type of the Vector
375 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
376 -- ^ An error message or The typemark created.
379 types_map <- getA vsTypes
381 let (nvec_l, nvec_el) = Type.splitAppTy ty
382 let (nvec, leng) = Type.splitAppTy nvec_l
383 let vec_ty = Type.mkAppTy nvec nvec_el
384 len <- tfp_to_int (tfvec_len_ty ty)
385 let el_ty = tfvec_elem ty
386 el_ty_tm_either <- vhdl_ty_either el_ty
387 case el_ty_tm_either of
388 -- Could create element type
390 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
391 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
392 let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
393 case existing_elem_ty of
395 let ty_def = AST.SubtypeIn t (Just range)
396 return (Right (ty_id, Right ty_def))
398 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
399 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
400 modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
401 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
402 let vecShowFuns = mkVectorShow el_ty_tm vec_id
403 mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
404 let ty_def = AST.SubtypeIn vec_id (Just range)
405 return (Right (ty_id, Right ty_def))
406 -- Could not create element type
407 Left err -> return $ Left $
408 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
412 Int -- ^ The minimum bound (> 0)
413 -> Int -- ^ The maximum bound (> minimum bound)
414 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
415 -- ^ An error message or The typemark created.
416 mk_natural_ty min_bound max_bound = do
417 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
418 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
419 let ty_def = AST.SubtypeIn naturalTM (Just range)
420 return (Right (ty_id, Right ty_def))
423 Type.Type -- ^ Haskell type of the unsigned integer
424 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
425 mk_unsigned_ty ty = do
426 size <- tfp_to_int (sized_word_len_ty ty)
427 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
428 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
429 let ty_def = AST.SubtypeIn unsignedTM (Just range)
430 let unsignedshow = mkIntegerShow ty_id
431 modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
432 return (Right (ty_id, Right ty_def))
435 Type.Type -- ^ Haskell type of the signed integer
436 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
438 size <- tfp_to_int (sized_int_len_ty ty)
439 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
440 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
441 let ty_def = AST.SubtypeIn signedTM (Just range)
442 let signedshow = mkIntegerShow ty_id
443 modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
444 return (Right (ty_id, Right ty_def))
446 -- Finds the field labels for VHDL type generated for the given Core type,
447 -- which must result in a record type.
448 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
449 getFieldLabels ty = do
450 -- Ensure that the type is generated (but throw away it's VHDLId)
451 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
453 -- Get the types map, lookup and unpack the VHDL TypeDef
454 types <- getA vsTypes
455 -- Assume the type for which we want labels is really translatable
456 Right htype <- mkHType ty
457 case Map.lookup htype types of
458 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
459 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
461 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
462 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
463 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
465 mkHType :: Type.Type -> TypeSession (Either String HType)
467 -- FIXME: Do we really need to do this here again?
468 let builtin_ty = do -- See if this is a tycon and lookup its name
469 (tycon, args) <- Type.splitTyConApp_maybe ty
470 let name = Name.getOccString (TyCon.tyConName tycon)
471 Map.lookup name builtin_types
474 return $ Right $ BuiltinType $ prettyShow typ
476 case Type.splitTyConApp_maybe ty of
477 Just (tycon, args) -> do
478 let name = Name.getOccString (TyCon.tyConName tycon)
481 let el_ty = tfvec_elem ty
482 elem_htype_either <- mkHType el_ty
483 case elem_htype_either of
484 -- Could create element type
485 Right elem_htype -> do
486 len <- tfp_to_int (tfvec_len_ty ty)
487 return $ Right $ VecType len elem_htype
488 -- Could not create element type
489 Left err -> return $ Left $
490 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
493 len <- tfp_to_int (sized_word_len_ty ty)
494 return $ Right $ SizedWType len
496 len <- tfp_to_int (sized_word_len_ty ty)
497 return $ Right $ SizedIType len
499 bound <- tfp_to_int (ranged_word_bound_ty ty)
500 return $ Right $ RangedWType bound
502 mkTyConHType tycon args
503 Nothing -> return $ Right $ StdType $ OrdType ty
505 -- FIXME: Do we really need to do this here again?
506 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
507 mkTyConHType tycon args =
508 case TyCon.tyConDataCons tycon of
509 -- Not an algebraic type
510 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
512 let arg_tys = DataCon.dataConRepArgTys dc
513 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
514 elem_htys_either <- mapM mkHType real_arg_tys
515 case Either.partitionEithers elem_htys_either of
516 -- No errors in element types
517 ([], elem_htys) -> do
518 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
519 -- There were errors in element types
520 (errors, _) -> return $ Left $
521 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
523 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
525 tyvars = TyCon.tyConTyVars tycon
526 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
528 -- Is the given type representable at runtime?
529 isReprType :: Type.Type -> TypeSession Bool
531 ty_either <- vhdl_ty_either ty
532 return $ case ty_either of
537 tfp_to_int :: Type.Type -> TypeSession Int
539 hscenv <- getA vsHscEnv
540 let norm_ty = normalise_tfp_int hscenv ty
541 case Type.splitTyConApp_maybe norm_ty of
542 Just (tycon, args) -> do
543 let name = Name.getOccString (TyCon.tyConName tycon)
546 len <- tfp_to_int' ty
549 modA vsTfpInts (Map.insert (OrdType norm_ty) (-1))
550 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
551 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
553 tfp_to_int' :: Type.Type -> TypeSession Int
555 lens <- getA vsTfpInts
556 hscenv <- getA vsHscEnv
557 let norm_ty = normalise_tfp_int hscenv ty
558 let existing_len = Map.lookup (OrdType norm_ty) lens
560 Just len -> return len
562 let new_len = eval_tfp_int hscenv ty
563 modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
567 [AST.TypeMark] -- ^ type of each tuple element
568 -> AST.TypeMark -- ^ type of the tuple
570 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
572 tupPar = AST.unsafeVHDLBasicId "tup"
573 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
574 showExpr = AST.ReturnSm (Just $
575 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
577 showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
578 map ((genExprFCall showId).
581 (AST.NSimple tupPar AST.:.:).
583 (take tupSize recordlabels)
584 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
585 tupSize = length elemTMs
588 AST.TypeMark -- ^ elemtype
589 -> AST.TypeMark -- ^ vectype
590 -> [(String,AST.SubProgBody)]
591 mkVectorShow elemTM vectorTM =
592 [ (headId, AST.SubProgBody headSpec [] [headExpr])
593 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
594 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
597 vecPar = AST.unsafeVHDLBasicId "vec"
598 resId = AST.unsafeVHDLBasicId "res"
599 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
601 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
602 (AST.NSimple vecPar) [AST.PrimLit "0"])))
603 vecSlice init last = AST.PrimName (AST.NSlice
606 (AST.ToRange init last)))
607 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
608 -- variable res : fsvec_x (0 to vec'length-2);
611 (AST.SubtypeIn vectorTM
612 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
613 [AST.ToRange (AST.PrimLit "0")
614 (AST.PrimName (AST.NAttribute $
615 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
616 (AST.PrimLit "2")) ]))
618 -- res AST.:= vec(1 to vec'length-1)
619 tailExpr = AST.NSimple resId AST.:= (vecSlice
621 (AST.PrimName (AST.NAttribute $
622 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
623 AST.:-: AST.PrimLit "1"))
624 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
625 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
626 doShowId = AST.unsafeVHDLExtId "doshow"
627 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
628 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
631 -- when 0 => return "";
632 -- when 1 => return head(vec);
633 -- when others => return show(head(vec)) & ',' &
634 -- doshow (tail(vec));
637 AST.CaseSm (AST.PrimName (AST.NAttribute $
638 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
639 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
640 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
641 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
642 [AST.ReturnSm (Just $
644 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
645 AST.CaseSmAlt [AST.Others]
646 [AST.ReturnSm (Just $
648 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
649 AST.PrimLit "','" AST.:&:
650 genExprFCall doShowId
651 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
652 -- return '<' & doshow(vec) & '>';
653 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
654 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
658 AST.TypeMark -- ^ The specific signed
660 mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
662 signedPar = AST.unsafeVHDLBasicId "sint"
663 showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
664 showExpr = AST.ReturnSm (Just $
665 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
666 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
668 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
670 mkBuiltInShow :: [AST.SubProgBody]
671 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
672 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
675 bitPar = AST.unsafeVHDLBasicId "s"
676 boolPar = AST.unsafeVHDLBasicId "b"
677 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
678 -- if s = '1' then return "'1'" else return "'0'"
679 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
680 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
682 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
683 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
684 -- if b then return "True" else return "False"
685 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
686 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
688 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
690 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
691 genExprFCall fName args =
692 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
693 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
695 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
696 genExprPCall2 entid arg1 arg2 =
697 AST.ProcCall (AST.NSimple entid) $
698 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
700 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
702 if True then do --isInternalSigUse use || isStateSigUse use then do
703 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
704 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
705 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)