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.Map as Map
9 import qualified Control.Monad as Monad
10 import qualified Control.Arrow as Arrow
11 import qualified Control.Monad.Trans.State as State
12 import qualified Data.Monoid as Monoid
14 import Data.Accessor.MonadState as MonadState
18 import qualified Language.VHDL.AST as AST
23 import qualified OccName
26 import qualified IdInfo
27 import qualified TyCon
29 import qualified DataCon
30 import qualified CoreSubst
31 import qualified Outputable
34 import CLasH.VHDL.VHDLTypes
35 import CLasH.Translator.TranslatorTypes
36 import CLasH.Utils.Core.CoreTools
38 import CLasH.Utils.Pretty
39 import CLasH.VHDL.Constants
41 -----------------------------------------------------------------------------
42 -- Functions to generate concurrent statements
43 -----------------------------------------------------------------------------
45 -- Create an unconditional assignment statement
47 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
48 -> AST.Expr -- ^ The expression to assign
49 -> AST.ConcSm -- ^ The resulting concurrent statement
50 mkUncondAssign dst expr = mkAssign dst Nothing expr
52 -- Create a conditional assignment statement
54 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
55 -> AST.Expr -- ^ The condition
56 -> AST.Expr -- ^ The value when true
57 -> AST.Expr -- ^ The value when false
58 -> AST.ConcSm -- ^ The resulting concurrent statement
59 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
61 -- Create a conditional or unconditional assignment statement
63 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
64 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
65 -- and the value to assign when true.
66 -> AST.Expr -- ^ The value to assign when false or no condition
67 -> AST.ConcSm -- ^ The resulting concurrent statement
68 mkAssign dst cond false_expr =
70 -- I'm not 100% how this assignment AST works, but this gets us what we
72 whenelse = case cond of
73 Just (cond_expr, true_expr) ->
75 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
77 [AST.WhenElse true_wform cond_expr]
79 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
80 dst_name = case dst of
81 Left bndr -> AST.NSimple (varToVHDLId bndr)
83 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
88 [AST.Expr] -- ^ The argument that are applied to function
89 -> AST.VHDLName -- ^ The binder in which to store the result
90 -> Entity -- ^ The entity to map against.
91 -> [AST.AssocElem] -- ^ The resulting port maps
92 mkAssocElems args res entity =
93 arg_maps ++ (Maybe.maybeToList res_map_maybe)
95 arg_ports = ent_args entity
96 res_port_maybe = ent_res entity
97 -- Create an expression of res to map against the output port
98 res_expr = vhdlNameToVHDLExpr res
99 -- Map each of the input ports
100 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
101 -- Map the output port, if present
102 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
104 -- | Create an VHDL port -> signal association
105 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
106 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
108 -- | Create an aggregate signal
109 mkAggregateSignal :: [AST.Expr] -> AST.Expr
110 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
113 String -- ^ The portmap label
114 -> AST.VHDLId -- ^ The entity name
115 -> [AST.AssocElem] -- ^ The port assignments
117 mkComponentInst label entity_id portassigns = AST.CSISm compins
119 -- We always have a clock port, so no need to map it anywhere but here
120 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
121 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
123 -----------------------------------------------------------------------------
124 -- Functions to generate VHDL Exprs
125 -----------------------------------------------------------------------------
127 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
128 varToVHDLExpr var = do
129 case Id.isDataConWorkId_maybe var of
130 Just dc -> return $ dataconToVHDLExpr dc
131 -- This is a dataconstructor.
132 -- Not a datacon, just another signal. Perhaps we should check for
133 -- local/global here as well?
134 -- Sadly so.. tfp decimals are types, not data constructors, but instances
135 -- should still be translated to integer literals. It is probebly not the
136 -- best solution to translate them here.
137 -- FIXME: Find a better solution for translating instances of tfp integers
139 let ty = Var.varType var
140 case Type.splitTyConApp_maybe ty of
141 Just (tycon, args) ->
142 case Name.getOccString (TyCon.tyConName tycon) of
145 return $ AST.PrimLit $ (show len)
146 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
148 -- Turn a VHDLName into an AST expression
149 vhdlNameToVHDLExpr = AST.PrimName
151 -- Turn a VHDL Id into an AST expression
152 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
154 -- Turn a Core expression into an AST expression
155 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
157 -- Turn a alternative constructor into an AST expression. For
158 -- dataconstructors, this is only the constructor itself, not any arguments it
159 -- has. Should not be called with a DEFAULT constructor.
160 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
161 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
163 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
164 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
166 -- Turn a datacon (without arguments!) into a VHDL expression.
167 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
168 dataconToVHDLExpr dc = AST.PrimLit lit
170 tycon = DataCon.dataConTyCon dc
171 tyname = TyCon.tyConName tycon
172 dcname = DataCon.dataConName dc
173 lit = case Name.getOccString tyname of
174 -- TODO: Do something more robust than string matching
175 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
176 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
178 -----------------------------------------------------------------------------
179 -- Functions dealing with names, variables and ids
180 -----------------------------------------------------------------------------
182 -- Creates a VHDL Id from a binder
186 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var)
188 -- Creates a VHDL Name from a binder
192 varToVHDLName = AST.NSimple . varToVHDLId
194 -- Extracts the binder name as a String
198 varToString = OccName.occNameString . Name.nameOccName . Var.varName
200 -- Get the string version a Var's unique
201 varToStringUniq :: Var.Var -> String
202 varToStringUniq = show . Var.varUnique
204 -- Extracts the string version of the name
205 nameToString :: Name.Name -> String
206 nameToString = OccName.occNameString . Name.nameOccName
208 -- Shortcut for Basic VHDL Ids.
209 -- Can only contain alphanumerics and underscores. The supplied string must be
210 -- a valid basic id, otherwise an error value is returned. This function is
211 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
213 mkVHDLBasicId :: String -> AST.VHDLId
215 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
217 -- Strip invalid characters.
218 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
219 -- Strip leading numbers and underscores
220 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
221 -- Strip multiple adjacent underscores
222 strip_multiscore = concat . map (\cs ->
228 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
229 -- different characters than basic ids, but can never be used to refer to
231 -- Use extended Ids for any values that are taken from the source file.
232 mkVHDLExtId :: String -> AST.VHDLId
234 AST.unsafeVHDLExtId $ strip_invalid s
236 -- Allowed characters, taken from ForSyde's mkVHDLExtId
237 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
238 strip_invalid = filter (`elem` allowed)
240 -- Create a record field selector that selects the given label from the record
241 -- stored in the given binder.
242 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
243 mkSelectedName name label =
244 AST.NSelected $ name AST.:.: (AST.SSimple label)
246 -- Create an indexed name that selects a given element from a vector.
247 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
248 -- Special case for already indexed names. Just add an index
249 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
250 AST.NIndexed (AST.IndexedName name (indexes++[index]))
251 -- General case for other names
252 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
254 -----------------------------------------------------------------------------
255 -- Functions dealing with VHDL types
256 -----------------------------------------------------------------------------
258 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
259 -- for a few builtin types.
262 ("Bit", Just std_logicTM),
263 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
264 ("Dec", Just integerTM)
267 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
268 -- Returns an error value, using the given message, when no type could be
269 -- created. Returns Nothing when the type is valid, but empty.
270 vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
271 String -> t -> TypeSession (Maybe AST.TypeMark)
273 tm_either <- vhdl_ty_either ty
275 Right tm -> return tm
276 Left err -> error $ msg ++ "\n" ++ err
278 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
279 -- Returns either an error message or the resulting type.
280 vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
281 t -> TypeSession (Either String (Maybe AST.TypeMark))
282 vhdl_ty_either tything =
283 case getType tything of
284 Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
285 Just ty -> vhdl_ty_either' ty
287 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
288 vhdl_ty_either' ty = do
289 typemap <- getA tsTypes
290 htype_either <- mkHType ty
294 let builtin_ty = do -- See if this is a tycon and lookup its name
295 (tycon, args) <- Type.splitTyConApp_maybe ty
296 let name = Name.getOccString (TyCon.tyConName tycon)
297 Map.lookup name builtin_types
298 -- If not a builtin type, try the custom types
299 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
300 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
301 -- Found a type, return it
302 Just t -> return (Right t)
303 -- No type yet, try to construct it
305 newty_either <- (construct_vhdl_ty ty)
308 -- TODO: Check name uniqueness
309 modA tsTypes (Map.insert htype newty)
311 Just (ty_id, ty_def) -> do
312 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
313 return (Right $ Just ty_id)
314 Nothing -> return $ Right Nothing
315 Left err -> return $ Left $
316 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
318 -- Error when constructing htype
319 Left err -> return $ Left err
321 -- Construct a new VHDL type for the given Haskell type. Returns an error
322 -- message or the resulting typemark and typedef.
323 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
324 -- State types don't generate VHDL
325 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
326 construct_vhdl_ty ty = do
327 case Type.splitTyConApp_maybe ty of
328 Just (tycon, args) -> do
329 let name = Name.getOccString (TyCon.tyConName tycon)
331 "TFVec" -> mk_vector_ty ty
332 "SizedWord" -> mk_unsigned_ty ty
333 "SizedInt" -> mk_signed_ty ty
335 bound <- tfp_to_int (ranged_word_bound_ty ty)
336 mk_natural_ty 0 bound
337 -- Create a custom type from this tycon
338 otherwise -> mk_tycon_ty ty tycon args
339 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
341 -- | Create VHDL type for a custom tycon
342 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
343 mk_tycon_ty ty tycon args =
344 case TyCon.tyConDataCons tycon of
345 -- Not an algebraic type
346 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
348 let arg_tys = DataCon.dataConRepArgTys dc
349 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
350 -- violation? Or does it only mean not to apply it again to the same
352 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
353 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
354 case Either.partitionEithers elem_tys_either of
355 -- No errors in element types
356 ([], elem_tys') -> do
357 -- Throw away all empty members
358 case Maybe.catMaybes elem_tys' of
359 [] -> -- No non-empty members
360 return $ Right Nothing
362 let elems = zipWith AST.ElementDec recordlabels elem_tys
363 -- For a single construct datatype, build a record with one field for
365 -- TODO: Add argument type ids to this, to ensure uniqueness
366 -- TODO: Special handling for tuples?
367 let elem_names = concat $ map prettyShow elem_tys
368 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
369 let ty_def = AST.TDR $ AST.RecordTypeDef elems
370 let tupshow = mkTupleShow elem_tys ty_id
371 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
372 return $ Right $ Just (ty_id, Left ty_def)
373 -- There were errors in element types
374 (errors, _) -> return $ Left $
375 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
377 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
379 -- Create a subst that instantiates all types passed to the tycon
380 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
381 -- to work so far, though..
382 tyvars = TyCon.tyConTyVars tycon
383 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
384 -- Generate a bunch of labels for fields of a record
385 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
387 -- | Create a VHDL vector type
389 Type.Type -- ^ The Haskell type of the Vector
390 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
391 -- ^ An error message or The typemark created.
394 types_map <- getA tsTypes
396 let (nvec_l, nvec_el) = Type.splitAppTy ty
397 let (nvec, leng) = Type.splitAppTy nvec_l
398 let vec_ty = Type.mkAppTy nvec nvec_el
399 len <- tfp_to_int (tfvec_len_ty ty)
400 let el_ty = tfvec_elem ty
401 el_ty_tm_either <- vhdl_ty_either el_ty
402 case el_ty_tm_either of
403 -- Could create element type
404 Right (Just el_ty_tm) -> do
405 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
406 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
407 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
408 case existing_elem_ty of
410 let ty_def = AST.SubtypeIn t (Just range)
411 return (Right $ Just (ty_id, Right ty_def))
413 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
414 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
415 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
416 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
417 let vecShowFuns = mkVectorShow el_ty_tm vec_id
418 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
419 let ty_def = AST.SubtypeIn vec_id (Just range)
420 return (Right $ Just (ty_id, Right ty_def))
421 -- Empty element type? Empty vector type then. TODO: Does this make sense?
422 -- Probably needs changes in the builtin functions as well...
423 Right Nothing -> return $ Right Nothing
424 -- Could not create element type
425 Left err -> return $ Left $
426 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
430 Int -- ^ The minimum bound (> 0)
431 -> Int -- ^ The maximum bound (> minimum bound)
432 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
433 -- ^ An error message or The typemark created.
434 mk_natural_ty min_bound max_bound = do
435 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
436 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
437 let ty_def = AST.SubtypeIn naturalTM (Just range)
438 return (Right $ Just (ty_id, Right ty_def))
441 Type.Type -- ^ Haskell type of the unsigned integer
442 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
443 mk_unsigned_ty ty = do
444 size <- tfp_to_int (sized_word_len_ty ty)
445 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
446 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
447 let ty_def = AST.SubtypeIn unsignedTM (Just range)
448 return (Right $ Just (ty_id, Right ty_def))
451 Type.Type -- ^ Haskell type of the signed integer
452 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
454 size <- tfp_to_int (sized_int_len_ty ty)
455 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
456 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
457 let ty_def = AST.SubtypeIn signedTM (Just range)
458 return (Right $ Just (ty_id, Right ty_def))
460 -- Finds the field labels for VHDL type generated for the given Core type,
461 -- which must result in a record type.
462 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
463 getFieldLabels ty = do
464 -- Ensure that the type is generated (but throw away it's VHDLId)
465 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
467 -- Get the types map, lookup and unpack the VHDL TypeDef
468 types <- getA tsTypes
469 -- Assume the type for which we want labels is really translatable
470 Right htype <- mkHType ty
471 case Map.lookup htype types of
472 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
473 Just Nothing -> return [] -- The type is empty
474 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
476 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
477 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
478 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
480 mkHType :: Type.Type -> TypeSession (Either String HType)
482 -- FIXME: Do we really need to do this here again?
483 let builtin_ty = do -- See if this is a tycon and lookup its name
484 (tycon, args) <- Type.splitTyConApp_maybe ty
485 let name = Name.getOccString (TyCon.tyConName tycon)
486 Map.lookup name builtin_types
489 return $ Right $ BuiltinType $ prettyShow typ
491 case Type.splitTyConApp_maybe ty of
492 Just (tycon, args) -> do
493 let name = Name.getOccString (TyCon.tyConName tycon)
496 let el_ty = tfvec_elem ty
497 elem_htype_either <- mkHType el_ty
498 case elem_htype_either of
499 -- Could create element type
500 Right elem_htype -> do
501 len <- tfp_to_int (tfvec_len_ty ty)
502 return $ Right $ VecType len elem_htype
503 -- Could not create element type
504 Left err -> return $ Left $
505 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
508 len <- tfp_to_int (sized_word_len_ty ty)
509 return $ Right $ SizedWType len
511 len <- tfp_to_int (sized_word_len_ty ty)
512 return $ Right $ SizedIType len
514 bound <- tfp_to_int (ranged_word_bound_ty ty)
515 return $ Right $ RangedWType bound
517 mkTyConHType tycon args
518 Nothing -> return $ Right $ StdType $ OrdType ty
520 -- FIXME: Do we really need to do this here again?
521 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
522 mkTyConHType tycon args =
523 case TyCon.tyConDataCons tycon of
524 -- Not an algebraic type
525 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
527 let arg_tys = DataCon.dataConRepArgTys dc
528 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
529 elem_htys_either <- mapM mkHType real_arg_tys
530 case Either.partitionEithers elem_htys_either of
531 -- No errors in element types
532 ([], elem_htys) -> do
533 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
534 -- There were errors in element types
535 (errors, _) -> return $ Left $
536 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
538 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
540 tyvars = TyCon.tyConTyVars tycon
541 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
543 -- Is the given type representable at runtime?
544 isReprType :: Type.Type -> TypeSession Bool
546 ty_either <- vhdl_ty_either ty
547 return $ case ty_either of
552 tfp_to_int :: Type.Type -> TypeSession Int
554 hscenv <- getA tsHscEnv
555 let norm_ty = normalise_tfp_int hscenv ty
556 case Type.splitTyConApp_maybe norm_ty of
557 Just (tycon, args) -> do
558 let name = Name.getOccString (TyCon.tyConName tycon)
561 len <- tfp_to_int' ty
564 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
565 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
566 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
568 tfp_to_int' :: Type.Type -> TypeSession Int
570 lens <- getA tsTfpInts
571 hscenv <- getA tsHscEnv
572 let norm_ty = normalise_tfp_int hscenv ty
573 let existing_len = Map.lookup (OrdType norm_ty) lens
575 Just len -> return len
577 let new_len = eval_tfp_int hscenv ty
578 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
582 [AST.TypeMark] -- ^ type of each tuple element
583 -> AST.TypeMark -- ^ type of the tuple
585 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
587 tupPar = AST.unsafeVHDLBasicId "tup"
588 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
589 showExpr = AST.ReturnSm (Just $
590 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
592 showMiddle = if null elemTMs then
595 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
596 map ((genExprFCall showId).
599 (AST.NSimple tupPar AST.:.:).
601 (take tupSize recordlabels)
602 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
603 tupSize = length elemTMs
606 AST.TypeMark -- ^ elemtype
607 -> AST.TypeMark -- ^ vectype
608 -> [(String,AST.SubProgBody)]
609 mkVectorShow elemTM vectorTM =
610 [ (headId, AST.SubProgBody headSpec [] [headExpr])
611 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
612 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
615 vecPar = AST.unsafeVHDLBasicId "vec"
616 resId = AST.unsafeVHDLBasicId "res"
617 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
619 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
620 (AST.NSimple vecPar) [AST.PrimLit "0"])))
621 vecSlice init last = AST.PrimName (AST.NSlice
624 (AST.ToRange init last)))
625 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
626 -- variable res : fsvec_x (0 to vec'length-2);
629 (AST.SubtypeIn vectorTM
630 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
631 [AST.ToRange (AST.PrimLit "0")
632 (AST.PrimName (AST.NAttribute $
633 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
634 (AST.PrimLit "2")) ]))
636 -- res AST.:= vec(1 to vec'length-1)
637 tailExpr = AST.NSimple resId AST.:= (vecSlice
639 (AST.PrimName (AST.NAttribute $
640 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
641 AST.:-: AST.PrimLit "1"))
642 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
643 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
644 doShowId = AST.unsafeVHDLExtId "doshow"
645 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
646 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
649 -- when 0 => return "";
650 -- when 1 => return head(vec);
651 -- when others => return show(head(vec)) & ',' &
652 -- doshow (tail(vec));
655 AST.CaseSm (AST.PrimName (AST.NAttribute $
656 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
657 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
658 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
659 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
660 [AST.ReturnSm (Just $
662 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
663 AST.CaseSmAlt [AST.Others]
664 [AST.ReturnSm (Just $
666 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
667 AST.PrimLit "','" AST.:&:
668 genExprFCall doShowId
669 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
670 -- return '<' & doshow(vec) & '>';
671 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
672 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
675 mkBuiltInShow :: [AST.SubProgBody]
676 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
677 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
678 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
679 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
680 , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
683 bitPar = AST.unsafeVHDLBasicId "s"
684 boolPar = AST.unsafeVHDLBasicId "b"
685 signedPar = AST.unsafeVHDLBasicId "sint"
686 unsignedPar = AST.unsafeVHDLBasicId "uint"
687 naturalPar = AST.unsafeVHDLBasicId "nat"
688 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
689 -- if s = '1' then return "'1'" else return "'0'"
690 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
691 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
693 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
694 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
695 -- if b then return "True" else return "False"
696 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
697 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
699 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
700 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
701 showSignedExpr = AST.ReturnSm (Just $
702 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
703 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
705 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
706 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
707 showUnsignedExpr = AST.ReturnSm (Just $
708 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
709 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
711 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
712 showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
713 showNaturalExpr = AST.ReturnSm (Just $
714 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
715 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
718 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
719 genExprFCall fName args =
720 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
721 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
723 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
724 genExprPCall2 entid arg1 arg2 =
725 AST.ProcCall (AST.NSimple entid) $
726 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
728 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
730 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
731 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
732 case type_mark_maybe of
733 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
734 Nothing -> return Nothing
736 -- | Does the given thing have a non-empty type?
737 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
738 t -> TranslatorSession Bool
739 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)