1 {-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
2 module CLasH.VHDL.VHDLTools where
6 import qualified Data.Either as Either
7 import qualified Data.List as List
8 import qualified Data.Char as Char
9 import qualified Data.Map as Map
10 import qualified Control.Monad as Monad
11 import qualified Control.Arrow as Arrow
12 import qualified Control.Monad.Trans.State as State
13 import qualified Data.Monoid as Monoid
15 import Data.Accessor.MonadState as MonadState
19 import qualified Language.VHDL.AST as AST
24 import qualified OccName
27 import qualified IdInfo
28 import qualified TyCon
30 import qualified DataCon
31 import qualified CoreSubst
32 import qualified Outputable
35 import CLasH.VHDL.VHDLTypes
36 import CLasH.Translator.TranslatorTypes
37 import CLasH.Utils.Core.CoreTools
39 import CLasH.Utils.Pretty
40 import CLasH.VHDL.Constants
42 -----------------------------------------------------------------------------
43 -- Functions to generate concurrent statements
44 -----------------------------------------------------------------------------
46 -- Create an unconditional assignment statement
48 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
49 -> AST.Expr -- ^ The expression to assign
50 -> AST.ConcSm -- ^ The resulting concurrent statement
51 mkUncondAssign dst expr = mkAssign dst Nothing expr
53 -- Create a conditional assignment statement
55 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
56 -> AST.Expr -- ^ The condition
57 -> AST.Expr -- ^ The value when true
58 -> AST.Expr -- ^ The value when false
59 -> AST.ConcSm -- ^ The resulting concurrent statement
60 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
62 -- Create a conditional or unconditional assignment statement
64 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
65 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
66 -- and the value to assign when true.
67 -> AST.Expr -- ^ The value to assign when false or no condition
68 -> AST.ConcSm -- ^ The resulting concurrent statement
69 mkAssign dst cond false_expr =
71 -- I'm not 100% how this assignment AST works, but this gets us what we
73 whenelse = case cond of
74 Just (cond_expr, true_expr) ->
76 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
78 [AST.WhenElse true_wform cond_expr]
80 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
81 dst_name = case dst of
82 Left bndr -> AST.NSimple (varToVHDLId bndr)
84 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
89 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
90 -> [AST.Expr] -- ^ The conditions
91 -> [AST.Expr] -- ^ The expressions
92 -> AST.ConcSm -- ^ The Alt assigns
93 mkAltsAssign dst conds exprs
94 | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
97 whenelses = zipWith mkWhenElse conds exprs
98 false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
99 dst_name = case dst of
100 Left bndr -> AST.NSimple (varToVHDLId bndr)
102 assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
106 mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
107 mkWhenElse cond true_expr =
109 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
111 AST.WhenElse true_wform cond
114 [AST.Expr] -- ^ The argument that are applied to function
115 -> AST.VHDLName -- ^ The binder in which to store the result
116 -> Entity -- ^ The entity to map against.
117 -> [AST.AssocElem] -- ^ The resulting port maps
118 mkAssocElems args res entity =
119 arg_maps ++ (Maybe.maybeToList res_map_maybe)
121 arg_ports = ent_args entity
122 res_port_maybe = ent_res entity
123 -- Create an expression of res to map against the output port
124 res_expr = vhdlNameToVHDLExpr res
125 -- Map each of the input ports
126 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
127 -- Map the output port, if present
128 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
130 -- | Create an VHDL port -> signal association
131 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
132 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
134 -- | Create an aggregate signal
135 mkAggregateSignal :: [AST.Expr] -> AST.Expr
136 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
139 String -- ^ The portmap label
140 -> AST.VHDLId -- ^ The entity name
141 -> [AST.AssocElem] -- ^ The port assignments
143 mkComponentInst label entity_id portassigns = AST.CSISm compins
145 -- We always have a clock port, so no need to map it anywhere but here
146 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
147 resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
148 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
150 -----------------------------------------------------------------------------
151 -- Functions to generate VHDL Exprs
152 -----------------------------------------------------------------------------
154 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
155 varToVHDLExpr var = do
156 case Id.isDataConWorkId_maybe var of
157 Just dc -> dataconToVHDLExpr dc
158 -- This is a dataconstructor.
159 -- Not a datacon, just another signal. Perhaps we should check for
160 -- local/global here as well?
161 -- Sadly so.. tfp decimals are types, not data constructors, but instances
162 -- should still be translated to integer literals. It is probebly not the
163 -- best solution to translate them here.
164 -- FIXME: Find a better solution for translating instances of tfp integers
166 let ty = Var.varType var
167 case Type.splitTyConApp_maybe ty of
168 Just (tycon, args) ->
169 case Name.getOccString (TyCon.tyConName tycon) of
172 return $ AST.PrimLit $ (show len)
173 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
175 -- Turn a VHDLName into an AST expression
176 vhdlNameToVHDLExpr = AST.PrimName
178 -- Turn a VHDL Id into an AST expression
179 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
181 -- Turn a Core expression into an AST expression
182 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
184 -- Turn a alternative constructor into an AST expression. For
185 -- dataconstructors, this is only the constructor itself, not any arguments it
186 -- has. Should not be called with a DEFAULT constructor.
187 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
188 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
190 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
191 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
193 -- Turn a datacon (without arguments!) into a VHDL expression.
194 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
195 dataconToVHDLExpr dc = do
196 typemap <- getA tsTypes
197 htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
201 let dcname = DataCon.dataConName dc
203 (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
204 (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
206 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
209 let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
211 Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
212 -- Error when constructing htype
213 Left err -> error err
215 -----------------------------------------------------------------------------
216 -- Functions dealing with names, variables and ids
217 -----------------------------------------------------------------------------
219 -- Creates a VHDL Id from a binder
223 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
225 lowers :: String -> Int
226 lowers xs = length [x | x <- xs, Char.isLower x]
228 -- Creates a VHDL Name from a binder
232 varToVHDLName = AST.NSimple . varToVHDLId
234 -- Extracts the binder name as a String
238 varToString = OccName.occNameString . Name.nameOccName . Var.varName
240 -- Get the string version a Var's unique
241 varToStringUniq :: Var.Var -> String
242 varToStringUniq = show . Var.varUnique
244 -- Extracts the string version of the name
245 nameToString :: Name.Name -> String
246 nameToString = OccName.occNameString . Name.nameOccName
248 -- Shortcut for Basic VHDL Ids.
249 -- Can only contain alphanumerics and underscores. The supplied string must be
250 -- a valid basic id, otherwise an error value is returned. This function is
251 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
253 mkVHDLBasicId :: String -> AST.VHDLId
255 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
257 -- Strip invalid characters.
258 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
259 -- Strip leading numbers and underscores
260 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
261 -- Strip multiple adjacent underscores
262 strip_multiscore = concat . map (\cs ->
268 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
269 -- different characters than basic ids, but can never be used to refer to
271 -- Use extended Ids for any values that are taken from the source file.
272 mkVHDLExtId :: String -> AST.VHDLId
274 AST.unsafeVHDLExtId $ strip_invalid s
276 -- Allowed characters, taken from ForSyde's mkVHDLExtId
277 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
278 strip_invalid = filter (`elem` allowed)
280 -- Create a record field selector that selects the given label from the record
281 -- stored in the given binder.
282 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
283 mkSelectedName name label =
284 AST.NSelected $ name AST.:.: (AST.SSimple label)
286 -- Create an indexed name that selects a given element from a vector.
287 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
288 -- Special case for already indexed names. Just add an index
289 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
290 AST.NIndexed (AST.IndexedName name (indexes++[index]))
291 -- General case for other names
292 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
294 -----------------------------------------------------------------------------
295 -- Functions dealing with VHDL types
296 -----------------------------------------------------------------------------
297 builtin_types :: TypeMap
300 (BuiltinType "Bit", Just (std_logicTM, Nothing)),
301 (BuiltinType "Bool", Just (booleanTM, Nothing)), -- TysWiredIn.boolTy
302 (BuiltinType "Dec", Just (integerTM, Nothing))
305 -- Is the given type representable at runtime?
306 isReprType :: Type.Type -> TypeSession Bool
308 ty_either <- mkHTypeEither ty
309 return $ case ty_either of
313 mkHType :: (TypedThing t, Outputable.Outputable t) =>
314 String -> t -> TypeSession HType
316 htype_either <- mkHTypeEither ty
318 Right htype -> return htype
319 Left err -> error $ msg ++ err
321 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
322 t -> TypeSession (Either String HType)
323 mkHTypeEither tything = do
324 case getType tything of
325 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
326 Just ty -> mkHTypeEither' ty
328 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
329 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
330 | isStateType ty = return $ Right StateType
332 case Type.splitTyConApp_maybe ty of
333 Just (tycon, args) -> do
334 typemap <- getA tsTypes
335 let name = Name.getOccString (TyCon.tyConName tycon)
336 let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
337 case builtinTyMaybe of
338 (Just x) -> return $ Right $ BuiltinType name
342 let el_ty = tfvec_elem ty
343 elem_htype_either <- mkHTypeEither el_ty
344 case elem_htype_either of
345 -- Could create element type
346 Right elem_htype -> do
347 len <- tfp_to_int (tfvec_len_ty ty)
348 return $ Right $ VecType len elem_htype
349 -- Could not create element type
350 Left err -> return $ Left $
351 "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
353 len <- tfp_to_int (sized_word_len_ty ty)
354 return $ Right $ SizedWType len
356 len <- tfp_to_int (sized_word_len_ty ty)
357 return $ Right $ SizedIType len
359 bound <- tfp_to_int (ranged_word_bound_ty ty)
360 return $ Right $ RangedWType bound
362 mkTyConHType tycon args
363 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
365 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
366 mkTyConHType tycon args =
367 case TyCon.tyConDataCons tycon of
368 -- Not an algebraic type
369 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
371 let arg_tys = DataCon.dataConRepArgTys dc
372 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
373 let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
374 elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
375 case Either.partitionEithers elem_htys_either of
376 ([], [elem_hty]) -> do
377 return $ Right elem_hty
378 -- No errors in element types
379 ([], elem_htys) -> do
380 return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
381 -- There were errors in element types
382 (errors, _) -> return $ Left $
383 "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
386 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
387 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
390 return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
391 xs -> return $ Left $
392 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
394 tyvars = TyCon.tyConTyVars tycon
395 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
397 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
398 -- Returns an error value, using the given message, when no type could be
399 -- created. Returns Nothing when the type is valid, but empty.
400 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
401 String -> t -> TypeSession (Maybe AST.TypeMark)
403 htype <- mkHType msg ty
404 tm <- vhdlTyMaybe htype
407 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
408 vhdlTyMaybe htype = do
409 typemap <- getA tsTypes
410 -- If not a builtin type, try the custom types
411 let existing_ty = Map.lookup htype typemap
413 -- Found a type, return it
414 Just (Just (t, _)) -> return $ Just t
415 Just (Nothing) -> return Nothing
416 -- No type yet, try to construct it
418 newty <- (construct_vhdl_ty htype)
419 modA tsTypes (Map.insert htype newty)
421 Just (ty_id, ty_def) -> do
422 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
424 Nothing -> return Nothing
426 -- Construct a new VHDL type for the given Haskell type. Returns an error
427 -- message or the resulting typemark and typedef.
428 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
429 -- State types don't generate VHDL
430 construct_vhdl_ty htype = do
432 StateType -> return Nothing
433 (SizedWType w) -> mkUnsignedTy w
434 (SizedIType i) -> mkSignedTy i
435 (RangedWType u) -> mkNaturalTy 0 u
436 (VecType n e) -> mkVectorTy (VecType n e)
437 -- Create a custom type from this tycon
438 otherwise -> mkTyconTy htype
440 -- | Create VHDL type for a custom tycon
441 mkTyconTy :: HType -> TypeSession TypeMapRec
444 (AggrType tycon args) -> do
445 elemTysMaybe <- mapM vhdlTyMaybe args
446 case Maybe.catMaybes elemTysMaybe of
447 [] -> -- No non-empty members
450 let elems = zipWith AST.ElementDec recordlabels elem_tys
451 let elem_names = concat $ map prettyShow elem_tys
452 let ty_id = mkVHDLExtId $ tycon ++ elem_names
453 let ty_def = AST.TDR $ AST.RecordTypeDef elems
454 let tupshow = mkTupleShow elem_tys ty_id
455 modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
456 return $ Just (ty_id, Just $ Left ty_def)
457 (EnumType tycon dcs) -> do
458 let elems = map mkVHDLExtId dcs
459 let ty_id = mkVHDLExtId tycon
460 let ty_def = AST.TDE $ AST.EnumTypeDef elems
461 let enumShow = mkEnumShow elems ty_id
462 modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
463 return $ Just (ty_id, Just $ Left ty_def)
464 otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
466 -- Generate a bunch of labels for fields of a record
467 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
469 -- | Create a VHDL vector type
471 HType -- ^ The Haskell type of the Vector
472 -> TypeSession TypeMapRec
473 -- ^ An error message or The typemark created.
475 mkVectorTy (VecType len elHType) = do
476 typesMap <- getA tsTypes
477 elTyTmMaybe <- vhdlTyMaybe elHType
480 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
481 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
482 let existing_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap
483 case existing_uvec_ty of
485 let ty_def = AST.SubtypeIn t (Just range)
486 return (Just (ty_id, Just $ Right ty_def))
488 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
489 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
490 modA tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
491 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
492 let vecShowFuns = mkVectorShow elTyTm vec_id
493 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
494 let ty_def = AST.SubtypeIn vec_id (Just range)
495 return (Just (ty_id, Just $ Right ty_def))
496 Nothing -> return Nothing
497 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
500 Int -- ^ The minimum bound (> 0)
501 -> Int -- ^ The maximum bound (> minimum bound)
502 -> TypeSession TypeMapRec
503 -- ^ An error message or The typemark created.
504 mkNaturalTy min_bound max_bound = do
505 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
506 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
507 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
508 let ty_def = AST.SubtypeIn unsignedTM (Just range)
509 return (Just (ty_id, Just $ Right ty_def))
512 Int -- ^ Haskell type of the unsigned integer
513 -> TypeSession TypeMapRec
514 mkUnsignedTy size = do
515 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
516 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
517 let ty_def = AST.SubtypeIn unsignedTM (Just range)
518 return (Just (ty_id, Just $ Right ty_def))
521 Int -- ^ Haskell type of the signed integer
522 -> TypeSession TypeMapRec
524 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
525 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
526 let ty_def = AST.SubtypeIn signedTM (Just range)
527 return (Just (ty_id, Just $ Right ty_def))
529 -- Finds the field labels for VHDL type generated for the given Core type,
530 -- which must result in a record type.
531 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
532 getFieldLabels ty = do
533 -- Ensure that the type is generated (but throw away it's VHDLId)
534 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
536 -- Get the types map, lookup and unpack the VHDL TypeDef
537 types <- getA tsTypes
538 -- Assume the type for which we want labels is really translatable
539 htype <- mkHType error_msg ty
540 case Map.lookup htype types of
541 Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
542 Just Nothing -> return [] -- The type is empty
543 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show htype)
545 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
546 mytydecl (_, Nothing) = Nothing
547 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
548 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
550 tfp_to_int :: Type.Type -> TypeSession Int
552 hscenv <- getA tsHscEnv
553 let norm_ty = normalise_tfp_int hscenv ty
554 case Type.splitTyConApp_maybe norm_ty of
555 Just (tycon, args) -> do
556 let name = Name.getOccString (TyCon.tyConName tycon)
559 len <- tfp_to_int' ty
562 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
563 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
564 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
566 tfp_to_int' :: Type.Type -> TypeSession Int
568 lens <- getA tsTfpInts
569 hscenv <- getA tsHscEnv
570 let norm_ty = normalise_tfp_int hscenv ty
571 let existing_len = Map.lookup (OrdType norm_ty) lens
573 Just len -> return len
575 let new_len = eval_tfp_int hscenv ty
576 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
580 [AST.TypeMark] -- ^ type of each tuple element
581 -> AST.TypeMark -- ^ type of the tuple
583 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
585 tupPar = AST.unsafeVHDLBasicId "tup"
586 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
587 showExpr = AST.ReturnSm (Just $
588 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
590 showMiddle = if null elemTMs then
593 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
594 map ((genExprFCall showId).
597 (AST.NSimple tupPar AST.:.:).
599 (take tupSize recordlabels)
600 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
601 tupSize = length elemTMs
607 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
609 enumPar = AST.unsafeVHDLBasicId "enum"
610 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
611 showExpr = AST.ReturnSm (Just $
612 AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
615 AST.TypeMark -- ^ elemtype
616 -> AST.TypeMark -- ^ vectype
617 -> [(String,AST.SubProgBody)]
618 mkVectorShow elemTM vectorTM =
619 [ (headId, AST.SubProgBody headSpec [] [headExpr])
620 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
621 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
624 vecPar = AST.unsafeVHDLBasicId "vec"
625 resId = AST.unsafeVHDLBasicId "res"
626 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
628 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
629 (AST.NSimple vecPar) [AST.PrimLit "0"])))
630 vecSlice init last = AST.PrimName (AST.NSlice
633 (AST.ToRange init last)))
634 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
635 -- variable res : fsvec_x (0 to vec'length-2);
638 (AST.SubtypeIn vectorTM
639 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
640 [AST.ToRange (AST.PrimLit "0")
641 (AST.PrimName (AST.NAttribute $
642 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
643 (AST.PrimLit "2")) ]))
645 -- res AST.:= vec(1 to vec'length-1)
646 tailExpr = AST.NSimple resId AST.:= (vecSlice
648 (AST.PrimName (AST.NAttribute $
649 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
650 AST.:-: AST.PrimLit "1"))
651 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
652 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
653 doShowId = AST.unsafeVHDLExtId "doshow"
654 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
655 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
658 -- when 0 => return "";
659 -- when 1 => return head(vec);
660 -- when others => return show(head(vec)) & ',' &
661 -- doshow (tail(vec));
664 AST.CaseSm (AST.PrimName (AST.NAttribute $
665 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
666 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
667 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
668 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
669 [AST.ReturnSm (Just $
671 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
672 AST.CaseSmAlt [AST.Others]
673 [AST.ReturnSm (Just $
675 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
676 AST.PrimLit "','" AST.:&:
677 genExprFCall doShowId
678 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
679 -- return '<' & doshow(vec) & '>';
680 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
681 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
684 mkBuiltInShow :: [AST.SubProgBody]
685 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
686 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
687 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
688 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
689 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
692 bitPar = AST.unsafeVHDLBasicId "s"
693 boolPar = AST.unsafeVHDLBasicId "b"
694 signedPar = AST.unsafeVHDLBasicId "sint"
695 unsignedPar = AST.unsafeVHDLBasicId "uint"
696 -- naturalPar = AST.unsafeVHDLBasicId "nat"
697 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
698 -- if s = '1' then return "'1'" else return "'0'"
699 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
700 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
702 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
703 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
704 -- if b then return "True" else return "False"
705 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
706 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
708 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
709 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
710 showSignedExpr = AST.ReturnSm (Just $
711 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
712 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
714 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
715 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
716 showUnsignedExpr = AST.ReturnSm (Just $
717 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
718 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
720 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
721 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
722 -- showNaturalExpr = AST.ReturnSm (Just $
723 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
724 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
727 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
728 genExprFCall fName args =
729 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
730 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
732 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
733 genExprPCall2 entid arg1 arg2 =
734 AST.ProcCall (AST.NSimple entid) $
735 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
737 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
739 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
740 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
741 case type_mark_maybe of
742 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
743 Nothing -> return Nothing
745 -- | Does the given thing have a non-empty type?
746 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
747 t -> TranslatorSession Bool
748 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)