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 [AST.Expr] -- ^ The argument that are applied to function
90 -> AST.VHDLName -- ^ The binder in which to store the result
91 -> Entity -- ^ The entity to map against.
92 -> [AST.AssocElem] -- ^ The resulting port maps
93 mkAssocElems args res entity =
94 arg_maps ++ (Maybe.maybeToList res_map_maybe)
96 arg_ports = ent_args entity
97 res_port_maybe = ent_res entity
98 -- Create an expression of res to map against the output port
99 res_expr = vhdlNameToVHDLExpr res
100 -- Map each of the input ports
101 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
102 -- Map the output port, if present
103 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
105 -- | Create an VHDL port -> signal association
106 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
107 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
109 -- | Create an aggregate signal
110 mkAggregateSignal :: [AST.Expr] -> AST.Expr
111 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
114 String -- ^ The portmap label
115 -> AST.VHDLId -- ^ The entity name
116 -> [AST.AssocElem] -- ^ The port assignments
118 mkComponentInst label entity_id portassigns = AST.CSISm compins
120 -- We always have a clock port, so no need to map it anywhere but here
121 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
122 resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
123 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
125 -----------------------------------------------------------------------------
126 -- Functions to generate VHDL Exprs
127 -----------------------------------------------------------------------------
129 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
130 varToVHDLExpr var = do
131 case Id.isDataConWorkId_maybe var of
132 Just dc -> dataconToVHDLExpr dc
133 -- This is a dataconstructor.
134 -- Not a datacon, just another signal. Perhaps we should check for
135 -- local/global here as well?
136 -- Sadly so.. tfp decimals are types, not data constructors, but instances
137 -- should still be translated to integer literals. It is probebly not the
138 -- best solution to translate them here.
139 -- FIXME: Find a better solution for translating instances of tfp integers
141 let ty = Var.varType var
142 case Type.splitTyConApp_maybe ty of
143 Just (tycon, args) ->
144 case Name.getOccString (TyCon.tyConName tycon) of
147 return $ AST.PrimLit $ (show len)
148 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
150 -- Turn a VHDLName into an AST expression
151 vhdlNameToVHDLExpr = AST.PrimName
153 -- Turn a VHDL Id into an AST expression
154 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
156 -- Turn a Core expression into an AST expression
157 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
159 -- Turn a alternative constructor into an AST expression. For
160 -- dataconstructors, this is only the constructor itself, not any arguments it
161 -- has. Should not be called with a DEFAULT constructor.
162 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
163 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
165 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
166 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
168 -- Turn a datacon (without arguments!) into a VHDL expression.
169 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
170 dataconToVHDLExpr dc = do
171 typemap <- getA tsTypes
172 htype_either <- mkHType (DataCon.dataConRepType dc)
176 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
179 let dcname = DataCon.dataConName dc
180 let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
183 let tycon = DataCon.dataConTyCon dc
184 let tyname = TyCon.tyConName tycon
185 let dcname = DataCon.dataConName dc
186 let lit = case Name.getOccString tyname of
187 -- TODO: Do something more robust than string matching
188 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
189 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
190 return $ AST.PrimLit lit
191 -- Error when constructing htype
192 Left err -> error err
194 -----------------------------------------------------------------------------
195 -- Functions dealing with names, variables and ids
196 -----------------------------------------------------------------------------
198 -- Creates a VHDL Id from a binder
202 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
204 lowers :: String -> Int
205 lowers xs = length [x | x <- xs, Char.isLower x]
207 -- Creates a VHDL Name from a binder
211 varToVHDLName = AST.NSimple . varToVHDLId
213 -- Extracts the binder name as a String
217 varToString = OccName.occNameString . Name.nameOccName . Var.varName
219 -- Get the string version a Var's unique
220 varToStringUniq :: Var.Var -> String
221 varToStringUniq = show . Var.varUnique
223 -- Extracts the string version of the name
224 nameToString :: Name.Name -> String
225 nameToString = OccName.occNameString . Name.nameOccName
227 -- Shortcut for Basic VHDL Ids.
228 -- Can only contain alphanumerics and underscores. The supplied string must be
229 -- a valid basic id, otherwise an error value is returned. This function is
230 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
232 mkVHDLBasicId :: String -> AST.VHDLId
234 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
236 -- Strip invalid characters.
237 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
238 -- Strip leading numbers and underscores
239 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
240 -- Strip multiple adjacent underscores
241 strip_multiscore = concat . map (\cs ->
247 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
248 -- different characters than basic ids, but can never be used to refer to
250 -- Use extended Ids for any values that are taken from the source file.
251 mkVHDLExtId :: String -> AST.VHDLId
253 AST.unsafeVHDLExtId $ strip_invalid s
255 -- Allowed characters, taken from ForSyde's mkVHDLExtId
256 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
257 strip_invalid = filter (`elem` allowed)
259 -- Create a record field selector that selects the given label from the record
260 -- stored in the given binder.
261 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
262 mkSelectedName name label =
263 AST.NSelected $ name AST.:.: (AST.SSimple label)
265 -- Create an indexed name that selects a given element from a vector.
266 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
267 -- Special case for already indexed names. Just add an index
268 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
269 AST.NIndexed (AST.IndexedName name (indexes++[index]))
270 -- General case for other names
271 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
273 -----------------------------------------------------------------------------
274 -- Functions dealing with VHDL types
275 -----------------------------------------------------------------------------
277 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
278 -- for a few builtin types.
281 ("Bit", Just std_logicTM),
282 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
283 ("Dec", Just integerTM)
286 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
287 -- Returns an error value, using the given message, when no type could be
288 -- created. Returns Nothing when the type is valid, but empty.
289 vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
290 String -> t -> TypeSession (Maybe AST.TypeMark)
292 tm_either <- vhdl_ty_either ty
294 Right tm -> return tm
295 Left err -> error $ msg ++ "\n" ++ err
297 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
298 -- Returns either an error message or the resulting type.
299 vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
300 t -> TypeSession (Either String (Maybe AST.TypeMark))
301 vhdl_ty_either tything =
302 case getType tything of
303 Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
304 Just ty -> vhdl_ty_either' ty
306 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
307 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
309 typemap <- getA tsTypes
310 htype_either <- mkHType ty
314 let builtin_ty = do -- See if this is a tycon and lookup its name
315 (tycon, args) <- Type.splitTyConApp_maybe ty
316 let name = Name.getOccString (TyCon.tyConName tycon)
317 Map.lookup name builtin_types
318 -- If not a builtin type, try the custom types
319 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
320 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
321 -- Found a type, return it
322 Just t -> return (Right t)
323 -- No type yet, try to construct it
325 newty_either <- (construct_vhdl_ty ty)
328 -- TODO: Check name uniqueness
329 modA tsTypes (Map.insert htype newty)
331 Just (ty_id, ty_def) -> do
332 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
333 return (Right $ Just ty_id)
334 Nothing -> return $ Right Nothing
335 Left err -> return $ Left $
336 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
338 -- Error when constructing htype
339 Left err -> return $ Left err
341 -- Construct a new VHDL type for the given Haskell type. Returns an error
342 -- message or the resulting typemark and typedef.
343 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
344 -- State types don't generate VHDL
345 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
346 construct_vhdl_ty ty = do
347 case Type.splitTyConApp_maybe ty of
348 Just (tycon, args) -> do
349 let name = Name.getOccString (TyCon.tyConName tycon)
351 "TFVec" -> mk_vector_ty ty
352 "SizedWord" -> mk_unsigned_ty ty
353 "SizedInt" -> mk_signed_ty ty
355 bound <- tfp_to_int (ranged_word_bound_ty ty)
356 mk_natural_ty 0 bound
357 -- Create a custom type from this tycon
358 otherwise -> mk_tycon_ty ty tycon args
359 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
361 -- | Create VHDL type for a custom tycon
362 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
363 mk_tycon_ty ty tycon args =
364 case TyCon.tyConDataCons tycon of
365 -- Not an algebraic type
366 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
368 let arg_tys = DataCon.dataConRepArgTys dc
369 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
370 -- violation? Or does it only mean not to apply it again to the same
372 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
373 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
374 case Either.partitionEithers elem_tys_either of
375 -- No errors in element types
376 ([], elem_tys') -> do
377 -- Throw away all empty members
378 case Maybe.catMaybes elem_tys' of
379 [] -> -- No non-empty members
380 return $ Right Nothing
382 let elems = zipWith AST.ElementDec recordlabels elem_tys
383 -- For a single construct datatype, build a record with one field for
385 -- TODO: Add argument type ids to this, to ensure uniqueness
386 -- TODO: Special handling for tuples?
387 let elem_names = concat $ map prettyShow elem_tys
388 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
389 let ty_def = AST.TDR $ AST.RecordTypeDef elems
390 let tupshow = mkTupleShow elem_tys ty_id
391 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
392 return $ Right $ Just (ty_id, Left ty_def)
393 -- There were errors in element types
394 (errors, _) -> return $ Left $
395 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
398 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
399 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
402 let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
403 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
404 let ty_def = AST.TDE $ AST.EnumTypeDef elems
405 let enumShow = mkEnumShow elems ty_id
406 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow)
407 return $ Right $ Just (ty_id, Left ty_def)
408 xs -> return $ Left $
409 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
411 -- Create a subst that instantiates all types passed to the tycon
412 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
413 -- to work so far, though..
414 tyvars = TyCon.tyConTyVars tycon
415 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
416 -- Generate a bunch of labels for fields of a record
417 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
419 -- | Create a VHDL vector type
421 Type.Type -- ^ The Haskell type of the Vector
422 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
423 -- ^ An error message or The typemark created.
426 types_map <- getA tsTypes
428 let (nvec_l, nvec_el) = Type.splitAppTy ty
429 let (nvec, leng) = Type.splitAppTy nvec_l
430 let vec_ty = Type.mkAppTy nvec nvec_el
431 len <- tfp_to_int (tfvec_len_ty ty)
432 let el_ty = tfvec_elem ty
433 el_ty_tm_either <- vhdl_ty_either el_ty
434 case el_ty_tm_either of
435 -- Could create element type
436 Right (Just el_ty_tm) -> do
437 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
438 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
439 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
440 case existing_elem_ty of
442 let ty_def = AST.SubtypeIn t (Just range)
443 return (Right $ Just (ty_id, Right ty_def))
445 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
446 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
447 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
448 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
449 let vecShowFuns = mkVectorShow el_ty_tm vec_id
450 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
451 let ty_def = AST.SubtypeIn vec_id (Just range)
452 return (Right $ Just (ty_id, Right ty_def))
453 -- Empty element type? Empty vector type then. TODO: Does this make sense?
454 -- Probably needs changes in the builtin functions as well...
455 Right Nothing -> return $ Right Nothing
456 -- Could not create element type
457 Left err -> return $ Left $
458 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
462 Int -- ^ The minimum bound (> 0)
463 -> Int -- ^ The maximum bound (> minimum bound)
464 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
465 -- ^ An error message or The typemark created.
466 mk_natural_ty min_bound max_bound = do
467 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
468 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
469 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
470 let ty_def = AST.SubtypeIn unsignedTM (Just range)
471 return (Right $ Just (ty_id, Right ty_def))
474 Type.Type -- ^ Haskell type of the unsigned integer
475 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
476 mk_unsigned_ty ty = do
477 size <- tfp_to_int (sized_word_len_ty ty)
478 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
479 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
480 let ty_def = AST.SubtypeIn unsignedTM (Just range)
481 return (Right $ Just (ty_id, Right ty_def))
484 Type.Type -- ^ Haskell type of the signed integer
485 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
487 size <- tfp_to_int (sized_int_len_ty ty)
488 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
489 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
490 let ty_def = AST.SubtypeIn signedTM (Just range)
491 return (Right $ Just (ty_id, Right ty_def))
493 -- Finds the field labels for VHDL type generated for the given Core type,
494 -- which must result in a record type.
495 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
496 getFieldLabels ty = do
497 -- Ensure that the type is generated (but throw away it's VHDLId)
498 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
500 -- Get the types map, lookup and unpack the VHDL TypeDef
501 types <- getA tsTypes
502 -- Assume the type for which we want labels is really translatable
503 Right htype <- mkHType ty
504 case Map.lookup htype types of
505 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
506 Just Nothing -> return [] -- The type is empty
507 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
509 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
510 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
511 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
513 mkHType :: Type.Type -> TypeSession (Either String HType)
515 -- FIXME: Do we really need to do this here again?
516 let builtin_ty = do -- See if this is a tycon and lookup its name
517 (tycon, args) <- Type.splitTyConApp_maybe ty
518 let name = Name.getOccString (TyCon.tyConName tycon)
519 Map.lookup name builtin_types
522 return $ Right $ BuiltinType $ prettyShow typ
524 case Type.splitTyConApp_maybe ty of
525 Just (tycon, args) -> do
526 let name = Name.getOccString (TyCon.tyConName tycon)
529 let el_ty = tfvec_elem ty
530 elem_htype_either <- mkHType el_ty
531 case elem_htype_either of
532 -- Could create element type
533 Right elem_htype -> do
534 len <- tfp_to_int (tfvec_len_ty ty)
535 return $ Right $ VecType len elem_htype
536 -- Could not create element type
537 Left err -> return $ Left $
538 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
541 len <- tfp_to_int (sized_word_len_ty ty)
542 return $ Right $ SizedWType len
544 len <- tfp_to_int (sized_word_len_ty ty)
545 return $ Right $ SizedIType len
547 bound <- tfp_to_int (ranged_word_bound_ty ty)
548 return $ Right $ RangedWType bound
550 mkTyConHType tycon args
551 Nothing -> return $ Right $ StdType $ OrdType ty
553 -- FIXME: Do we really need to do this here again?
554 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
555 mkTyConHType tycon args =
556 case TyCon.tyConDataCons tycon of
557 -- Not an algebraic type
558 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
560 let arg_tys = DataCon.dataConRepArgTys dc
561 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
562 elem_htys_either <- mapM mkHType real_arg_tys
563 case Either.partitionEithers elem_htys_either of
564 -- No errors in element types
565 ([], elem_htys) -> do
566 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
567 -- There were errors in element types
568 (errors, _) -> return $ Left $
569 "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
572 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
573 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
576 return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
577 xs -> return $ Left $
578 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
580 tyvars = TyCon.tyConTyVars tycon
581 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
583 -- Is the given type representable at runtime?
584 isReprType :: Type.Type -> TypeSession Bool
586 ty_either <- vhdl_ty_either ty
587 return $ case ty_either of
592 tfp_to_int :: Type.Type -> TypeSession Int
594 hscenv <- getA tsHscEnv
595 let norm_ty = normalise_tfp_int hscenv ty
596 case Type.splitTyConApp_maybe norm_ty of
597 Just (tycon, args) -> do
598 let name = Name.getOccString (TyCon.tyConName tycon)
601 len <- tfp_to_int' ty
604 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
605 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
606 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
608 tfp_to_int' :: Type.Type -> TypeSession Int
610 lens <- getA tsTfpInts
611 hscenv <- getA tsHscEnv
612 let norm_ty = normalise_tfp_int hscenv ty
613 let existing_len = Map.lookup (OrdType norm_ty) lens
615 Just len -> return len
617 let new_len = eval_tfp_int hscenv ty
618 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
622 [AST.TypeMark] -- ^ type of each tuple element
623 -> AST.TypeMark -- ^ type of the tuple
625 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
627 tupPar = AST.unsafeVHDLBasicId "tup"
628 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
629 showExpr = AST.ReturnSm (Just $
630 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
632 showMiddle = if null elemTMs then
635 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
636 map ((genExprFCall showId).
639 (AST.NSimple tupPar AST.:.:).
641 (take tupSize recordlabels)
642 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
643 tupSize = length elemTMs
649 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
651 enumPar = AST.unsafeVHDLBasicId "enum"
652 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
653 showExpr = AST.ReturnSm (Just $
654 AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
657 AST.TypeMark -- ^ elemtype
658 -> AST.TypeMark -- ^ vectype
659 -> [(String,AST.SubProgBody)]
660 mkVectorShow elemTM vectorTM =
661 [ (headId, AST.SubProgBody headSpec [] [headExpr])
662 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
663 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
666 vecPar = AST.unsafeVHDLBasicId "vec"
667 resId = AST.unsafeVHDLBasicId "res"
668 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
670 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
671 (AST.NSimple vecPar) [AST.PrimLit "0"])))
672 vecSlice init last = AST.PrimName (AST.NSlice
675 (AST.ToRange init last)))
676 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
677 -- variable res : fsvec_x (0 to vec'length-2);
680 (AST.SubtypeIn vectorTM
681 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
682 [AST.ToRange (AST.PrimLit "0")
683 (AST.PrimName (AST.NAttribute $
684 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
685 (AST.PrimLit "2")) ]))
687 -- res AST.:= vec(1 to vec'length-1)
688 tailExpr = AST.NSimple resId AST.:= (vecSlice
690 (AST.PrimName (AST.NAttribute $
691 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
692 AST.:-: AST.PrimLit "1"))
693 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
694 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
695 doShowId = AST.unsafeVHDLExtId "doshow"
696 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
697 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
700 -- when 0 => return "";
701 -- when 1 => return head(vec);
702 -- when others => return show(head(vec)) & ',' &
703 -- doshow (tail(vec));
706 AST.CaseSm (AST.PrimName (AST.NAttribute $
707 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
708 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
709 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
710 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
711 [AST.ReturnSm (Just $
713 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
714 AST.CaseSmAlt [AST.Others]
715 [AST.ReturnSm (Just $
717 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
718 AST.PrimLit "','" AST.:&:
719 genExprFCall doShowId
720 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
721 -- return '<' & doshow(vec) & '>';
722 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
723 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
726 mkBuiltInShow :: [AST.SubProgBody]
727 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
728 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
729 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
730 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
731 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
734 bitPar = AST.unsafeVHDLBasicId "s"
735 boolPar = AST.unsafeVHDLBasicId "b"
736 signedPar = AST.unsafeVHDLBasicId "sint"
737 unsignedPar = AST.unsafeVHDLBasicId "uint"
738 -- naturalPar = AST.unsafeVHDLBasicId "nat"
739 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
740 -- if s = '1' then return "'1'" else return "'0'"
741 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
742 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
744 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
745 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
746 -- if b then return "True" else return "False"
747 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
748 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
750 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
751 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
752 showSignedExpr = AST.ReturnSm (Just $
753 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
754 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
756 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
757 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
758 showUnsignedExpr = AST.ReturnSm (Just $
759 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
760 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
762 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
763 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
764 -- showNaturalExpr = AST.ReturnSm (Just $
765 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
766 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
769 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
770 genExprFCall fName args =
771 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
772 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
774 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
775 genExprPCall2 entid arg1 arg2 =
776 AST.ProcCall (AST.NSimple entid) $
777 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
779 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
781 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
782 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
783 case type_mark_maybe of
784 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
785 Nothing -> return Nothing
787 -- | Does the given thing have a non-empty type?
788 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
789 t -> TranslatorSession Bool
790 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)