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
14 import Data.Accessor.Monad.Trans.State as MonadState
18 import qualified Language.VHDL.AST as AST
23 import qualified OccName
26 import qualified IdInfo
27 import qualified TyCon
29 import qualified DataCon
30 import qualified CoreSubst
31 import qualified Outputable
34 import CLasH.VHDL.VHDLTypes
35 import CLasH.Translator.TranslatorTypes
36 import CLasH.Utils.Core.CoreTools
38 import CLasH.Utils.Pretty
39 import CLasH.VHDL.Constants
41 -----------------------------------------------------------------------------
42 -- Functions to generate concurrent statements
43 -----------------------------------------------------------------------------
45 -- Create an unconditional assignment statement
47 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
48 -> AST.Expr -- ^ The expression to assign
49 -> AST.ConcSm -- ^ The resulting concurrent statement
50 mkUncondAssign dst expr = mkAssign dst Nothing expr
52 -- Create a conditional assignment statement
54 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
55 -> AST.Expr -- ^ The condition
56 -> AST.Expr -- ^ The value when true
57 -> AST.Expr -- ^ The value when false
58 -> AST.ConcSm -- ^ The resulting concurrent statement
59 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
61 -- Create a conditional or unconditional assignment statement
63 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
64 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
65 -- and the value to assign when true.
66 -> AST.Expr -- ^ The value to assign when false or no condition
67 -> AST.ConcSm -- ^ The resulting concurrent statement
68 mkAssign dst cond false_expr =
70 -- I'm not 100% how this assignment AST works, but this gets us what we
72 whenelse = case cond of
73 Just (cond_expr, true_expr) ->
75 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
77 [AST.WhenElse true_wform cond_expr]
79 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
80 dst_name = case dst of
81 Left bndr -> AST.NSimple (varToVHDLId bndr)
83 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
88 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
89 -> [AST.Expr] -- ^ The conditions
90 -> [AST.Expr] -- ^ The expressions
91 -> AST.ConcSm -- ^ The Alt assigns
92 mkAltsAssign dst conds exprs
93 | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
96 whenelses = zipWith mkWhenElse conds exprs
97 false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
98 dst_name = case dst of
99 Left bndr -> AST.NSimple (varToVHDLId bndr)
101 assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
105 mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
106 mkWhenElse cond true_expr =
108 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
110 AST.WhenElse true_wform cond
113 [AST.Expr] -- ^ The argument that are applied to function
114 -> AST.VHDLName -- ^ The binder in which to store the result
115 -> Entity -- ^ The entity to map against.
116 -> [AST.AssocElem] -- ^ The resulting port maps
117 mkAssocElems args res entity =
118 arg_maps ++ (Maybe.maybeToList res_map_maybe)
120 arg_ports = ent_args entity
121 res_port_maybe = ent_res entity
122 -- Create an expression of res to map against the output port
123 res_expr = vhdlNameToVHDLExpr res
124 -- Map each of the input ports
125 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
126 -- Map the output port, if present
127 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
129 -- | Create an VHDL port -> signal association
130 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
131 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
133 -- | Create an aggregate signal
134 mkAggregateSignal :: [AST.Expr] -> AST.Expr
135 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
138 String -- ^ The portmap label
139 -> AST.VHDLId -- ^ The entity name
140 -> [AST.AssocElem] -- ^ The port assignments
142 mkComponentInst label entity_id portassigns = AST.CSISm compins
144 -- We always have a clock port, so no need to map it anywhere but here
145 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
146 resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
147 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
149 -----------------------------------------------------------------------------
150 -- Functions to generate VHDL Exprs
151 -----------------------------------------------------------------------------
153 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
154 varToVHDLExpr var = do
155 case Id.isDataConWorkId_maybe var of
156 Just dc -> dataconToVHDLExpr dc
157 -- This is a dataconstructor.
158 -- Not a datacon, just another signal. Perhaps we should check for
159 -- local/global here as well?
160 -- Sadly so.. tfp decimals are types, not data constructors, but instances
161 -- should still be translated to integer literals. It is probebly not the
162 -- best solution to translate them here.
163 -- FIXME: Find a better solution for translating instances of tfp integers
165 let ty = Var.varType var
166 case Type.splitTyConApp_maybe ty of
167 Just (tycon, args) ->
168 case Name.getOccString (TyCon.tyConName tycon) of
171 return $ AST.PrimLit $ (show len)
172 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
174 -- Turn a VHDLName into an AST expression
175 vhdlNameToVHDLExpr = AST.PrimName
177 -- Turn a VHDL Id into an AST expression
178 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
180 -- Turn a Core expression into an AST expression
181 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
183 -- Turn a alternative constructor into an AST expression. For
184 -- dataconstructors, this is only the constructor itself, not any arguments it
185 -- has. Should not be called with a DEFAULT constructor.
186 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
187 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
189 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
190 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
192 -- Turn a datacon (without arguments!) into a VHDL expression.
193 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
194 dataconToVHDLExpr dc = do
195 typemap <- MonadState.get tsTypes
196 htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
200 let dcname = DataCon.dataConName dc
202 (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
203 (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
205 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
208 let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
210 Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
211 -- Error when constructing htype
212 Left err -> error err
214 -----------------------------------------------------------------------------
215 -- Functions dealing with names, variables and ids
216 -----------------------------------------------------------------------------
218 -- Creates a VHDL Id from a binder
222 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
224 lowers :: String -> Int
225 lowers xs = length [x | x <- xs, Char.isLower x]
227 -- Creates a VHDL Name from a binder
231 varToVHDLName = AST.NSimple . varToVHDLId
233 -- Extracts the binder name as a String
237 varToString = OccName.occNameString . Name.nameOccName . Var.varName
239 -- Get the string version a Var's unique
240 varToStringUniq :: Var.Var -> String
241 varToStringUniq = show . Var.varUnique
243 -- Extracts the string version of the name
244 nameToString :: Name.Name -> String
245 nameToString = OccName.occNameString . Name.nameOccName
247 -- Shortcut for Basic VHDL Ids.
248 -- Can only contain alphanumerics and underscores. The supplied string must be
249 -- a valid basic id, otherwise an error value is returned. This function is
250 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
252 mkVHDLBasicId :: String -> AST.VHDLId
254 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
256 -- Strip invalid characters.
257 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
258 -- Strip leading numbers and underscores
259 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
260 -- Strip multiple adjacent underscores
261 strip_multiscore = concat . map (\cs ->
267 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
268 -- different characters than basic ids, but can never be used to refer to
270 -- Use extended Ids for any values that are taken from the source file.
271 mkVHDLExtId :: String -> AST.VHDLId
273 AST.unsafeVHDLExtId $ strip_invalid s
275 -- Allowed characters, taken from ForSyde's mkVHDLExtId
276 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
277 strip_invalid = filter (`elem` allowed)
279 -- Create a record field selector that selects the given label from the record
280 -- stored in the given binder.
281 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
282 mkSelectedName name label =
283 AST.NSelected $ name AST.:.: (AST.SSimple label)
285 -- Create an indexed name that selects a given element from a vector.
286 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
287 -- Special case for already indexed names. Just add an index
288 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
289 AST.NIndexed (AST.IndexedName name (indexes++[index]))
290 -- General case for other names
291 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
293 -----------------------------------------------------------------------------
294 -- Functions dealing with VHDL types
295 -----------------------------------------------------------------------------
296 builtin_types :: TypeMap
299 (BuiltinType "Bit", Just (std_logicTM, Nothing)),
300 (BuiltinType "Bool", Just (booleanTM, Nothing)), -- TysWiredIn.boolTy
301 (BuiltinType "Dec", Just (integerTM, Nothing))
304 -- Is the given type representable at runtime?
305 isReprType :: Type.Type -> TypeSession Bool
307 ty_either <- mkHTypeEither ty
308 return $ case ty_either of
312 mkHType :: (TypedThing t, Outputable.Outputable t) =>
313 String -> t -> TypeSession HType
315 htype_either <- mkHTypeEither ty
317 Right htype -> return htype
318 Left err -> error $ msg ++ err
320 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
321 t -> TypeSession (Either String HType)
322 mkHTypeEither tything = do
323 case getType tything of
324 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
325 Just ty -> mkHTypeEither' ty
327 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
328 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
329 | isStateType ty = return $ Right StateType
331 case Type.splitTyConApp_maybe ty of
332 Just (tycon, args) -> do
333 typemap <- MonadState.get tsTypes
334 let name = Name.getOccString (TyCon.tyConName tycon)
335 let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
336 case builtinTyMaybe of
337 (Just x) -> return $ Right $ BuiltinType name
341 let el_ty = tfvec_elem ty
342 elem_htype_either <- mkHTypeEither el_ty
343 case elem_htype_either of
344 -- Could create element type
345 Right elem_htype -> do
346 len <- tfp_to_int (tfvec_len_ty ty)
347 return $ Right $ VecType len elem_htype
348 -- Could not create element type
349 Left err -> return $ Left $
350 "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
352 len <- tfp_to_int (sized_word_len_ty ty)
353 return $ Right $ SizedWType len
355 len <- tfp_to_int (sized_word_len_ty ty)
356 return $ Right $ SizedIType len
358 bound <- tfp_to_int (ranged_word_bound_ty ty)
359 return $ Right $ RangedWType bound
361 mkTyConHType tycon args
362 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
364 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
365 mkTyConHType tycon args =
366 case TyCon.tyConDataCons tycon of
367 -- Not an algebraic type
368 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
370 let arg_tys = DataCon.dataConRepArgTys dc
371 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
372 let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
373 elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
374 case Either.partitionEithers elem_htys_either of
375 ([], [elem_hty]) -> do
376 return $ Right elem_hty
377 -- No errors in element types
378 ([], elem_htys) -> do
379 return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
380 -- There were errors in element types
381 (errors, _) -> return $ Left $
382 "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
385 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
386 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
389 return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
390 xs -> return $ Left $
391 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
393 tyvars = TyCon.tyConTyVars tycon
394 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
396 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
397 -- Returns an error value, using the given message, when no type could be
398 -- created. Returns Nothing when the type is valid, but empty.
399 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
400 String -> t -> TypeSession (Maybe AST.TypeMark)
402 htype <- mkHType msg ty
403 tm <- vhdlTyMaybe htype
406 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
407 vhdlTyMaybe htype = do
408 typemap <- MonadState.get tsTypes
409 -- If not a builtin type, try the custom types
410 let existing_ty = Map.lookup htype typemap
412 -- Found a type, return it
413 Just (Just (t, _)) -> return $ Just t
414 Just (Nothing) -> return Nothing
415 -- No type yet, try to construct it
417 newty <- (construct_vhdl_ty htype)
418 MonadState.modify tsTypes (Map.insert htype newty)
420 Just (ty_id, ty_def) -> do
421 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
423 Nothing -> return Nothing
425 -- Construct a new VHDL type for the given Haskell type. Returns an error
426 -- message or the resulting typemark and typedef.
427 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
428 -- State types don't generate VHDL
429 construct_vhdl_ty htype = do
431 StateType -> return Nothing
432 (SizedWType w) -> mkUnsignedTy w
433 (SizedIType i) -> mkSignedTy i
434 (RangedWType u) -> mkNaturalTy 0 u
435 (VecType n e) -> mkVectorTy (VecType n e)
436 -- Create a custom type from this tycon
437 otherwise -> mkTyconTy htype
439 -- | Create VHDL type for a custom tycon
440 mkTyconTy :: HType -> TypeSession TypeMapRec
443 (AggrType tycon args) -> do
444 elemTysMaybe <- mapM vhdlTyMaybe args
445 case Maybe.catMaybes elemTysMaybe of
446 [] -> -- No non-empty members
449 let elems = zipWith AST.ElementDec recordlabels elem_tys
450 let elem_names = concat $ map prettyShow elem_tys
451 let ty_id = mkVHDLExtId $ tycon ++ elem_names
452 let ty_def = AST.TDR $ AST.RecordTypeDef elems
453 let tupshow = mkTupleShow elem_tys ty_id
454 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
455 return $ Just (ty_id, Just $ Left ty_def)
456 (EnumType tycon dcs) -> do
457 let elems = map mkVHDLExtId dcs
458 let ty_id = mkVHDLExtId tycon
459 let ty_def = AST.TDE $ AST.EnumTypeDef elems
460 let enumShow = mkEnumShow elems ty_id
461 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
462 return $ Just (ty_id, Just $ Left ty_def)
463 otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
465 -- Generate a bunch of labels for fields of a record
466 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
468 -- | Create a VHDL vector type
470 HType -- ^ The Haskell type of the Vector
471 -> TypeSession TypeMapRec
472 -- ^ An error message or The typemark created.
474 mkVectorTy (VecType len elHType) = do
475 typesMap <- MonadState.get tsTypes
476 elTyTmMaybe <- vhdlTyMaybe elHType
479 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
480 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
481 let existing_uvec_ty = (fmap $ fmap fst) $ Map.lookup (UVecType elHType) typesMap
482 case existing_uvec_ty of
484 let ty_def = AST.SubtypeIn t (Just range)
485 return (Just (ty_id, Just $ Right ty_def))
487 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
488 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
489 MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
490 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
491 let vecShowFuns = mkVectorShow elTyTm vec_id
492 mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
493 let ty_def = AST.SubtypeIn vec_id (Just range)
494 return (Just (ty_id, Just $ Right ty_def))
495 Nothing -> return Nothing
496 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
499 Int -- ^ The minimum bound (> 0)
500 -> Int -- ^ The maximum bound (> minimum bound)
501 -> TypeSession TypeMapRec
502 -- ^ An error message or The typemark created.
503 mkNaturalTy min_bound max_bound = do
504 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
505 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
506 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
507 let ty_def = AST.SubtypeIn unsignedTM (Just range)
508 return (Just (ty_id, Just $ Right ty_def))
511 Int -- ^ Haskell type of the unsigned integer
512 -> TypeSession TypeMapRec
513 mkUnsignedTy size = do
514 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
515 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
516 let ty_def = AST.SubtypeIn unsignedTM (Just range)
517 return (Just (ty_id, Just $ Right ty_def))
520 Int -- ^ Haskell type of the signed integer
521 -> TypeSession TypeMapRec
523 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
524 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
525 let ty_def = AST.SubtypeIn signedTM (Just range)
526 return (Just (ty_id, Just $ Right ty_def))
528 -- Finds the field labels for VHDL type generated for the given Core type,
529 -- which must result in a record type.
530 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
531 getFieldLabels ty = do
532 -- Ensure that the type is generated (but throw away it's VHDLId)
533 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
535 -- Get the types map, lookup and unpack the VHDL TypeDef
536 types <- MonadState.get tsTypes
537 -- Assume the type for which we want labels is really translatable
538 htype <- mkHType error_msg ty
539 case Map.lookup htype types of
540 Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
541 Just Nothing -> return [] -- The type is empty
542 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show htype)
544 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
545 mytydecl (_, Nothing) = Nothing
546 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
547 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
549 tfp_to_int :: Type.Type -> TypeSession Int
551 hscenv <- MonadState.get tsHscEnv
552 let norm_ty = normalise_tfp_int hscenv ty
553 case Type.splitTyConApp_maybe norm_ty of
554 Just (tycon, args) -> do
555 let name = Name.getOccString (TyCon.tyConName tycon)
558 len <- tfp_to_int' ty
561 MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1))
562 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
563 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
565 tfp_to_int' :: Type.Type -> TypeSession Int
567 lens <- MonadState.get tsTfpInts
568 hscenv <- MonadState.get tsHscEnv
569 let norm_ty = normalise_tfp_int hscenv ty
570 let existing_len = Map.lookup (OrdType norm_ty) lens
572 Just len -> return len
574 let new_len = eval_tfp_int hscenv ty
575 MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
579 [AST.TypeMark] -- ^ type of each tuple element
580 -> AST.TypeMark -- ^ type of the tuple
582 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
584 tupPar = AST.unsafeVHDLBasicId "tup"
585 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
586 showExpr = AST.ReturnSm (Just $
587 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
589 showMiddle = if null elemTMs then
592 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
593 map ((genExprFCall showId).
596 (AST.NSimple tupPar AST.:.:).
598 (take tupSize recordlabels)
599 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
600 tupSize = length elemTMs
606 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
608 enumPar = AST.unsafeVHDLBasicId "enum"
609 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
610 showExpr = AST.ReturnSm (Just $
611 AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
614 AST.TypeMark -- ^ elemtype
615 -> AST.TypeMark -- ^ vectype
616 -> [(String,AST.SubProgBody)]
617 mkVectorShow elemTM vectorTM =
618 [ (headId, AST.SubProgBody headSpec [] [headExpr])
619 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
620 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
623 vecPar = AST.unsafeVHDLBasicId "vec"
624 resId = AST.unsafeVHDLBasicId "res"
625 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
627 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
628 (AST.NSimple vecPar) [AST.PrimLit "0"])))
629 vecSlice init last = AST.PrimName (AST.NSlice
632 (AST.ToRange init last)))
633 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
634 -- variable res : fsvec_x (0 to vec'length-2);
637 (AST.SubtypeIn vectorTM
638 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
639 [AST.ToRange (AST.PrimLit "0")
640 (AST.PrimName (AST.NAttribute $
641 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
642 (AST.PrimLit "2")) ]))
644 -- res AST.:= vec(1 to vec'length-1)
645 tailExpr = AST.NSimple resId AST.:= (vecSlice
647 (AST.PrimName (AST.NAttribute $
648 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
649 AST.:-: AST.PrimLit "1"))
650 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
651 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
652 doShowId = AST.unsafeVHDLExtId "doshow"
653 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
654 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
657 -- when 0 => return "";
658 -- when 1 => return head(vec);
659 -- when others => return show(head(vec)) & ',' &
660 -- doshow (tail(vec));
663 AST.CaseSm (AST.PrimName (AST.NAttribute $
664 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
665 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
666 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
667 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
668 [AST.ReturnSm (Just $
670 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
671 AST.CaseSmAlt [AST.Others]
672 [AST.ReturnSm (Just $
674 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
675 AST.PrimLit "','" AST.:&:
676 genExprFCall doShowId
677 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
678 -- return '<' & doshow(vec) & '>';
679 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
680 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
683 mkBuiltInShow :: [AST.SubProgBody]
684 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
685 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
686 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
687 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
688 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
691 bitPar = AST.unsafeVHDLBasicId "s"
692 boolPar = AST.unsafeVHDLBasicId "b"
693 signedPar = AST.unsafeVHDLBasicId "sint"
694 unsignedPar = AST.unsafeVHDLBasicId "uint"
695 -- naturalPar = AST.unsafeVHDLBasicId "nat"
696 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
697 -- if s = '1' then return "'1'" else return "'0'"
698 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
699 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
701 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
702 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
703 -- if b then return "True" else return "False"
704 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
705 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
707 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
708 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
709 showSignedExpr = AST.ReturnSm (Just $
710 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
711 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
713 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
714 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
715 showUnsignedExpr = AST.ReturnSm (Just $
716 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
717 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
719 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
720 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
721 -- showNaturalExpr = AST.ReturnSm (Just $
722 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
723 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
726 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
727 genExprFCall fName args =
728 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
729 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
731 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
732 genExprPCall2 entid arg1 arg2 =
733 AST.ProcCall (AST.NSimple entid) $
734 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
736 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
738 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
739 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
740 case type_mark_maybe of
741 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
742 Nothing -> return Nothing
744 -- | Does the given thing have a non-empty type?
745 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
746 t -> TranslatorSession Bool
747 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)