1 {-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
2 module CLasH.VHDL.VHDLTools where
6 import qualified Data.Either as Either
7 import qualified Data.List as List
8 import qualified Data.Char as Char
9 import qualified Data.Map as Map
10 import qualified Control.Monad as Monad
11 import qualified Control.Arrow as Arrow
12 import qualified Control.Monad.Trans.State as State
13 import qualified Data.Monoid as Monoid
15 import Data.Accessor.MonadState as MonadState
19 import qualified Language.VHDL.AST as AST
24 import qualified OccName
27 import qualified IdInfo
28 import qualified TyCon
30 import qualified DataCon
31 import qualified CoreSubst
32 import qualified Outputable
35 import CLasH.VHDL.VHDLTypes
36 import CLasH.Translator.TranslatorTypes
37 import CLasH.Utils.Core.CoreTools
39 import CLasH.Utils.Pretty
40 import CLasH.VHDL.Constants
42 -----------------------------------------------------------------------------
43 -- Functions to generate concurrent statements
44 -----------------------------------------------------------------------------
46 -- Create an unconditional assignment statement
48 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
49 -> AST.Expr -- ^ The expression to assign
50 -> AST.ConcSm -- ^ The resulting concurrent statement
51 mkUncondAssign dst expr = mkAssign dst Nothing expr
53 -- Create a conditional assignment statement
55 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
56 -> AST.Expr -- ^ The condition
57 -> AST.Expr -- ^ The value when true
58 -> AST.Expr -- ^ The value when false
59 -> AST.ConcSm -- ^ The resulting concurrent statement
60 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
62 -- Create a conditional or unconditional assignment statement
64 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
65 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
66 -- and the value to assign when true.
67 -> AST.Expr -- ^ The value to assign when false or no condition
68 -> AST.ConcSm -- ^ The resulting concurrent statement
69 mkAssign dst cond false_expr =
71 -- I'm not 100% how this assignment AST works, but this gets us what we
73 whenelse = case cond of
74 Just (cond_expr, true_expr) ->
76 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
78 [AST.WhenElse true_wform cond_expr]
80 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
81 dst_name = case dst of
82 Left bndr -> AST.NSimple (varToVHDLId bndr)
84 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
89 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
90 -> [AST.Expr] -- ^ The conditions
91 -> [AST.Expr] -- ^ The expressions
92 -> AST.ConcSm -- ^ The Alt assigns
93 mkAltsAssign dst conds exprs
94 | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
97 whenelses = zipWith mkWhenElse conds exprs
98 false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
99 dst_name = case dst of
100 Left bndr -> AST.NSimple (varToVHDLId bndr)
102 assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
106 mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
107 mkWhenElse cond true_expr =
109 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
111 AST.WhenElse true_wform cond
114 [AST.Expr] -- ^ The argument that are applied to function
115 -> AST.VHDLName -- ^ The binder in which to store the result
116 -> Entity -- ^ The entity to map against.
117 -> [AST.AssocElem] -- ^ The resulting port maps
118 mkAssocElems args res entity =
119 arg_maps ++ (Maybe.maybeToList res_map_maybe)
121 arg_ports = ent_args entity
122 res_port_maybe = ent_res entity
123 -- Create an expression of res to map against the output port
124 res_expr = vhdlNameToVHDLExpr res
125 -- Map each of the input ports
126 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
127 -- Map the output port, if present
128 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
130 -- | Create an VHDL port -> signal association
131 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
132 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
134 -- | Create an aggregate signal
135 mkAggregateSignal :: [AST.Expr] -> AST.Expr
136 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
139 String -- ^ The portmap label
140 -> AST.VHDLId -- ^ The entity name
141 -> [AST.AssocElem] -- ^ The port assignments
143 mkComponentInst label entity_id portassigns = AST.CSISm compins
145 -- We always have a clock port, so no need to map it anywhere but here
146 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
147 resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
148 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
150 -----------------------------------------------------------------------------
151 -- Functions to generate VHDL Exprs
152 -----------------------------------------------------------------------------
154 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
155 varToVHDLExpr var = do
156 case Id.isDataConWorkId_maybe var of
157 Just dc -> dataconToVHDLExpr dc
158 -- This is a dataconstructor.
159 -- Not a datacon, just another signal. Perhaps we should check for
160 -- local/global here as well?
161 -- Sadly so.. tfp decimals are types, not data constructors, but instances
162 -- should still be translated to integer literals. It is probebly not the
163 -- best solution to translate them here.
164 -- FIXME: Find a better solution for translating instances of tfp integers
166 let ty = Var.varType var
167 case Type.splitTyConApp_maybe ty of
168 Just (tycon, args) ->
169 case Name.getOccString (TyCon.tyConName tycon) of
172 return $ AST.PrimLit $ (show len)
173 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
175 -- Turn a VHDLName into an AST expression
176 vhdlNameToVHDLExpr = AST.PrimName
178 -- Turn a VHDL Id into an AST expression
179 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
181 -- Turn a Core expression into an AST expression
182 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
184 -- Turn a alternative constructor into an AST expression. For
185 -- dataconstructors, this is only the constructor itself, not any arguments it
186 -- has. Should not be called with a DEFAULT constructor.
187 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
188 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
190 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
191 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
193 -- Turn a datacon (without arguments!) into a VHDL expression.
194 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
195 dataconToVHDLExpr dc = do
196 typemap <- getA tsTypes
197 htype_either <- mkHType (DataCon.dataConRepType dc)
201 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
204 let dcname = DataCon.dataConName dc
205 let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
208 let tycon = DataCon.dataConTyCon dc
209 let tyname = TyCon.tyConName tycon
210 let dcname = DataCon.dataConName dc
211 let lit = case Name.getOccString tyname of
212 -- TODO: Do something more robust than string matching
213 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
214 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
215 return $ AST.PrimLit lit
216 -- Error when constructing htype
217 Left err -> error err
219 -----------------------------------------------------------------------------
220 -- Functions dealing with names, variables and ids
221 -----------------------------------------------------------------------------
223 -- Creates a VHDL Id from a binder
227 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
229 lowers :: String -> Int
230 lowers xs = length [x | x <- xs, Char.isLower x]
232 -- Creates a VHDL Name from a binder
236 varToVHDLName = AST.NSimple . varToVHDLId
238 -- Extracts the binder name as a String
242 varToString = OccName.occNameString . Name.nameOccName . Var.varName
244 -- Get the string version a Var's unique
245 varToStringUniq :: Var.Var -> String
246 varToStringUniq = show . Var.varUnique
248 -- Extracts the string version of the name
249 nameToString :: Name.Name -> String
250 nameToString = OccName.occNameString . Name.nameOccName
252 -- Shortcut for Basic VHDL Ids.
253 -- Can only contain alphanumerics and underscores. The supplied string must be
254 -- a valid basic id, otherwise an error value is returned. This function is
255 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
257 mkVHDLBasicId :: String -> AST.VHDLId
259 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
261 -- Strip invalid characters.
262 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
263 -- Strip leading numbers and underscores
264 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
265 -- Strip multiple adjacent underscores
266 strip_multiscore = concat . map (\cs ->
272 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
273 -- different characters than basic ids, but can never be used to refer to
275 -- Use extended Ids for any values that are taken from the source file.
276 mkVHDLExtId :: String -> AST.VHDLId
278 AST.unsafeVHDLExtId $ strip_invalid s
280 -- Allowed characters, taken from ForSyde's mkVHDLExtId
281 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
282 strip_invalid = filter (`elem` allowed)
284 -- Create a record field selector that selects the given label from the record
285 -- stored in the given binder.
286 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
287 mkSelectedName name label =
288 AST.NSelected $ name AST.:.: (AST.SSimple label)
290 -- Create an indexed name that selects a given element from a vector.
291 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
292 -- Special case for already indexed names. Just add an index
293 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
294 AST.NIndexed (AST.IndexedName name (indexes++[index]))
295 -- General case for other names
296 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
298 -----------------------------------------------------------------------------
299 -- Functions dealing with VHDL types
300 -----------------------------------------------------------------------------
302 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
303 -- for a few builtin types.
306 ("Bit", Just std_logicTM),
307 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
308 ("Dec", Just integerTM)
311 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
312 -- Returns an error value, using the given message, when no type could be
313 -- created. Returns Nothing when the type is valid, but empty.
314 vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
315 String -> t -> TypeSession (Maybe AST.TypeMark)
317 tm_either <- vhdl_ty_either ty
319 Right tm -> return tm
320 Left err -> error $ msg ++ "\n" ++ err
322 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
323 -- Returns either an error message or the resulting type.
324 vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
325 t -> TypeSession (Either String (Maybe AST.TypeMark))
326 vhdl_ty_either tything =
327 case getType tything of
328 Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
329 Just ty -> vhdl_ty_either' ty
331 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
332 vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty
334 typemap <- getA tsTypes
335 htype_either <- mkHType ty
339 let builtin_ty = do -- See if this is a tycon and lookup its name
340 (tycon, args) <- Type.splitTyConApp_maybe ty
341 let name = Name.getOccString (TyCon.tyConName tycon)
342 Map.lookup name builtin_types
343 -- If not a builtin type, try the custom types
344 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
345 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
346 -- Found a type, return it
347 Just t -> return (Right t)
348 -- No type yet, try to construct it
350 newty_either <- (construct_vhdl_ty ty)
353 -- TODO: Check name uniqueness
354 modA tsTypes (Map.insert htype newty)
356 Just (ty_id, ty_def) -> do
357 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
358 return (Right $ Just ty_id)
359 Nothing -> return $ Right Nothing
360 Left err -> return $ Left $
361 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
363 -- Error when constructing htype
364 Left err -> return $ Left err
366 -- Construct a new VHDL type for the given Haskell type. Returns an error
367 -- message or the resulting typemark and typedef.
368 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
369 -- State types don't generate VHDL
370 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
371 construct_vhdl_ty ty = do
372 case Type.splitTyConApp_maybe ty of
373 Just (tycon, args) -> do
374 let name = Name.getOccString (TyCon.tyConName tycon)
376 "TFVec" -> mk_vector_ty ty
377 "SizedWord" -> mk_unsigned_ty ty
378 "SizedInt" -> mk_signed_ty ty
380 bound <- tfp_to_int (ranged_word_bound_ty ty)
381 mk_natural_ty 0 bound
382 -- Create a custom type from this tycon
383 otherwise -> mk_tycon_ty ty tycon args
384 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
386 -- | Create VHDL type for a custom tycon
387 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
388 mk_tycon_ty ty tycon args =
389 case TyCon.tyConDataCons tycon of
390 -- Not an algebraic type
391 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
393 let arg_tys = DataCon.dataConRepArgTys dc
394 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
395 -- violation? Or does it only mean not to apply it again to the same
397 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
398 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
399 case Either.partitionEithers elem_tys_either of
400 -- No errors in element types
401 ([], elem_tys') -> do
402 -- Throw away all empty members
403 case Maybe.catMaybes elem_tys' of
404 [] -> -- No non-empty members
405 return $ Right Nothing
407 let elems = zipWith AST.ElementDec recordlabels elem_tys
408 -- For a single construct datatype, build a record with one field for
410 -- TODO: Add argument type ids to this, to ensure uniqueness
411 -- TODO: Special handling for tuples?
412 let elem_names = concat $ map prettyShow elem_tys
413 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
414 let ty_def = AST.TDR $ AST.RecordTypeDef elems
415 let tupshow = mkTupleShow elem_tys ty_id
416 let htype = ADTType (nameToString (TyCon.tyConName tycon)) (map (\x -> StdType (OrdType x)) real_arg_tys)
417 modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
418 return $ Right $ Just (ty_id, Left ty_def)
419 -- There were errors in element types
420 (errors, _) -> return $ Left $
421 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
424 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
425 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
428 let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
429 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
430 let ty_def = AST.TDE $ AST.EnumTypeDef elems
431 let enumShow = mkEnumShow elems ty_id
432 let htype = EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
433 modA tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
434 return $ Right $ Just (ty_id, Left ty_def)
435 xs -> return $ Left $
436 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
438 -- Create a subst that instantiates all types passed to the tycon
439 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
440 -- to work so far, though..
441 tyvars = TyCon.tyConTyVars tycon
442 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
443 -- Generate a bunch of labels for fields of a record
444 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
446 -- | Create a VHDL vector type
448 Type.Type -- ^ The Haskell type of the Vector
449 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
450 -- ^ An error message or The typemark created.
453 types_map <- getA tsTypes
455 let (nvec_l, nvec_el) = Type.splitAppTy ty
456 let (nvec, leng) = Type.splitAppTy nvec_l
457 let vec_ty = Type.mkAppTy nvec nvec_el
458 len <- tfp_to_int (tfvec_len_ty ty)
459 let el_ty = tfvec_elem ty
460 el_ty_tm_either <- vhdl_ty_either el_ty
461 case el_ty_tm_either of
462 -- Could create element type
463 Right (Just el_ty_tm) -> do
464 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
465 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
466 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
467 case existing_elem_ty of
469 let ty_def = AST.SubtypeIn t (Just range)
470 return (Right $ Just (ty_id, Right ty_def))
472 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
473 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
474 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
475 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
476 let vecShowFuns = mkVectorShow el_ty_tm vec_id
477 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
478 let ty_def = AST.SubtypeIn vec_id (Just range)
479 return (Right $ Just (ty_id, Right ty_def))
480 -- Empty element type? Empty vector type then. TODO: Does this make sense?
481 -- Probably needs changes in the builtin functions as well...
482 Right Nothing -> return $ Right Nothing
483 -- Could not create element type
484 Left err -> return $ Left $
485 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
489 Int -- ^ The minimum bound (> 0)
490 -> Int -- ^ The maximum bound (> minimum bound)
491 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
492 -- ^ An error message or The typemark created.
493 mk_natural_ty min_bound max_bound = do
494 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
495 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
496 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
497 let ty_def = AST.SubtypeIn unsignedTM (Just range)
498 return (Right $ Just (ty_id, Right ty_def))
501 Type.Type -- ^ Haskell type of the unsigned integer
502 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
503 mk_unsigned_ty ty = do
504 size <- tfp_to_int (sized_word_len_ty ty)
505 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
506 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
507 let ty_def = AST.SubtypeIn unsignedTM (Just range)
508 return (Right $ Just (ty_id, Right ty_def))
511 Type.Type -- ^ Haskell type of the signed integer
512 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
514 size <- tfp_to_int (sized_int_len_ty ty)
515 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
516 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
517 let ty_def = AST.SubtypeIn signedTM (Just range)
518 return (Right $ Just (ty_id, Right ty_def))
520 -- Finds the field labels for VHDL type generated for the given Core type,
521 -- which must result in a record type.
522 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
523 getFieldLabels ty = do
524 -- Ensure that the type is generated (but throw away it's VHDLId)
525 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
527 -- Get the types map, lookup and unpack the VHDL TypeDef
528 types <- getA tsTypes
529 -- Assume the type for which we want labels is really translatable
530 Right htype <- mkHType ty
531 case Map.lookup htype types of
532 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
533 Just Nothing -> return [] -- The type is empty
534 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
536 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
537 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
538 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
540 mkHType :: Type.Type -> TypeSession (Either String HType)
542 -- FIXME: Do we really need to do this here again?
543 let builtin_ty = do -- See if this is a tycon and lookup its name
544 (tycon, args) <- Type.splitTyConApp_maybe ty
545 let name = Name.getOccString (TyCon.tyConName tycon)
546 Map.lookup name builtin_types
549 return $ Right $ BuiltinType $ prettyShow typ
551 case Type.splitTyConApp_maybe ty of
552 Just (tycon, args) -> do
553 let name = Name.getOccString (TyCon.tyConName tycon)
556 let el_ty = tfvec_elem ty
557 elem_htype_either <- mkHType el_ty
558 case elem_htype_either of
559 -- Could create element type
560 Right elem_htype -> do
561 len <- tfp_to_int (tfvec_len_ty ty)
562 return $ Right $ VecType len elem_htype
563 -- Could not create element type
564 Left err -> return $ Left $
565 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
568 len <- tfp_to_int (sized_word_len_ty ty)
569 return $ Right $ SizedWType len
571 len <- tfp_to_int (sized_word_len_ty ty)
572 return $ Right $ SizedIType len
574 bound <- tfp_to_int (ranged_word_bound_ty ty)
575 return $ Right $ RangedWType bound
577 mkTyConHType tycon args
578 Nothing -> return $ Right $ StdType $ OrdType ty
580 -- FIXME: Do we really need to do this here again?
581 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
582 mkTyConHType tycon args =
583 case TyCon.tyConDataCons tycon of
584 -- Not an algebraic type
585 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
587 let arg_tys = DataCon.dataConRepArgTys dc
588 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
589 elem_htys_either <- mapM mkHType real_arg_tys
590 case Either.partitionEithers elem_htys_either of
591 -- No errors in element types
592 ([], elem_htys) -> do
593 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
594 -- There were errors in element types
595 (errors, _) -> return $ Left $
596 "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
599 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
600 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
603 return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
604 xs -> return $ Left $
605 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
607 tyvars = TyCon.tyConTyVars tycon
608 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
610 -- Is the given type representable at runtime?
611 isReprType :: Type.Type -> TypeSession Bool
613 ty_either <- vhdl_ty_either ty
614 return $ case ty_either of
619 tfp_to_int :: Type.Type -> TypeSession Int
621 hscenv <- getA tsHscEnv
622 let norm_ty = normalise_tfp_int hscenv ty
623 case Type.splitTyConApp_maybe norm_ty of
624 Just (tycon, args) -> do
625 let name = Name.getOccString (TyCon.tyConName tycon)
628 len <- tfp_to_int' ty
631 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
632 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
633 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
635 tfp_to_int' :: Type.Type -> TypeSession Int
637 lens <- getA tsTfpInts
638 hscenv <- getA tsHscEnv
639 let norm_ty = normalise_tfp_int hscenv ty
640 let existing_len = Map.lookup (OrdType norm_ty) lens
642 Just len -> return len
644 let new_len = eval_tfp_int hscenv ty
645 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
649 [AST.TypeMark] -- ^ type of each tuple element
650 -> AST.TypeMark -- ^ type of the tuple
652 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
654 tupPar = AST.unsafeVHDLBasicId "tup"
655 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
656 showExpr = AST.ReturnSm (Just $
657 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
659 showMiddle = if null elemTMs then
662 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
663 map ((genExprFCall showId).
666 (AST.NSimple tupPar AST.:.:).
668 (take tupSize recordlabels)
669 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
670 tupSize = length elemTMs
676 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
678 enumPar = AST.unsafeVHDLBasicId "enum"
679 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
680 showExpr = AST.ReturnSm (Just $
681 AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
684 AST.TypeMark -- ^ elemtype
685 -> AST.TypeMark -- ^ vectype
686 -> [(String,AST.SubProgBody)]
687 mkVectorShow elemTM vectorTM =
688 [ (headId, AST.SubProgBody headSpec [] [headExpr])
689 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
690 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
693 vecPar = AST.unsafeVHDLBasicId "vec"
694 resId = AST.unsafeVHDLBasicId "res"
695 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
697 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
698 (AST.NSimple vecPar) [AST.PrimLit "0"])))
699 vecSlice init last = AST.PrimName (AST.NSlice
702 (AST.ToRange init last)))
703 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
704 -- variable res : fsvec_x (0 to vec'length-2);
707 (AST.SubtypeIn vectorTM
708 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
709 [AST.ToRange (AST.PrimLit "0")
710 (AST.PrimName (AST.NAttribute $
711 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
712 (AST.PrimLit "2")) ]))
714 -- res AST.:= vec(1 to vec'length-1)
715 tailExpr = AST.NSimple resId AST.:= (vecSlice
717 (AST.PrimName (AST.NAttribute $
718 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
719 AST.:-: AST.PrimLit "1"))
720 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
721 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
722 doShowId = AST.unsafeVHDLExtId "doshow"
723 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
724 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
727 -- when 0 => return "";
728 -- when 1 => return head(vec);
729 -- when others => return show(head(vec)) & ',' &
730 -- doshow (tail(vec));
733 AST.CaseSm (AST.PrimName (AST.NAttribute $
734 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
735 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
736 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
737 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
738 [AST.ReturnSm (Just $
740 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
741 AST.CaseSmAlt [AST.Others]
742 [AST.ReturnSm (Just $
744 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
745 AST.PrimLit "','" AST.:&:
746 genExprFCall doShowId
747 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
748 -- return '<' & doshow(vec) & '>';
749 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
750 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
753 mkBuiltInShow :: [AST.SubProgBody]
754 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
755 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
756 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
757 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
758 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
761 bitPar = AST.unsafeVHDLBasicId "s"
762 boolPar = AST.unsafeVHDLBasicId "b"
763 signedPar = AST.unsafeVHDLBasicId "sint"
764 unsignedPar = AST.unsafeVHDLBasicId "uint"
765 -- naturalPar = AST.unsafeVHDLBasicId "nat"
766 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
767 -- if s = '1' then return "'1'" else return "'0'"
768 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
769 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
771 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
772 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
773 -- if b then return "True" else return "False"
774 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
775 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
777 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
778 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
779 showSignedExpr = AST.ReturnSm (Just $
780 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
781 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
783 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
784 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
785 showUnsignedExpr = AST.ReturnSm (Just $
786 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
787 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
789 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
790 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
791 -- showNaturalExpr = AST.ReturnSm (Just $
792 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
793 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
796 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
797 genExprFCall fName args =
798 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
799 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
801 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
802 genExprPCall2 entid arg1 arg2 =
803 AST.ProcCall (AST.NSimple entid) $
804 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
806 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
808 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
809 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
810 case type_mark_maybe of
811 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
812 Nothing -> return Nothing
814 -- | Does the given thing have a non-empty type?
815 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
816 t -> TranslatorSession Bool
817 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)