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 Data.Accessor.Monad.Trans.State as MonadState
14 import qualified Language.VHDL.AST as AST
17 import qualified CoreSyn
19 import qualified OccName
22 import qualified TyCon
24 import qualified DataCon
25 import qualified CoreSubst
26 import qualified Outputable
29 import CLasH.VHDL.VHDLTypes
30 import CLasH.Translator.TranslatorTypes
31 import CLasH.Utils.Core.CoreTools
33 import CLasH.Utils.Pretty
34 import CLasH.VHDL.Constants
36 -----------------------------------------------------------------------------
37 -- Functions to generate concurrent statements
38 -----------------------------------------------------------------------------
40 -- Create an unconditional assignment statement
42 Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
43 -> AST.Expr -- ^ The expression to assign
44 -> AST.ConcSm -- ^ The resulting concurrent statement
45 mkUncondAssign dst expr = mkAssign dst Nothing expr
47 -- Create a conditional assignment statement
49 Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
50 -> AST.Expr -- ^ The condition
51 -> AST.Expr -- ^ The value when true
52 -> AST.Expr -- ^ The value when false
53 -> AST.ConcSm -- ^ The resulting concurrent statement
54 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
56 -- Create a conditional or unconditional assignment statement
58 Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
59 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
60 -- and the value to assign when true.
61 -> AST.Expr -- ^ The value to assign when false or no condition
62 -> AST.ConcSm -- ^ The resulting concurrent statement
63 mkAssign dst cond false_expr =
65 -- I'm not 100% how this assignment AST works, but this gets us what we
67 whenelse = case cond of
68 Just (cond_expr, true_expr) ->
70 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
72 [AST.WhenElse true_wform cond_expr]
74 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
75 dst_name = case dst of
76 Left bndr -> AST.NSimple (varToVHDLId bndr)
78 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
83 Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
84 -> [AST.Expr] -- ^ The conditions
85 -> [AST.Expr] -- ^ The expressions
86 -> AST.ConcSm -- ^ The Alt assigns
87 mkAltsAssign dst conds exprs
88 | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
91 whenelses = zipWith mkWhenElse conds exprs
92 false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
93 dst_name = case dst of
94 Left bndr -> AST.NSimple (varToVHDLId bndr)
96 assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
100 mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
101 mkWhenElse cond true_expr =
103 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
105 AST.WhenElse true_wform cond
108 [AST.Expr] -- ^ The argument that are applied to function
109 -> AST.VHDLName -- ^ The binder in which to store the result
110 -> Entity -- ^ The entity to map against.
111 -> [AST.AssocElem] -- ^ The resulting port maps
112 mkAssocElems args res entity =
113 arg_maps ++ (Maybe.maybeToList res_map_maybe)
115 arg_ports = ent_args entity
116 res_port_maybe = ent_res entity
117 -- Create an expression of res to map against the output port
118 res_expr = vhdlNameToVHDLExpr res
119 -- Map each of the input ports
120 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
121 -- Map the output port, if present
122 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
124 -- | Create an VHDL port -> signal association
125 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
126 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
128 -- | Create an aggregate signal
129 mkAggregateSignal :: [AST.Expr] -> AST.Expr
130 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
133 String -- ^ The portmap label
134 -> AST.VHDLId -- ^ The entity name
135 -> [AST.AssocElem] -- ^ The port assignments
137 mkComponentInst label entity_id portassigns = AST.CSISm compins
139 -- We always have a clock port, so no need to map it anywhere but here
140 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
141 resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
142 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
144 -----------------------------------------------------------------------------
145 -- Functions to generate VHDL Exprs
146 -----------------------------------------------------------------------------
148 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
150 case Id.isDataConWorkId_maybe var of
151 Just dc -> dataconToVHDLExpr dc
152 -- This is a dataconstructor.
153 -- Not a datacon, just another signal. Perhaps we should check for
154 -- local/global here as well?
155 -- Sadly so.. tfp decimals are types, not data constructors, but instances
156 -- should still be translated to integer literals. It is probebly not the
157 -- best solution to translate them here.
158 -- FIXME: Find a better solution for translating instances of tfp integers
160 let ty = Var.varType var
161 case Type.splitTyConApp_maybe ty of
162 Just (tycon, args) ->
163 case Name.getOccString (TyCon.tyConName tycon) of
166 return $ AST.PrimLit (show len)
167 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
169 -- Turn a VHDLName into an AST expression
170 vhdlNameToVHDLExpr = AST.PrimName
172 -- Turn a VHDL Id into an AST expression
173 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
175 -- Turn a Core expression into an AST expression
176 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
178 -- Turn a alternative constructor into an AST expression. For
179 -- dataconstructors, this is only the constructor itself, not any arguments it
180 -- has. Should not be called with a DEFAULT constructor.
181 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
182 altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
184 altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
185 altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
187 -- Turn a datacon (without arguments!) into a VHDL expression.
188 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
189 dataconToVHDLExpr dc = do
190 typemap <- MonadState.get tsTypes
191 htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
195 let dcname = DataCon.dataConName dc
197 (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
198 (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
200 let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
203 let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
205 Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
206 -- Error when constructing htype
207 Left err -> error err
209 -----------------------------------------------------------------------------
210 -- Functions dealing with names, variables and ids
211 -----------------------------------------------------------------------------
213 -- Creates a VHDL Id from a binder
217 varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
219 lowers :: String -> Int
220 lowers xs = length [x | x <- xs, Char.isLower x]
222 -- Creates a VHDL Name from a binder
226 varToVHDLName = AST.NSimple . varToVHDLId
228 -- Extracts the binder name as a String
232 varToString = OccName.occNameString . Name.nameOccName . Var.varName
234 -- Get the string version a Var's unique
235 varToStringUniq :: Var.Var -> String
236 varToStringUniq = show . Var.varUnique
238 -- Extracts the string version of the name
239 nameToString :: Name.Name -> String
240 nameToString = OccName.occNameString . Name.nameOccName
242 -- Shortcut for Basic VHDL Ids.
243 -- Can only contain alphanumerics and underscores. The supplied string must be
244 -- a valid basic id, otherwise an error value is returned. This function is
245 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
247 mkVHDLBasicId :: String -> AST.VHDLId
249 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
251 -- Strip invalid characters.
252 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
253 -- Strip leading numbers and underscores
254 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
255 -- Strip multiple adjacent underscores
256 strip_multiscore = concatMap (\cs ->
262 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
263 -- different characters than basic ids, but can never be used to refer to
265 -- Use extended Ids for any values that are taken from the source file.
266 mkVHDLExtId :: String -> AST.VHDLId
268 AST.unsafeVHDLExtId $ strip_invalid s
270 -- Allowed characters, taken from ForSyde's mkVHDLExtId
271 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
272 strip_invalid = filter (`elem` allowed)
274 -- Create a record field selector that selects the given label from the record
275 -- stored in the given binder.
276 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
277 mkSelectedName name label =
278 AST.NSelected $ name AST.:.: (AST.SSimple label)
280 -- Create an indexed name that selects a given element from a vector.
281 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
282 -- Special case for already indexed names. Just add an index
283 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
284 AST.NIndexed (AST.IndexedName name (indexes++[index]))
285 -- General case for other names
286 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
288 -----------------------------------------------------------------------------
289 -- Functions dealing with VHDL types
290 -----------------------------------------------------------------------------
291 builtin_types :: TypeMap
294 (BuiltinType "Bit", Just (std_logicTM, Nothing)),
295 (BuiltinType "Bool", Just (booleanTM, Nothing)), -- TysWiredIn.boolTy
296 (BuiltinType "Dec", Just (integerTM, Nothing))
299 -- Is the given type representable at runtime?
300 isReprType :: Type.Type -> TypeSession Bool
302 ty_either <- mkHTypeEither ty
303 return $ case ty_either of
307 -- | Turn a Core type into a HType, returning an error using the given
308 -- error string if the type was not representable.
309 mkHType :: (TypedThing t, Outputable.Outputable t) =>
310 String -> t -> TypeSession HType
312 htype_either <- mkHTypeEither ty
314 Right htype -> return htype
315 Left err -> error $ msg ++ err
317 -- | Turn a Core type into a HType. Returns either an error message if
318 -- the type was not representable, or the HType generated.
319 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
320 t -> TypeSession (Either String HType)
321 mkHTypeEither tything =
322 case getType tything of
323 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
324 Just ty -> mkHTypeEither' ty
326 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
327 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
328 | isStateType ty = return $ Right StateType
330 case Type.splitTyConApp_maybe ty of
331 Just (tycon, args) -> do
332 typemap <- MonadState.get tsTypes
333 let name = Name.getOccString (TyCon.tyConName tycon)
334 let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
335 case builtinTyMaybe of
336 (Just x) -> return $ Right $ BuiltinType name
340 let el_ty = tfvec_elem ty
341 elem_htype_either <- mkHTypeEither el_ty
342 case elem_htype_either of
343 -- Could create element type
344 Right elem_htype -> do
345 len <- tfp_to_int (tfvec_len_ty ty)
346 return $ Right $ VecType len elem_htype
347 -- Could not create element type
348 Left err -> return $ Left $
349 "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
351 len <- tfp_to_int (sized_word_len_ty ty)
352 return $ Right $ SizedWType len
354 len <- tfp_to_int (sized_word_len_ty ty)
355 return $ Right $ SizedIType len
357 bound <- tfp_to_int (ranged_word_bound_ty ty)
358 return $ Right $ RangedWType bound
360 mkTyConHType tycon args
361 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
363 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
364 mkTyConHType tycon args =
365 case TyCon.tyConDataCons tycon of
366 -- Not an algebraic type
367 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
369 let arg_tys = DataCon.dataConRepArgTys dc
370 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
371 let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
372 elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
373 case Either.partitionEithers elem_htys_either of
375 return $ Right elem_hty
376 -- No errors in element types
378 return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
379 -- There were errors in element types
380 (errors, _) -> return $ Left $
381 "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
384 let arg_tys = concatMap DataCon.dataConRepArgTys dcs
385 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
388 return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
389 xs -> return $ Left $
390 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
392 tyvars = TyCon.tyConTyVars tycon
393 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
395 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
396 -- Returns an error value, using the given message, when no type could be
397 -- created. Returns Nothing when the type is valid, but empty.
398 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
399 String -> t -> TypeSession (Maybe AST.TypeMark)
401 htype <- mkHType msg ty
404 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
405 vhdlTyMaybe htype = do
406 typemap <- MonadState.get tsTypes
407 -- If not a builtin type, try the custom types
408 let existing_ty = Map.lookup htype typemap
410 -- Found a type, return it
411 Just (Just (t, _)) -> return $ Just t
412 Just (Nothing) -> return Nothing
413 -- No type yet, try to construct it
415 newty <- (construct_vhdl_ty htype)
416 MonadState.modify tsTypes (Map.insert htype newty)
418 Just (ty_id, ty_def) -> do
419 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
421 Nothing -> return Nothing
423 -- Construct a new VHDL type for the given Haskell type. Returns an error
424 -- message or the resulting typemark and typedef.
425 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
426 -- State types don't generate VHDL
427 construct_vhdl_ty htype =
429 StateType -> return Nothing
430 (SizedWType w) -> mkUnsignedTy w
431 (SizedIType i) -> mkSignedTy i
432 (RangedWType u) -> mkNaturalTy 0 u
433 (VecType n e) -> mkVectorTy (VecType n e)
434 -- Create a custom type from this tycon
435 otherwise -> mkTyconTy htype
437 -- | Create VHDL type for a custom tycon
438 mkTyconTy :: HType -> TypeSession TypeMapRec
441 (AggrType tycon args) -> do
442 elemTysMaybe <- mapM vhdlTyMaybe args
443 case Maybe.catMaybes elemTysMaybe of
444 [] -> -- No non-empty members
447 let elems = zipWith AST.ElementDec recordlabels elem_tys
448 let elem_names = concatMap prettyShow elem_tys
449 let ty_id = mkVHDLExtId $ tycon ++ elem_names
450 let ty_def = AST.TDR $ AST.RecordTypeDef elems
451 let tupshow = mkTupleShow elem_tys ty_id
452 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
453 return $ Just (ty_id, Just $ Left ty_def)
454 (EnumType tycon dcs) -> do
455 let elems = map mkVHDLExtId dcs
456 let ty_id = mkVHDLExtId tycon
457 let ty_def = AST.TDE $ AST.EnumTypeDef elems
458 let enumShow = mkEnumShow elems ty_id
459 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
460 return $ Just (ty_id, Just $ Left ty_def)
461 otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
463 -- Generate a bunch of labels for fields of a record
464 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
466 -- | Create a VHDL vector type
468 HType -- ^ The Haskell type of the Vector
469 -> TypeSession TypeMapRec
470 -- ^ An error message or The typemark created.
472 mkVectorTy (VecType len elHType) = do
473 typesMap <- MonadState.get tsTypes
474 elTyTmMaybe <- vhdlTyMaybe elHType
477 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
478 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
479 let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
480 case existing_uvec_ty of
482 let ty_def = AST.SubtypeIn t (Just range)
483 return (Just (ty_id, Just $ Right ty_def))
485 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
486 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
487 MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
488 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
489 let vecShowFuns = mkVectorShow elTyTm vec_id
490 mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
491 let ty_def = AST.SubtypeIn vec_id (Just range)
492 return (Just (ty_id, Just $ Right ty_def))
493 -- Vector of empty elements becomes empty itself.
494 Nothing -> return Nothing
495 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
498 Int -- ^ The minimum bound (> 0)
499 -> Int -- ^ The maximum bound (> minimum bound)
500 -> TypeSession TypeMapRec
501 -- ^ An error message or The typemark created.
502 mkNaturalTy min_bound max_bound = do
503 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
504 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
505 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
506 let ty_def = AST.SubtypeIn unsignedTM (Just range)
507 return (Just (ty_id, Just $ Right ty_def))
510 Int -- ^ Haskell type of the unsigned integer
511 -> TypeSession TypeMapRec
512 mkUnsignedTy size = do
513 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
514 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
515 let ty_def = AST.SubtypeIn unsignedTM (Just range)
516 return (Just (ty_id, Just $ Right ty_def))
519 Int -- ^ Haskell type of the signed integer
520 -> TypeSession TypeMapRec
522 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
523 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
524 let ty_def = AST.SubtypeIn signedTM (Just range)
525 return (Just (ty_id, Just $ Right ty_def))
527 -- Finds the field labels for VHDL type generated for the given Core type,
528 -- which must result in a record type.
529 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
530 getFieldLabels ty = do
531 -- Ensure that the type is generated (but throw away it's VHDLId)
532 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
534 -- Get the types map, lookup and unpack the VHDL TypeDef
535 types <- MonadState.get tsTypes
536 -- Assume the type for which we want labels is really translatable
537 htype <- mkHType error_msg ty
538 case Map.lookup htype types of
539 Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype)
540 Just Nothing -> return [] -- The type is empty
541 Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
542 Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)
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)
560 MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (-1))
561 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
562 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
564 tfp_to_int' :: Type.Type -> TypeSession Int
566 lens <- MonadState.get tsTfpInts
567 hscenv <- MonadState.get tsHscEnv
568 let norm_ty = normalise_tfp_int hscenv ty
569 let existing_len = Map.lookup (OrdType norm_ty) lens
571 Just len -> return len
573 let new_len = eval_tfp_int hscenv ty
574 MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
578 [AST.TypeMark] -- ^ type of each tuple element
579 -> AST.TypeMark -- ^ type of the tuple
581 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
583 tupPar = AST.unsafeVHDLBasicId "tup"
584 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
585 showExpr = AST.ReturnSm (Just $
586 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
588 showMiddle = if null elemTMs then
591 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
592 map ((genExprFCall showId).
595 (AST.NSimple tupPar AST.:.:).
597 (take tupSize recordlabels)
598 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
599 tupSize = length elemTMs
605 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
607 enumPar = AST.unsafeVHDLBasicId "enum"
608 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
609 showExpr = AST.ReturnSm (Just $
610 AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
613 AST.TypeMark -- ^ elemtype
614 -> AST.TypeMark -- ^ vectype
615 -> [(String,AST.SubProgBody)]
616 mkVectorShow elemTM vectorTM =
617 [ (headId, AST.SubProgBody headSpec [] [headExpr])
618 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
619 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
622 vecPar = AST.unsafeVHDLBasicId "vec"
623 resId = AST.unsafeVHDLBasicId "res"
624 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
626 headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
627 (AST.NSimple vecPar) [AST.PrimLit "0"])))
628 vecSlice init last = AST.PrimName (AST.NSlice
631 (AST.ToRange init last)))
632 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
633 -- variable res : fsvec_x (0 to vec'length-2);
636 (AST.SubtypeIn vectorTM
637 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
638 [AST.ToRange (AST.PrimLit "0")
639 (AST.PrimName (AST.NAttribute $
640 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
641 (AST.PrimLit "2")) ]))
643 -- res AST.:= vec(1 to vec'length-1)
644 tailExpr = AST.NSimple resId AST.:= (vecSlice
646 (AST.PrimName (AST.NAttribute $
647 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
648 AST.:-: AST.PrimLit "1"))
649 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
650 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
651 doShowId = AST.unsafeVHDLExtId "doshow"
652 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
653 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
656 -- when 0 => return "";
657 -- when 1 => return head(vec);
658 -- when others => return show(head(vec)) & ',' &
659 -- doshow (tail(vec));
662 AST.CaseSm (AST.PrimName (AST.NAttribute $
663 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
664 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
665 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
666 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
667 [AST.ReturnSm (Just $
669 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
670 AST.CaseSmAlt [AST.Others]
671 [AST.ReturnSm (Just $
673 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
674 AST.PrimLit "','" AST.:&:
675 genExprFCall doShowId
676 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
677 -- return '<' & doshow(vec) & '>';
678 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
679 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
682 mkBuiltInShow :: [AST.SubProgBody]
683 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
684 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
685 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
686 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
687 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
690 bitPar = AST.unsafeVHDLBasicId "s"
691 boolPar = AST.unsafeVHDLBasicId "b"
692 signedPar = AST.unsafeVHDLBasicId "sint"
693 unsignedPar = AST.unsafeVHDLBasicId "uint"
694 -- naturalPar = AST.unsafeVHDLBasicId "nat"
695 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
696 -- if s = '1' then return "'1'" else return "'0'"
697 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
698 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
700 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
701 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
702 -- if b then return "True" else return "False"
703 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
704 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
706 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
707 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
708 showSignedExpr = AST.ReturnSm (Just $
709 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
710 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
712 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
713 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
714 showUnsignedExpr = AST.ReturnSm (Just $
715 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
716 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
718 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
719 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
720 -- showNaturalExpr = AST.ReturnSm (Just $
721 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
722 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
725 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
726 genExprFCall fName args =
727 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
728 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
730 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
731 genExprPCall2 entid arg1 arg2 =
732 AST.ProcCall (AST.NSimple entid) $
733 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
735 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
737 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
738 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
739 case type_mark_maybe of
740 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
741 Nothing -> return Nothing
743 -- | Does the given thing have a non-empty type?
744 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
745 t -> TranslatorSession Bool
746 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)