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 $ varToUniqString var
211 -- Creates a VHDL Name from a binder
215 varToVHDLName = AST.NSimple . varToVHDLId
217 -- Extracts the binder name as a String
221 varToString = OccName.occNameString . Name.nameOccName . Var.varName
226 varToUniqString var = (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
228 lowers :: String -> Int
229 lowers xs = length [x | x <- xs, Char.isLower x]
231 -- Get the string version a Var's unique
232 varToStringUniq :: Var.Var -> String
233 varToStringUniq = show . Var.varUnique
235 -- Extracts the string version of the name
236 nameToString :: Name.Name -> String
237 nameToString = OccName.occNameString . Name.nameOccName
239 -- Shortcut for Basic VHDL Ids.
240 -- Can only contain alphanumerics and underscores. The supplied string must be
241 -- a valid basic id, otherwise an error value is returned. This function is
242 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
244 mkVHDLBasicId :: String -> AST.VHDLId
246 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
248 -- Strip invalid characters.
249 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
250 -- Strip leading numbers and underscores
251 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
252 -- Strip multiple adjacent underscores
253 strip_multiscore = concatMap (\cs ->
259 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
260 -- different characters than basic ids, but can never be used to refer to
262 -- Use extended Ids for any values that are taken from the source file.
263 mkVHDLExtId :: String -> AST.VHDLId
265 (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s
267 -- Allowed characters, taken from ForSyde's mkVHDLExtId
268 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
269 strip_invalid = filter (`elem` allowed)
270 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
271 strip_multiscore = concatMap (\cs ->
277 -- Create a record field selector that selects the given label from the record
278 -- stored in the given binder.
279 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
280 mkSelectedName name label =
281 AST.NSelected $ name AST.:.: (AST.SSimple label)
283 -- Create an indexed name that selects a given element from a vector.
284 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
285 -- Special case for already indexed names. Just add an index
286 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
287 AST.NIndexed (AST.IndexedName name (indexes++[index]))
288 -- General case for other names
289 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
291 -----------------------------------------------------------------------------
292 -- Functions dealing with VHDL types
293 -----------------------------------------------------------------------------
294 builtin_types :: TypeMap
297 (BuiltinType "Bit", Just (std_logicTM, Nothing)),
298 (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
301 -- Is the given type representable at runtime?
302 isReprType :: Type.Type -> TypeSession Bool
304 ty_either <- mkHTypeEither ty
305 return $ case ty_either of
309 -- | Turn a Core type into a HType, returning an error using the given
310 -- error string if the type was not representable.
311 mkHType :: (TypedThing t, Outputable.Outputable t) =>
312 String -> t -> TypeSession HType
314 htype_either <- mkHTypeEither ty
316 Right htype -> return htype
317 Left err -> error $ msg ++ err
319 -- | Turn a Core type into a HType. Returns either an error message if
320 -- the type was not representable, or the HType generated.
321 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) =>
322 t -> TypeSession (Either String HType)
323 mkHTypeEither tything =
324 case getType tything of
325 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
326 Just ty -> mkHTypeEither' ty
328 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
329 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
330 | isStateType ty = return $ Right StateType
332 case Type.splitTyConApp_maybe ty of
333 Just (tycon, args) -> do
334 typemap <- MonadState.get tsTypes
335 let name = Name.getOccString (TyCon.tyConName tycon)
336 let builtinTyMaybe = Map.lookup (BuiltinType name) typemap
337 case builtinTyMaybe of
338 (Just x) -> return $ Right $ BuiltinType name
342 let el_ty = tfvec_elem ty
343 elem_htype_either <- mkHTypeEither el_ty
344 case elem_htype_either of
345 -- Could create element type
346 Right elem_htype -> do
347 len <- tfp_to_int (tfvec_len_ty ty)
348 return $ Right $ VecType len elem_htype
349 -- Could not create element type
350 Left err -> return $ Left $
351 "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
353 len <- tfp_to_int (sized_word_len_ty ty)
354 return $ Right $ SizedWType len
356 len <- tfp_to_int (sized_word_len_ty ty)
357 return $ Right $ SizedIType len
359 bound <- tfp_to_int (ranged_word_bound_ty ty)
360 -- Upperbound is exclusive, hence the -1
361 return $ Right $ RangedWType (bound - 1)
363 mkTyConHType tycon args
364 Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
366 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
367 mkTyConHType tycon args =
368 case TyCon.tyConDataCons tycon of
369 -- Not an algebraic type
370 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
372 let arg_tyss = map DataCon.dataConRepArgTys dcs
373 let enum_ty = EnumType name (map (nameToString . DataCon.dataConName) dcs)
374 case (concat arg_tyss) of
375 -- No arguments, this is just an enumeration type
376 [] -> return (Right enum_ty)
377 -- At least one argument, this becomes an aggregate type
379 -- Resolve any type arguments to this type
380 let real_arg_tyss = map (map (CoreSubst.substTy subst)) arg_tyss
381 -- Remove any state type fields
382 let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss
383 elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate
384 let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either)
385 case (all null errors) of
386 True -> case (dcs, concat elem_htyss) of
387 -- A single constructor with a single (non-state) field?
388 ([dc], [elem_hty]) -> return $ Right elem_hty
389 -- If we get here, then all of the argument types were state
390 -- types (we check for enumeration types at the top). Not
391 -- sure how to handle this, so error out for now.
392 (_, []) -> error $ "ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args
393 -- A full ADT (with multiple fields and one or multiple
396 let (_, fieldss) = List.mapAccumL (List.mapAccumL label_field) labels elem_htyss
397 -- Only put in an enumeration as part of the aggregation
398 -- when there are multiple datacons
399 let enum_ty_part = case dcs of
401 _ -> Just ("constructor", enum_ty)
402 -- Create the AggrType HType
403 return $ Right $ AggrType name enum_ty_part fieldss
404 -- There were errors in element types
405 False -> return $ Left $
406 "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
407 ++ (concat $ concat errors)
409 name = (nameToString (TyCon.tyConName tycon))
410 tyvars = TyCon.tyConTyVars tycon
411 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
412 -- Label a field by taking the first available label and returning
414 label_field :: [String] -> HType -> ([String], (String, HType))
415 label_field (l:ls) htype = (ls, (l, htype))
416 labels = map (:[]) ['A'..'Z']
418 vhdlTy :: (TypedThing t, Outputable.Outputable t) =>
419 String -> t -> TypeSession (Maybe AST.TypeMark)
421 htype <- mkHType msg ty
424 -- | Translate a Haskell type to a VHDL type, generating a new type if needed.
425 -- Returns an error value, using the given message, when no type could be
426 -- created. Returns Nothing when the type is valid, but empty.
427 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
428 vhdlTyMaybe htype = do
429 typemap <- MonadState.get tsTypes
430 -- If not a builtin type, try the custom types
431 let existing_ty = Map.lookup htype typemap
433 -- Found a type, return it
434 Just (Just (t, _)) -> return $ Just t
435 Just (Nothing) -> return Nothing
436 -- No type yet, try to construct it
438 newty <- (construct_vhdl_ty htype)
439 MonadState.modify tsTypes (Map.insert htype newty)
441 Just (ty_id, ty_def) -> do
442 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
444 Nothing -> return Nothing
446 -- Construct a new VHDL type for the given Haskell type. Returns an error
447 -- message or the resulting typemark and typedef.
448 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
449 -- State types don't generate VHDL
450 construct_vhdl_ty htype =
452 StateType -> return Nothing
453 (SizedWType w) -> mkUnsignedTy w
454 (SizedIType i) -> mkSignedTy i
455 (RangedWType u) -> mkNaturalTy 0 u
456 (VecType n e) -> mkVectorTy (VecType n e)
457 -- Create a custom type from this tycon
458 otherwise -> mkTyconTy htype
460 -- | Create VHDL type for a custom tycon
461 mkTyconTy :: HType -> TypeSession TypeMapRec
464 (AggrType name enum_field_maybe fieldss) -> do
465 let (labelss, elem_htypess) = unzip (map unzip fieldss)
466 elemTyMaybess <- mapM (mapM vhdlTyMaybe) elem_htypess
467 let elem_tyss = map Maybe.catMaybes elemTyMaybess
468 case concat elem_tyss of
469 [] -> -- No non-empty fields
472 let reclabelss = map (map mkVHDLBasicId) labelss
473 let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss
474 let elem_names = concatMap (concatMap prettyShow) elem_tyss
475 let ty_id = mkVHDLExtId $ name ++ elem_names
476 -- Find out if we need to add an extra field at the start of
477 -- the record type containing the constructor (only needed
478 -- when there's more than one constructor).
479 enum_ty_maybe <- case enum_field_maybe of
480 Nothing -> return Nothing
481 Just (_, enum_htype) -> do
482 enum_ty_maybe' <- vhdlTyMaybe enum_htype
483 case enum_ty_maybe' of
484 Nothing -> error $ "Couldn't translate enumeration type part of AggrType: " ++ show htype
485 -- Note that the first Just means the type is
486 -- translateable, while the second Just means that there
487 -- is a enum_ty at all (e.g., there's multiple
489 Just enum_ty -> return $ Just enum_ty
490 -- Create an record field declaration for the first
491 -- constructor field, if needed.
492 enum_dec_maybe <- case enum_field_maybe of
493 Nothing -> return $ Nothing
494 Just (enum_name, enum_htype) -> do
495 enum_vhdl_ty_maybe <- vhdlTyMaybe enum_htype
496 let enum_vhdl_ty = Maybe.fromMaybe (error $ "\nVHDLTools.mkTyconTy: Enumeration field should not have empty type: " ++ show enum_htype) enum_vhdl_ty_maybe
497 return $ Just $ AST.ElementDec (mkVHDLBasicId enum_name) enum_vhdl_ty
498 -- Turn the maybe into a list, so we can prepend it.
499 let enum_decs = Maybe.maybeToList enum_dec_maybe
500 let enum_tys = Maybe.maybeToList enum_ty_maybe
501 let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
502 let aggrshow = case enum_field_maybe of
503 Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
504 Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
505 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
506 return $ Just (ty_id, Just $ Left ty_def)
507 (EnumType tycon dcs) -> do
508 let ty_id = mkVHDLExtId tycon
509 let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))
510 let ty_def = AST.TDI $ AST.IntegerTypeDef range
511 let enumShow = mkEnumShow dcs ty_id
512 MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
513 return $ Just (ty_id, Just $ Left ty_def)
514 otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
516 -- | Create a VHDL vector type
518 HType -- ^ The Haskell type of the Vector
519 -> TypeSession TypeMapRec
520 -- ^ An error message or The typemark created.
522 mkVectorTy (VecType len elHType) = do
523 typesMap <- MonadState.get tsTypes
524 elTyTmMaybe <- vhdlTyMaybe elHType
527 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
528 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
529 let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
530 case existing_uvec_ty of
532 let ty_def = AST.SubtypeIn t (Just range)
533 return (Just (ty_id, Just $ Right ty_def))
535 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
536 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
537 MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
538 MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
539 let vecShowFuns = mkVectorShow elTyTm vec_id
540 mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
541 let ty_def = AST.SubtypeIn vec_id (Just range)
542 return (Just (ty_id, Just $ Right ty_def))
543 -- Vector of empty elements becomes empty itself.
544 Nothing -> return Nothing
545 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
548 Int -- ^ The minimum bound (> 0)
549 -> Int -- ^ The maximum bound (> minimum bound)
550 -> TypeSession TypeMapRec
551 -- ^ An error message or The typemark created.
552 mkNaturalTy min_bound max_bound = do
553 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
554 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
555 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
556 let ty_def = AST.SubtypeIn unsignedTM (Just range)
557 return (Just (ty_id, Just $ Right ty_def))
560 Int -- ^ Haskell type of the unsigned integer
561 -> TypeSession TypeMapRec
562 mkUnsignedTy size = do
563 let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
564 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
565 let ty_def = AST.SubtypeIn unsignedTM (Just range)
566 return (Just (ty_id, Just $ Right ty_def))
569 Int -- ^ Haskell type of the signed integer
570 -> TypeSession TypeMapRec
572 let ty_id = mkVHDLExtId $ "signed_" ++ show size
573 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
574 let ty_def = AST.SubtypeIn signedTM (Just range)
575 return (Just (ty_id, Just $ Right ty_def))
577 -- Finds the field labels and types for aggregation HType. Returns an
578 -- error on other types.
580 HType -- ^ The HType to get fields for
581 -> Int -- ^ The constructor to get fields for (e.g., 0
582 -- for the first constructor, etc.)
583 -> [(String, HType)] -- ^ A list of fields, with their name and type
584 getFields htype dc_i = case htype of
585 (AggrType name _ fieldss)
586 | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i
587 | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)
588 _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype
590 -- Finds the field labels for an aggregation type, as VHDLIds.
592 HType -- ^ The HType to get field labels for
593 -> Int -- ^ The constructor to get fields for (e.g., 0
594 -- for the first constructor, etc.)
595 -> [AST.VHDLId] -- ^ The labels
596 getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i)
598 -- Finds the field label for the constructor field, if any.
599 getConstructorFieldLabel ::
602 getConstructorFieldLabel (AggrType _ (Just con) _) =
603 Just $ mkVHDLBasicId (fst con)
604 getConstructorFieldLabel (AggrType _ Nothing _) =
606 getConstructorFieldLabel htype =
607 error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype
610 getConstructorIndex ::
614 getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of
615 Just (index) -> index
616 Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons
617 getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ show htype
620 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
621 mytydecl (_, Nothing) = Nothing
622 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
623 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
626 [AST.TypeMark] -- ^ type of each tuple element
627 -> AST.TypeMark -- ^ type of the tuple
629 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
631 tupPar = AST.unsafeVHDLBasicId "tup"
632 parenPar = AST.unsafeVHDLBasicId "paren"
633 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM, AST.IfaceVarDec parenPar booleanTM] stringTM
634 showExpr = AST.ReturnSm (Just $
635 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
637 showMiddle = if null elemTMs then
640 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
641 map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false")))
642 (take tupSize recordlabels)
643 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
644 tupSize = length elemTMs
645 selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
649 -> [String] -- Constructors
650 -> [[String]] -- Fields for every constructor
653 mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
655 adtPar = AST.unsafeVHDLBasicId "adt"
656 parenPar = AST.unsafeVHDLBasicId "paren"
657 showSpec = AST.Function showId [AST.IfaceVarDec adtPar adtTM, AST.IfaceVarDec parenPar booleanTM] stringTM
658 showExpr = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))
659 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] (
660 if (null (elemIdss!!x)) then
661 [AST.ReturnSm (Just $ ((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
663 [addParens (((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
664 ) | x <- [0..(length conIds) -1]]
665 showFields i = if (null (elemIdss!!i)) then
668 foldr1 (\e1 e2 -> e1 AST.:&: e2) $
669 map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "true")))
670 (map mkVHDLBasicId (elemIdss!!i))
671 selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
672 addParens :: AST.Expr -> AST.SeqSm
673 addParens k = AST.IfSm (AST.PrimName (AST.NSimple parenPar))
674 [AST.ReturnSm (Just (AST.PrimLit "'('" AST.:&: k AST.:&: AST.PrimLit "')'" ))]
676 (Just $ AST.Else [AST.ReturnSm (Just k)])
682 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
684 enumPar = AST.unsafeVHDLBasicId "enum"
685 parenPar = AST.unsafeVHDLBasicId "paren"
686 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM, AST.IfaceVarDec parenPar booleanTM] stringTM
687 showExpr = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
688 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
692 AST.TypeMark -- ^ elemtype
693 -> AST.TypeMark -- ^ vectype
694 -> [(String,AST.SubProgBody)]
695 mkVectorShow elemTM vectorTM =
696 [ (headId, AST.SubProgBody headSpec [] [headExpr])
697 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
698 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
701 vecPar = AST.unsafeVHDLBasicId "vec"
702 resId = AST.unsafeVHDLBasicId "res"
703 parenPar = AST.unsafeVHDLBasicId "paren"
704 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
706 headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
707 (AST.NSimple vecPar) [AST.PrimLit "0"])))
708 vecSlice init last = AST.PrimName (AST.NSlice
711 (AST.ToRange init last)))
712 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
713 -- variable res : fsvec_x (0 to vec'length-2);
716 (AST.SubtypeIn vectorTM
717 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
718 [AST.ToRange (AST.PrimLit "0")
719 (AST.PrimName (AST.NAttribute $
720 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
721 (AST.PrimLit "2")) ]))
723 -- res AST.:= vec(1 to vec'length-1)
724 tailExpr = AST.NSimple resId AST.:= (vecSlice
726 (AST.PrimName (AST.NAttribute $
727 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
728 AST.:-: AST.PrimLit "1"))
729 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
730 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM
731 doShowId = AST.unsafeVHDLBasicId "doshow"
732 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
733 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
736 -- when 0 => return "";
737 -- when 1 => return head(vec);
738 -- when others => return show(head(vec)) & ',' &
739 -- doshow (tail(vec));
742 AST.CaseSm (AST.PrimName (AST.NAttribute $
743 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
744 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
745 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
746 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
747 [AST.ReturnSm (Just $
749 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar),AST.PrimLit "false") )],
750 AST.CaseSmAlt [AST.Others]
751 [AST.ReturnSm (Just $
753 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar), AST.PrimLit "false") AST.:&:
754 AST.PrimLit "','" AST.:&:
755 genExprFCall doShowId
756 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
757 -- return '<' & doshow(vec) & '>';
758 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
759 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
762 mkBuiltInShow :: [AST.SubProgBody]
763 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
764 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
765 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
766 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
767 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
770 bitPar = AST.unsafeVHDLBasicId "s"
771 boolPar = AST.unsafeVHDLBasicId "b"
772 signedPar = AST.unsafeVHDLBasicId "sint"
773 unsignedPar = AST.unsafeVHDLBasicId "uint"
774 parenPar = AST.unsafeVHDLBasicId "paren"
775 -- naturalPar = AST.unsafeVHDLBasicId "nat"
776 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM, AST.IfaceVarDec parenPar booleanTM] stringTM
777 -- if s = '1' then return "'1'" else return "'0'"
778 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
779 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
781 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
782 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM, AST.IfaceVarDec parenPar booleanTM] stringTM
783 -- if b then return "True" else return "False"
784 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
785 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
787 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
788 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
789 showSignedExpr = AST.ReturnSm (Just $
790 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
791 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
793 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
794 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
795 showUnsignedExpr = AST.ReturnSm (Just $
796 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
797 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
799 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
800 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
801 -- showNaturalExpr = AST.ReturnSm (Just $
802 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
803 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
806 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
807 genExprFCall fName args =
808 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
809 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
811 genExprFCall2 :: AST.VHDLId -> (AST.Expr, AST.Expr) -> AST.Expr
812 genExprFCall2 fName (arg1, arg2) =
813 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
814 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
816 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
817 genExprPCall2 entid arg1 arg2 =
818 AST.ProcCall (AST.NSimple entid) $
819 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
821 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
823 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
824 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
825 case type_mark_maybe of
826 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
827 Nothing -> return Nothing
829 -- | Does the given thing have a non-empty type?
830 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
831 t -> TranslatorSession Bool
832 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)