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])))
112 String -- ^ The portmap label
113 -> AST.VHDLId -- ^ The entity name
114 -> [AST.AssocElem] -- ^ The port assignments
116 mkComponentInst label entity_id portassigns = AST.CSISm compins
118 -- We always have a clock port, so no need to map it anywhere but here
119 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
120 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
122 -----------------------------------------------------------------------------
123 -- Functions to generate VHDL Exprs
124 -----------------------------------------------------------------------------
126 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
127 varToVHDLExpr var = do
128 case Id.isDataConWorkId_maybe var of
129 Just dc -> return $ 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
138 let ty = Var.varType var
139 case Type.splitTyConApp_maybe ty of
140 Just (tycon, args) ->
141 case Name.getOccString (TyCon.tyConName tycon) of
144 return $ AST.PrimLit $ (show len)
145 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
147 -- Turn a VHDLName into an AST expression
148 vhdlNameToVHDLExpr = AST.PrimName
150 -- Turn a VHDL Id into an AST expression
151 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
153 -- Turn a Core expression into an AST expression
154 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
156 -- Turn a alternative constructor into an AST expression. For
157 -- dataconstructors, this is only the constructor itself, not any arguments it
158 -- has. Should not be called with a DEFAULT constructor.
159 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
160 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
162 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
163 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
165 -- Turn a datacon (without arguments!) into a VHDL expression.
166 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
167 dataconToVHDLExpr dc = AST.PrimLit lit
169 tycon = DataCon.dataConTyCon dc
170 tyname = TyCon.tyConName tycon
171 dcname = DataCon.dataConName dc
172 lit = case Name.getOccString tyname of
173 -- TODO: Do something more robust than string matching
174 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
175 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
177 -----------------------------------------------------------------------------
178 -- Functions dealing with names, variables and ids
179 -----------------------------------------------------------------------------
181 -- Creates a VHDL Id from a binder
185 varToVHDLId = mkVHDLExtId . varToString
187 -- Creates a VHDL Name from a binder
191 varToVHDLName = AST.NSimple . varToVHDLId
193 -- Extracts the binder name as a String
197 varToString = OccName.occNameString . Name.nameOccName . Var.varName
199 -- Get the string version a Var's unique
200 varToStringUniq :: Var.Var -> String
201 varToStringUniq = show . Var.varUnique
203 -- Extracts the string version of the name
204 nameToString :: Name.Name -> String
205 nameToString = OccName.occNameString . Name.nameOccName
207 -- Shortcut for Basic VHDL Ids.
208 -- Can only contain alphanumerics and underscores. The supplied string must be
209 -- a valid basic id, otherwise an error value is returned. This function is
210 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
212 mkVHDLBasicId :: String -> AST.VHDLId
214 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
216 -- Strip invalid characters.
217 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
218 -- Strip leading numbers and underscores
219 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
220 -- Strip multiple adjacent underscores
221 strip_multiscore = concat . map (\cs ->
227 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
228 -- different characters than basic ids, but can never be used to refer to
230 -- Use extended Ids for any values that are taken from the source file.
231 mkVHDLExtId :: String -> AST.VHDLId
233 AST.unsafeVHDLExtId $ strip_invalid s
235 -- Allowed characters, taken from ForSyde's mkVHDLExtId
236 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
237 strip_invalid = filter (`elem` allowed)
239 -- Create a record field selector that selects the given label from the record
240 -- stored in the given binder.
241 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
242 mkSelectedName name label =
243 AST.NSelected $ name AST.:.: (AST.SSimple label)
245 -- Create an indexed name that selects a given element from a vector.
246 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
247 -- Special case for already indexed names. Just add an index
248 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
249 AST.NIndexed (AST.IndexedName name (indexes++[index]))
250 -- General case for other names
251 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
253 -----------------------------------------------------------------------------
254 -- Functions dealing with VHDL types
255 -----------------------------------------------------------------------------
257 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
258 -- for a few builtin types.
261 ("Bit", std_logicTM),
262 ("Bool", booleanTM), -- TysWiredIn.boolTy
266 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
267 -- Returns an error value, using the given message, when no type could be
269 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
271 tm_either <- vhdl_ty_either ty
273 Right tm -> return tm
274 Left err -> error $ msg ++ "\n" ++ err
276 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
277 -- Returns either an error message or the resulting type.
278 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
279 vhdl_ty_either ty = do
280 typemap <- getA vsTypes
281 htype_either <- mkHType ty
285 let builtin_ty = do -- See if this is a tycon and lookup its name
286 (tycon, args) <- Type.splitTyConApp_maybe ty
287 let name = Name.getOccString (TyCon.tyConName tycon)
288 Map.lookup name builtin_types
289 -- If not a builtin type, try the custom types
290 let existing_ty = (fmap fst) $ Map.lookup htype typemap
291 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
292 -- Found a type, return it
293 Just t -> return (Right t)
294 -- No type yet, try to construct it
296 newty_maybe <- (construct_vhdl_ty ty)
298 Right (ty_id, ty_def) -> do
299 -- TODO: Check name uniqueness
300 modA vsTypes (Map.insert htype (ty_id, ty_def))
301 modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
303 Left err -> return $ Left $
304 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
306 -- Error when constructing htype
307 Left err -> return $ Left err
309 -- Construct a new VHDL type for the given Haskell type. Returns an error
310 -- message or the resulting typemark and typedef.
311 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
312 construct_vhdl_ty ty = do
313 case Type.splitTyConApp_maybe ty of
314 Just (tycon, args) -> do
315 let name = Name.getOccString (TyCon.tyConName tycon)
317 "TFVec" -> mk_vector_ty ty
318 "SizedWord" -> mk_unsigned_ty ty
319 "SizedInt" -> mk_signed_ty ty
321 bound <- tfp_to_int (ranged_word_bound_ty ty)
322 mk_natural_ty 0 bound
323 -- Create a custom type from this tycon
324 otherwise -> mk_tycon_ty ty tycon args
325 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
327 -- | Create VHDL type for a custom tycon
328 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
329 mk_tycon_ty ty tycon args =
330 case TyCon.tyConDataCons tycon of
331 -- Not an algebraic type
332 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
334 let arg_tys = DataCon.dataConRepArgTys dc
335 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
336 -- violation? Or does it only mean not to apply it again to the same
338 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
339 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
340 case Either.partitionEithers elem_tys_either of
341 -- No errors in element types
343 let elems = zipWith AST.ElementDec recordlabels elem_tys
344 -- For a single construct datatype, build a record with one field for
346 -- TODO: Add argument type ids to this, to ensure uniqueness
347 -- TODO: Special handling for tuples?
348 let elem_names = concat $ map prettyShow elem_tys
349 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
350 let ty_def = AST.TDR $ AST.RecordTypeDef elems
351 let tupshow = mkTupleShow elem_tys ty_id
352 modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
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 vecShowFuns = mkVectorShow el_ty_tm vec_id
399 mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
400 let ty_def = AST.SubtypeIn vec_id (Just range)
401 return (Right (ty_id, Right ty_def))
402 -- Could not create element type
403 Left err -> return $ Left $
404 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
408 Int -- ^ The minimum bound (> 0)
409 -> Int -- ^ The maximum bound (> minimum bound)
410 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
411 -- ^ An error message or The typemark created.
412 mk_natural_ty min_bound max_bound = do
413 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
414 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
415 let ty_def = AST.SubtypeIn naturalTM (Just range)
416 return (Right (ty_id, Right ty_def))
419 Type.Type -- ^ Haskell type of the unsigned integer
420 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
421 mk_unsigned_ty ty = do
422 size <- tfp_to_int (sized_word_len_ty ty)
423 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
424 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
425 let ty_def = AST.SubtypeIn unsignedTM (Just range)
426 let unsignedshow = mkIntegerShow ty_id
427 modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
428 return (Right (ty_id, Right ty_def))
431 Type.Type -- ^ Haskell type of the signed integer
432 -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
434 size <- tfp_to_int (sized_int_len_ty ty)
435 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
436 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
437 let ty_def = AST.SubtypeIn signedTM (Just range)
438 let signedshow = mkIntegerShow ty_id
439 modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
440 return (Right (ty_id, Right ty_def))
442 -- Finds the field labels for VHDL type generated for the given Core type,
443 -- which must result in a record type.
444 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
445 getFieldLabels ty = do
446 -- Ensure that the type is generated (but throw away it's VHDLId)
447 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
449 -- Get the types map, lookup and unpack the VHDL TypeDef
450 types <- getA vsTypes
451 -- Assume the type for which we want labels is really translatable
452 Right htype <- mkHType ty
453 case Map.lookup htype types of
454 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
455 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
457 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
458 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
459 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
461 mkHType :: Type.Type -> TypeSession (Either String HType)
463 -- FIXME: Do we really need to do this here again?
464 let builtin_ty = do -- See if this is a tycon and lookup its name
465 (tycon, args) <- Type.splitTyConApp_maybe ty
466 let name = Name.getOccString (TyCon.tyConName tycon)
467 Map.lookup name builtin_types
470 return $ Right $ BuiltinType $ prettyShow typ
472 case Type.splitTyConApp_maybe ty of
473 Just (tycon, args) -> do
474 let name = Name.getOccString (TyCon.tyConName tycon)
477 let el_ty = tfvec_elem ty
478 elem_htype_either <- mkHType el_ty
479 case elem_htype_either of
480 -- Could create element type
481 Right elem_htype -> do
482 len <- tfp_to_int (tfvec_len_ty ty)
483 return $ Right $ VecType len elem_htype
484 -- Could not create element type
485 Left err -> return $ Left $
486 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
489 len <- tfp_to_int (sized_word_len_ty ty)
490 return $ Right $ SizedWType len
492 len <- tfp_to_int (sized_word_len_ty ty)
493 return $ Right $ SizedIType len
495 bound <- tfp_to_int (ranged_word_bound_ty ty)
496 return $ Right $ RangedWType bound
498 mkTyConHType tycon args
499 Nothing -> return $ Right $ StdType $ OrdType ty
501 -- FIXME: Do we really need to do this here again?
502 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
503 mkTyConHType tycon args =
504 case TyCon.tyConDataCons tycon of
505 -- Not an algebraic type
506 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
508 let arg_tys = DataCon.dataConRepArgTys dc
509 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
510 elem_htys_either <- mapM mkHType real_arg_tys
511 case Either.partitionEithers elem_htys_either of
512 -- No errors in element types
513 ([], elem_htys) -> do
514 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
515 -- There were errors in element types
516 (errors, _) -> return $ Left $
517 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
519 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
521 tyvars = TyCon.tyConTyVars tycon
522 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
524 -- Is the given type representable at runtime?
525 isReprType :: Type.Type -> TypeSession Bool
527 ty_either <- vhdl_ty_either ty
528 return $ case ty_either of
533 tfp_to_int :: Type.Type -> TypeSession Int
535 hscenv <- getA vsHscEnv
536 let norm_ty = normalise_tfp_int hscenv ty
537 case Type.splitTyConApp_maybe norm_ty of
538 Just (tycon, args) -> do
539 let name = Name.getOccString (TyCon.tyConName tycon)
542 len <- tfp_to_int' ty
545 modA vsTfpInts (Map.insert (OrdType norm_ty) (-1))
546 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
547 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
549 tfp_to_int' :: Type.Type -> TypeSession Int
551 lens <- getA vsTfpInts
552 hscenv <- getA vsHscEnv
553 let norm_ty = normalise_tfp_int hscenv ty
554 let existing_len = Map.lookup (OrdType norm_ty) lens
556 Just len -> return len
558 let new_len = eval_tfp_int hscenv ty
559 modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
563 [AST.TypeMark] -- ^ type of each tuple element
564 -> AST.TypeMark -- ^ type of the tuple
566 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
568 tupPar = AST.unsafeVHDLBasicId "tup"
569 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
570 showExpr = AST.ReturnSm (Just $
571 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
573 showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
574 map ((genExprFCall showId).
577 (AST.NSimple tupPar AST.:.:).
579 (take tupSize recordlabels)
580 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
581 tupSize = length elemTMs
584 AST.TypeMark -- ^ elemtype
585 -> AST.TypeMark -- ^ vectype
586 -> [(String,AST.SubProgBody)]
587 mkVectorShow elemTM vectorTM =
588 [ (headId, AST.SubProgBody headSpec [] [headExpr])
589 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
590 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
593 vecPar = AST.unsafeVHDLBasicId "vec"
594 resId = AST.unsafeVHDLBasicId "res"
595 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
597 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
598 (AST.NSimple vecPar) [AST.PrimLit "0"])))
599 vecSlice init last = AST.PrimName (AST.NSlice
602 (AST.ToRange init last)))
603 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
604 -- variable res : fsvec_x (0 to vec'length-2);
607 (AST.SubtypeIn vectorTM
608 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
609 [AST.ToRange (AST.PrimLit "0")
610 (AST.PrimName (AST.NAttribute $
611 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
612 (AST.PrimLit "2")) ]))
614 -- res AST.:= vec(1 to vec'length-1)
615 tailExpr = AST.NSimple resId AST.:= (vecSlice
617 (AST.PrimName (AST.NAttribute $
618 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
619 AST.:-: AST.PrimLit "1"))
620 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
621 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
622 doShowId = AST.unsafeVHDLExtId "doshow"
623 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
624 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
627 -- when 0 => return "";
628 -- when 1 => return head(vec);
629 -- when others => return show(head(vec)) & ',' &
630 -- doshow (tail(vec));
633 AST.CaseSm (AST.PrimName (AST.NAttribute $
634 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
635 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
636 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
637 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
638 [AST.ReturnSm (Just $
640 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
641 AST.CaseSmAlt [AST.Others]
642 [AST.ReturnSm (Just $
644 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
645 AST.PrimLit "','" AST.:&:
646 genExprFCall doShowId
647 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
648 -- return '<' & doshow(vec) & '>';
649 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
650 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
654 AST.TypeMark -- ^ The specific signed
656 mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
658 signedPar = AST.unsafeVHDLBasicId "sint"
659 showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
660 showExpr = AST.ReturnSm (Just $
661 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
662 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
664 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
666 mkBuiltInShow :: [AST.SubProgBody]
667 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
668 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
671 bitPar = AST.unsafeVHDLBasicId "s"
672 boolPar = AST.unsafeVHDLBasicId "b"
673 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
674 -- if s = '1' then return "'1'" else return "'0'"
675 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
676 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
678 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
679 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
680 -- if b then return "True" else return "False"
681 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
682 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
684 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
686 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
687 genExprFCall fName args =
688 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
689 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
691 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
692 genExprPCall2 entid arg1 arg2 =
693 AST.ProcCall (AST.NSimple entid) $
694 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
696 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
698 if True then do --isInternalSigUse use || isStateSigUse use then do
699 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
700 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
701 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)