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 -- This is a dataconstructor.
152 Just dc -> dataconToVHDLExpr dc
153 -- Not a datacon, just another signal.
154 Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
156 -- Turn a VHDLName into an AST expression
157 vhdlNameToVHDLExpr = AST.PrimName
159 -- Turn a VHDL Id into an AST expression
160 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
162 -- Turn a Core expression into an AST expression
163 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
165 -- Turn a String into a VHDL expr containing an id
166 stringToVHDLExpr :: String -> AST.Expr
167 stringToVHDLExpr = idToVHDLExpr . mkVHDLExtId
170 -- Turn a alternative constructor into an AST expression. For
171 -- dataconstructors, this is only the constructor itself, not any arguments it
172 -- has. Should not be called with a DEFAULT constructor.
173 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
174 altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
176 altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
177 altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
179 -- Turn a datacon (without arguments!) into a VHDL expression.
180 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
181 dataconToVHDLExpr dc = do
182 typemap <- MonadState.get tsTypes
183 htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
187 let dcname = DataCon.dataConName dc
189 (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
190 (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
192 let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
195 let lit = AST.PrimLit $ show $ getConstructorIndex htype $ Name.getOccString dcname
197 Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
198 -- Error when constructing htype
199 Left err -> error err
201 -----------------------------------------------------------------------------
202 -- Functions dealing with names, variables and ids
203 -----------------------------------------------------------------------------
205 -- Creates a VHDL Id from a binder
209 varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
211 lowers :: String -> Int
212 lowers xs = length [x | x <- xs, Char.isLower x]
214 -- Creates a VHDL Name from a binder
218 varToVHDLName = AST.NSimple . varToVHDLId
220 -- Extracts the binder name as a String
224 varToString = OccName.occNameString . Name.nameOccName . Var.varName
226 -- Get the string version a Var's unique
227 varToStringUniq :: Var.Var -> String
228 varToStringUniq = show . Var.varUnique
230 -- Extracts the string version of the name
231 nameToString :: Name.Name -> String
232 nameToString = OccName.occNameString . Name.nameOccName
234 -- Shortcut for Basic VHDL Ids.
235 -- Can only contain alphanumerics and underscores. The supplied string must be
236 -- a valid basic id, otherwise an error value is returned. This function is
237 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
239 mkVHDLBasicId :: String -> AST.VHDLId
241 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
243 -- Strip invalid characters.
244 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
245 -- Strip leading numbers and underscores
246 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
247 -- Strip multiple adjacent underscores
248 strip_multiscore = concatMap (\cs ->
254 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
255 -- different characters than basic ids, but can never be used to refer to
257 -- Use extended Ids for any values that are taken from the source file.
258 mkVHDLExtId :: String -> AST.VHDLId
260 (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s
262 -- Allowed characters, taken from ForSyde's mkVHDLExtId
263 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
264 strip_invalid = filter (`elem` allowed)
265 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
266 strip_multiscore = concatMap (\cs ->
272 -- Create a record field selector that selects the given label from the record
273 -- stored in the given binder.
274 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
275 mkSelectedName name label =
276 AST.NSelected $ name AST.:.: (AST.SSimple label)
278 -- Create an indexed name that selects a given element from a vector.
279 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
280 -- Special case for already indexed names. Just add an index
281 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
282 AST.NIndexed (AST.IndexedName name (indexes++[index]))
283 -- General case for other names
284 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
286 -----------------------------------------------------------------------------
287 -- Functions dealing with VHDL types
288 -----------------------------------------------------------------------------
289 builtin_types :: TypeMap
292 (BuiltinType "Bit", Just (std_logicTM, Nothing)),
293 (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
296 -- Is the given type representable at runtime?
297 isReprType :: Type.Type -> TypeSession Bool
299 ty_either <- mkHTypeEither ty
300 return $ case ty_either of
304 -- | Turn a Core type into a HType, returning an error using the given
305 -- error string if the type was not representable.
306 mkHType :: (TypedThing t, Outputable.Outputable t) =>
307 String -> t -> TypeSession HType
309 htype_either <- mkHTypeEither ty
311 Right htype -> return htype
312 Left err -> error $ msg ++ err
314 -- | Turn a Core type into a HType. Returns either an error message if
315 -- the type was not representable, or the HType generated.
316 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
317 t -> TypeSession (Either String HType)
318 mkHTypeEither tything =
319 case getType tything of
320 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
321 Just ty -> mkHTypeEither' ty
323 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
324 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
325 | isStateType ty = return $ Right StateType
327 case Type.splitTyConApp_maybe ty of
328 Just (tycon, args) -> do
329 typemap <- MonadState.get tsTypes
330 let name = Name.getOccString (TyCon.tyConName tycon)
331 let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
332 case builtinTyMaybe of
333 (Just x) -> return $ Right $ BuiltinType name
337 let el_ty = tfvec_elem ty
338 elem_htype_either <- mkHTypeEither el_ty
339 case elem_htype_either of
340 -- Could create element type
341 Right elem_htype -> do
342 len <- tfp_to_int (tfvec_len_ty ty)
343 return $ Right $ VecType len elem_htype
344 -- Could not create element type
345 Left err -> return $ Left $
346 "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
348 len <- tfp_to_int (sized_word_len_ty ty)
349 return $ Right $ SizedWType len
351 len <- tfp_to_int (sized_word_len_ty ty)
352 return $ Right $ SizedIType len
354 bound <- tfp_to_int (ranged_word_bound_ty ty)
355 -- Upperbound is exclusive, hence the -1
356 return $ Right $ RangedWType (bound - 1)
358 mkTyConHType tycon args
359 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
361 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
362 mkTyConHType tycon args =
363 case TyCon.tyConDataCons tycon of
364 -- Not an algebraic type
365 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
367 let arg_tyss = map DataCon.dataConRepArgTys dcs
368 let enum_ty = EnumType name (map (nameToString . DataCon.dataConName) dcs)
369 case (concat arg_tyss) of
370 -- No arguments, this is just an enumeration type
371 [] -> return (Right enum_ty)
372 -- At least one argument, this becomes an aggregate type
374 -- Resolve any type arguments to this type
375 let real_arg_tyss = map (map (CoreSubst.substTy subst)) arg_tyss
376 -- Remove any state type fields
377 let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss
378 elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate
379 let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either)
380 case (all null errors) of
381 True -> case (dcs, concat elem_htyss) of
382 -- A single constructor with a single (non-state) field?
383 ([dc], [elem_hty]) -> return $ Right elem_hty
384 -- If we get here, then all of the argument types were state
385 -- types (we check for enumeration types at the top). Not
386 -- sure how to handle this, so error out for now.
387 (_, []) -> error $ "ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args
388 -- A full ADT (with multiple fields and one or multiple
391 let (_, fieldss) = List.mapAccumL (List.mapAccumL label_field) labels elem_htyss
392 -- Only put in an enumeration as part of the aggregation
393 -- when there are multiple datacons
394 let enum_ty_part = case dcs of
396 _ -> Just ("constructor", enum_ty)
397 -- Create the AggrType HType
398 return $ Right $ AggrType name enum_ty_part fieldss
399 -- There were errors in element types
400 False -> return $ Left $
401 "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
402 ++ (concat $ concat errors)
404 name = (nameToString (TyCon.tyConName tycon))
405 tyvars = TyCon.tyConTyVars tycon
406 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
407 -- Label a field by taking the first available label and returning
409 label_field :: [String] -> HType -> ([String], (String, HType))
410 label_field (l:ls) htype = (ls, (l, htype))
411 labels = map (:[]) ['A'..'Z']
413 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
414 String -> t -> TypeSession (Maybe AST.TypeMark)
416 htype <- mkHType msg ty
419 -- | Translate a Haskell type to a VHDL type, generating a new type if needed.
420 -- Returns an error value, using the given message, when no type could be
421 -- created. Returns Nothing when the type is valid, but empty.
422 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
423 vhdlTyMaybe htype = do
424 typemap <- MonadState.get tsTypes
425 -- If not a builtin type, try the custom types
426 let existing_ty = Map.lookup htype typemap
428 -- Found a type, return it
429 Just (Just (t, _)) -> return $ Just t
430 Just (Nothing) -> return Nothing
431 -- No type yet, try to construct it
433 newty <- (construct_vhdl_ty htype)
434 MonadState.modify tsTypes (Map.insert htype newty)
436 Just (ty_id, ty_def) -> do
437 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
439 Nothing -> return Nothing
441 -- Construct a new VHDL type for the given Haskell type. Returns an error
442 -- message or the resulting typemark and typedef.
443 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
444 -- State types don't generate VHDL
445 construct_vhdl_ty htype =
447 StateType -> return Nothing
448 (SizedWType w) -> mkUnsignedTy w
449 (SizedIType i) -> mkSignedTy i
450 (RangedWType u) -> mkNaturalTy 0 u
451 (VecType n e) -> mkVectorTy (VecType n e)
452 -- Create a custom type from this tycon
453 otherwise -> mkTyconTy htype
455 -- | Create VHDL type for a custom tycon
456 mkTyconTy :: HType -> TypeSession TypeMapRec
459 (AggrType name enum_field_maybe fieldss) -> do
460 let (labelss, elem_htypess) = unzip (map unzip fieldss)
461 elemTyMaybess <- mapM (mapM vhdlTyMaybe) elem_htypess
462 let elem_tyss = map Maybe.catMaybes elemTyMaybess
463 case concat elem_tyss of
464 [] -> -- No non-empty fields
467 let reclabelss = map (map mkVHDLBasicId) labelss
468 let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss
469 let elem_names = concatMap (concatMap prettyShow) elem_tyss
470 let ty_id = mkVHDLExtId $ name ++ elem_names
471 -- Find out if we need to add an extra field at the start of
472 -- the record type containing the constructor (only needed
473 -- when there's more than one constructor).
474 enum_ty_maybe <- case enum_field_maybe of
475 Nothing -> return Nothing
476 Just (_, enum_htype) -> do
477 enum_ty_maybe' <- vhdlTyMaybe enum_htype
478 case enum_ty_maybe' of
479 Nothing -> error $ "Couldn't translate enumeration type part of AggrType: " ++ show htype
480 -- Note that the first Just means the type is
481 -- translateable, while the second Just means that there
482 -- is a enum_ty at all (e.g., there's multiple
484 Just enum_ty -> return $ Just enum_ty
485 -- Create an record field declaration for the first
486 -- constructor field, if needed.
487 enum_dec_maybe <- case enum_field_maybe of
488 Nothing -> return $ Nothing
489 Just (enum_name, enum_htype) -> do
490 enum_vhdl_ty_maybe <- vhdlTyMaybe enum_htype
491 let enum_vhdl_ty = Maybe.fromMaybe (error $ "\nVHDLTools.mkTyconTy: Enumeration field should not have empty type: " ++ show enum_htype) enum_vhdl_ty_maybe
492 return $ Just $ AST.ElementDec (mkVHDLBasicId enum_name) enum_vhdl_ty
493 -- Turn the maybe into a list, so we can prepend it.
494 let enum_decs = Maybe.maybeToList enum_dec_maybe
495 let enum_tys = Maybe.maybeToList enum_ty_maybe
496 let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
497 let aggrshow = case enum_field_maybe of
498 Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
499 Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
500 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
501 return $ Just (ty_id, Just $ Left ty_def)
502 (EnumType tycon dcs) -> do
503 let ty_id = mkVHDLExtId tycon
504 let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))
505 let ty_def = AST.TDI $ AST.IntegerTypeDef range
506 let enumShow = mkEnumShow dcs ty_id
507 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
508 return $ Just (ty_id, Just $ Left ty_def)
509 otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
511 -- | Create a VHDL vector type
513 HType -- ^ The Haskell type of the Vector
514 -> TypeSession TypeMapRec
515 -- ^ An error message or The typemark created.
517 mkVectorTy (VecType len elHType) = do
518 typesMap <- MonadState.get tsTypes
519 elTyTmMaybe <- vhdlTyMaybe elHType
522 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
523 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
524 let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
525 case existing_uvec_ty of
527 let ty_def = AST.SubtypeIn t (Just range)
528 return (Just (ty_id, Just $ Right ty_def))
530 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
531 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
532 MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
533 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
534 let vecShowFuns = mkVectorShow elTyTm vec_id
535 mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
536 let ty_def = AST.SubtypeIn vec_id (Just range)
537 return (Just (ty_id, Just $ Right ty_def))
538 -- Vector of empty elements becomes empty itself.
539 Nothing -> return Nothing
540 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
543 Int -- ^ The minimum bound (> 0)
544 -> Int -- ^ The maximum bound (> minimum bound)
545 -> TypeSession TypeMapRec
546 -- ^ An error message or The typemark created.
547 mkNaturalTy min_bound max_bound = do
548 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
549 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
550 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
551 let ty_def = AST.SubtypeIn unsignedTM (Just range)
552 return (Just (ty_id, Just $ Right ty_def))
555 Int -- ^ Haskell type of the unsigned integer
556 -> TypeSession TypeMapRec
557 mkUnsignedTy size = do
558 let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
559 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
560 let ty_def = AST.SubtypeIn unsignedTM (Just range)
561 return (Just (ty_id, Just $ Right ty_def))
564 Int -- ^ Haskell type of the signed integer
565 -> TypeSession TypeMapRec
567 let ty_id = mkVHDLExtId $ "signed_" ++ show size
568 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
569 let ty_def = AST.SubtypeIn signedTM (Just range)
570 return (Just (ty_id, Just $ Right ty_def))
572 -- Finds the field labels and types for aggregation HType. Returns an
573 -- error on other types.
575 HType -- ^ The HType to get fields for
576 -> Int -- ^ The constructor to get fields for (e.g., 0
577 -- for the first constructor, etc.)
578 -> [(String, HType)] -- ^ A list of fields, with their name and type
579 getFields htype dc_i = case htype of
580 (AggrType name _ fieldss)
581 | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i
582 | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)
583 _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype
585 -- Finds the field labels for an aggregation type, as VHDLIds.
587 HType -- ^ The HType to get field labels for
588 -> Int -- ^ The constructor to get fields for (e.g., 0
589 -- for the first constructor, etc.)
590 -> [AST.VHDLId] -- ^ The labels
591 getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i)
593 -- Finds the field label for the constructor field, if any.
594 getConstructorFieldLabel ::
597 getConstructorFieldLabel (AggrType _ (Just con) _) =
598 Just $ mkVHDLBasicId (fst con)
599 getConstructorFieldLabel (AggrType _ Nothing _) =
601 getConstructorFieldLabel htype =
602 error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype
605 getConstructorIndex ::
609 getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of
610 Just (index) -> index
611 Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons
612 getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ show htype
615 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
616 mytydecl (_, Nothing) = Nothing
617 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
618 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
621 [AST.TypeMark] -- ^ type of each tuple element
622 -> AST.TypeMark -- ^ type of the tuple
624 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
626 tupPar = AST.unsafeVHDLBasicId "tup"
627 parenPar = AST.unsafeVHDLBasicId "paren"
628 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM, AST.IfaceVarDec parenPar booleanTM] stringTM
629 showExpr = AST.ReturnSm (Just $
630 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
632 showMiddle = if null elemTMs then
635 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
636 map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false")))
637 (take tupSize recordlabels)
638 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
639 tupSize = length elemTMs
640 selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
644 -> [String] -- Constructors
645 -> [[String]] -- Fields for every constructor
648 mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
650 adtPar = AST.unsafeVHDLBasicId "adt"
651 parenPar = AST.unsafeVHDLBasicId "paren"
652 showSpec = AST.Function showId [AST.IfaceVarDec adtPar adtTM, AST.IfaceVarDec parenPar booleanTM] stringTM
653 showExpr = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))
654 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] (
655 if (null (elemIdss!!x)) then
656 [AST.ReturnSm (Just $ ((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
658 [addParens (((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
659 ) | x <- [0..(length conIds) -1]]
660 showFields i = if (null (elemIdss!!i)) then
663 foldr1 (\e1 e2 -> e1 AST.:&: e2) $
664 map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "true")))
665 (map mkVHDLBasicId (elemIdss!!i))
666 selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
667 addParens :: AST.Expr -> AST.SeqSm
668 addParens k = AST.IfSm (AST.PrimName (AST.NSimple parenPar))
669 [AST.ReturnSm (Just (AST.PrimLit "'('" AST.:&: k AST.:&: AST.PrimLit "')'" ))]
671 (Just $ AST.Else [AST.ReturnSm (Just k)])
677 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
679 enumPar = AST.unsafeVHDLBasicId "enum"
680 parenPar = AST.unsafeVHDLBasicId "paren"
681 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM, AST.IfaceVarDec parenPar booleanTM] stringTM
682 showExpr = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
683 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
687 AST.TypeMark -- ^ elemtype
688 -> AST.TypeMark -- ^ vectype
689 -> [(String,AST.SubProgBody)]
690 mkVectorShow elemTM vectorTM =
691 [ (headId, AST.SubProgBody headSpec [] [headExpr])
692 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
693 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
696 vecPar = AST.unsafeVHDLBasicId "vec"
697 resId = AST.unsafeVHDLBasicId "res"
698 parenPar = AST.unsafeVHDLBasicId "paren"
699 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
701 headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
702 (AST.NSimple vecPar) [AST.PrimLit "0"])))
703 vecSlice init last = AST.PrimName (AST.NSlice
706 (AST.ToRange init last)))
707 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
708 -- variable res : fsvec_x (0 to vec'length-2);
711 (AST.SubtypeIn vectorTM
712 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
713 [AST.ToRange (AST.PrimLit "0")
714 (AST.PrimName (AST.NAttribute $
715 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
716 (AST.PrimLit "2")) ]))
718 -- res AST.:= vec(1 to vec'length-1)
719 tailExpr = AST.NSimple resId AST.:= (vecSlice
721 (AST.PrimName (AST.NAttribute $
722 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
723 AST.:-: AST.PrimLit "1"))
724 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
725 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM
726 doShowId = AST.unsafeVHDLExtId "doshow"
727 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
728 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
731 -- when 0 => return "";
732 -- when 1 => return head(vec);
733 -- when others => return show(head(vec)) & ',' &
734 -- doshow (tail(vec));
737 AST.CaseSm (AST.PrimName (AST.NAttribute $
738 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
739 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
740 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
741 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
742 [AST.ReturnSm (Just $
744 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar),AST.PrimLit "false") )],
745 AST.CaseSmAlt [AST.Others]
746 [AST.ReturnSm (Just $
748 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar), AST.PrimLit "false") AST.:&:
749 AST.PrimLit "','" AST.:&:
750 genExprFCall doShowId
751 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
752 -- return '<' & doshow(vec) & '>';
753 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
754 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
757 mkBuiltInShow :: [AST.SubProgBody]
758 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
759 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
760 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
761 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
762 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
765 bitPar = AST.unsafeVHDLBasicId "s"
766 boolPar = AST.unsafeVHDLBasicId "b"
767 signedPar = AST.unsafeVHDLBasicId "sint"
768 unsignedPar = AST.unsafeVHDLBasicId "uint"
769 parenPar = AST.unsafeVHDLBasicId "paren"
770 -- naturalPar = AST.unsafeVHDLBasicId "nat"
771 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM, AST.IfaceVarDec parenPar booleanTM] stringTM
772 -- if s = '1' then return "'1'" else return "'0'"
773 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
774 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
776 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
777 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM, AST.IfaceVarDec parenPar booleanTM] stringTM
778 -- if b then return "True" else return "False"
779 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
780 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
782 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
783 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
784 showSignedExpr = AST.ReturnSm (Just $
785 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
786 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
788 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
789 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
790 showUnsignedExpr = AST.ReturnSm (Just $
791 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
792 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
794 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
795 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
796 -- showNaturalExpr = AST.ReturnSm (Just $
797 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
798 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
801 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
802 genExprFCall fName args =
803 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
804 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
806 genExprFCall2 :: AST.VHDLId -> (AST.Expr, AST.Expr) -> AST.Expr
807 genExprFCall2 fName (arg1, arg2) =
808 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
809 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
811 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
812 genExprPCall2 entid arg1 arg2 =
813 AST.ProcCall (AST.NSimple entid) $
814 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
816 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
818 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
819 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
820 case type_mark_maybe of
821 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
822 Nothing -> return Nothing
824 -- | Does the given thing have a non-empty type?
825 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
826 t -> TranslatorSession Bool
827 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)