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 -> return $ 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 -> 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 -> AST.Expr
170 dataconToVHDLExpr dc = AST.PrimLit lit
172 tycon = DataCon.dataConTyCon dc
173 tyname = TyCon.tyConName tycon
174 dcname = DataCon.dataConName dc
175 lit = case Name.getOccString tyname of
176 -- TODO: Do something more robust than string matching
177 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
178 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
180 -----------------------------------------------------------------------------
181 -- Functions dealing with names, variables and ids
182 -----------------------------------------------------------------------------
184 -- Creates a VHDL Id from a binder
188 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
190 lowers :: String -> Int
191 lowers xs = length [x | x <- xs, Char.isLower x]
193 -- Creates a VHDL Name from a binder
197 varToVHDLName = AST.NSimple . varToVHDLId
199 -- Extracts the binder name as a String
203 varToString = OccName.occNameString . Name.nameOccName . Var.varName
205 -- Get the string version a Var's unique
206 varToStringUniq :: Var.Var -> String
207 varToStringUniq = show . Var.varUnique
209 -- Extracts the string version of the name
210 nameToString :: Name.Name -> String
211 nameToString = OccName.occNameString . Name.nameOccName
213 -- Shortcut for Basic VHDL Ids.
214 -- Can only contain alphanumerics and underscores. The supplied string must be
215 -- a valid basic id, otherwise an error value is returned. This function is
216 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
218 mkVHDLBasicId :: String -> AST.VHDLId
220 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
222 -- Strip invalid characters.
223 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
224 -- Strip leading numbers and underscores
225 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
226 -- Strip multiple adjacent underscores
227 strip_multiscore = concat . map (\cs ->
233 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
234 -- different characters than basic ids, but can never be used to refer to
236 -- Use extended Ids for any values that are taken from the source file.
237 mkVHDLExtId :: String -> AST.VHDLId
239 AST.unsafeVHDLExtId $ strip_invalid s
241 -- Allowed characters, taken from ForSyde's mkVHDLExtId
242 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
243 strip_invalid = filter (`elem` allowed)
245 -- Create a record field selector that selects the given label from the record
246 -- stored in the given binder.
247 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
248 mkSelectedName name label =
249 AST.NSelected $ name AST.:.: (AST.SSimple label)
251 -- Create an indexed name that selects a given element from a vector.
252 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
253 -- Special case for already indexed names. Just add an index
254 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
255 AST.NIndexed (AST.IndexedName name (indexes++[index]))
256 -- General case for other names
257 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
259 -----------------------------------------------------------------------------
260 -- Functions dealing with VHDL types
261 -----------------------------------------------------------------------------
263 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
264 -- for a few builtin types.
267 ("Bit", Just std_logicTM),
268 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
269 ("Dec", Just integerTM)
272 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
273 -- Returns an error value, using the given message, when no type could be
274 -- created. Returns Nothing when the type is valid, but empty.
275 vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
276 String -> t -> TypeSession (Maybe AST.TypeMark)
278 tm_either <- vhdl_ty_either ty
280 Right tm -> return tm
281 Left err -> error $ msg ++ "\n" ++ err
283 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
284 -- Returns either an error message or the resulting type.
285 vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
286 t -> TypeSession (Either String (Maybe AST.TypeMark))
287 vhdl_ty_either tything =
288 case getType tything of
289 Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
290 Just ty -> vhdl_ty_either' ty
292 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
293 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
295 typemap <- getA tsTypes
296 htype_either <- mkHType ty
300 let builtin_ty = do -- See if this is a tycon and lookup its name
301 (tycon, args) <- Type.splitTyConApp_maybe ty
302 let name = Name.getOccString (TyCon.tyConName tycon)
303 Map.lookup name builtin_types
304 -- If not a builtin type, try the custom types
305 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
306 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
307 -- Found a type, return it
308 Just t -> return (Right t)
309 -- No type yet, try to construct it
311 newty_either <- (construct_vhdl_ty ty)
314 -- TODO: Check name uniqueness
315 modA tsTypes (Map.insert htype newty)
317 Just (ty_id, ty_def) -> do
318 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
319 return (Right $ Just ty_id)
320 Nothing -> return $ Right Nothing
321 Left err -> return $ Left $
322 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
324 -- Error when constructing htype
325 Left err -> return $ Left err
327 -- Construct a new VHDL type for the given Haskell type. Returns an error
328 -- message or the resulting typemark and typedef.
329 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
330 -- State types don't generate VHDL
331 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
332 construct_vhdl_ty ty = do
333 case Type.splitTyConApp_maybe ty of
334 Just (tycon, args) -> do
335 let name = Name.getOccString (TyCon.tyConName tycon)
337 "TFVec" -> mk_vector_ty ty
338 "SizedWord" -> mk_unsigned_ty ty
339 "SizedInt" -> mk_signed_ty ty
341 bound <- tfp_to_int (ranged_word_bound_ty ty)
342 mk_natural_ty 0 bound
343 -- Create a custom type from this tycon
344 otherwise -> mk_tycon_ty ty tycon args
345 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
347 -- | Create VHDL type for a custom tycon
348 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
349 mk_tycon_ty ty tycon args =
350 case TyCon.tyConDataCons tycon of
351 -- Not an algebraic type
352 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
354 let arg_tys = DataCon.dataConRepArgTys dc
355 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
356 -- violation? Or does it only mean not to apply it again to the same
358 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
359 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
360 case Either.partitionEithers elem_tys_either of
361 -- No errors in element types
362 ([], elem_tys') -> do
363 -- Throw away all empty members
364 case Maybe.catMaybes elem_tys' of
365 [] -> -- No non-empty members
366 return $ Right Nothing
368 let elems = zipWith AST.ElementDec recordlabels elem_tys
369 -- For a single construct datatype, build a record with one field for
371 -- TODO: Add argument type ids to this, to ensure uniqueness
372 -- TODO: Special handling for tuples?
373 let elem_names = concat $ map prettyShow elem_tys
374 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
375 let ty_def = AST.TDR $ AST.RecordTypeDef elems
376 let tupshow = mkTupleShow elem_tys ty_id
377 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
378 return $ Right $ Just (ty_id, Left ty_def)
379 -- There were errors in element types
380 (errors, _) -> return $ Left $
381 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
383 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
385 -- Create a subst that instantiates all types passed to the tycon
386 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
387 -- to work so far, though..
388 tyvars = TyCon.tyConTyVars tycon
389 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
390 -- Generate a bunch of labels for fields of a record
391 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
393 -- | Create a VHDL vector type
395 Type.Type -- ^ The Haskell type of the Vector
396 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
397 -- ^ An error message or The typemark created.
400 types_map <- getA tsTypes
402 let (nvec_l, nvec_el) = Type.splitAppTy ty
403 let (nvec, leng) = Type.splitAppTy nvec_l
404 let vec_ty = Type.mkAppTy nvec nvec_el
405 len <- tfp_to_int (tfvec_len_ty ty)
406 let el_ty = tfvec_elem ty
407 el_ty_tm_either <- vhdl_ty_either el_ty
408 case el_ty_tm_either of
409 -- Could create element type
410 Right (Just el_ty_tm) -> do
411 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
412 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
413 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
414 case existing_elem_ty of
416 let ty_def = AST.SubtypeIn t (Just range)
417 return (Right $ Just (ty_id, Right ty_def))
419 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
420 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
421 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
422 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
423 let vecShowFuns = mkVectorShow el_ty_tm vec_id
424 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
425 let ty_def = AST.SubtypeIn vec_id (Just range)
426 return (Right $ Just (ty_id, Right ty_def))
427 -- Empty element type? Empty vector type then. TODO: Does this make sense?
428 -- Probably needs changes in the builtin functions as well...
429 Right Nothing -> return $ Right Nothing
430 -- Could not create element type
431 Left err -> return $ Left $
432 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
436 Int -- ^ The minimum bound (> 0)
437 -> Int -- ^ The maximum bound (> minimum bound)
438 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
439 -- ^ An error message or The typemark created.
440 mk_natural_ty min_bound max_bound = do
441 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
442 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
443 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
444 let ty_def = AST.SubtypeIn unsignedTM (Just range)
445 return (Right $ Just (ty_id, Right ty_def))
448 Type.Type -- ^ Haskell type of the unsigned integer
449 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
450 mk_unsigned_ty ty = do
451 size <- tfp_to_int (sized_word_len_ty ty)
452 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
453 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
454 let ty_def = AST.SubtypeIn unsignedTM (Just range)
455 return (Right $ Just (ty_id, Right ty_def))
458 Type.Type -- ^ Haskell type of the signed integer
459 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
461 size <- tfp_to_int (sized_int_len_ty ty)
462 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
463 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
464 let ty_def = AST.SubtypeIn signedTM (Just range)
465 return (Right $ Just (ty_id, Right ty_def))
467 -- Finds the field labels for VHDL type generated for the given Core type,
468 -- which must result in a record type.
469 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
470 getFieldLabels ty = do
471 -- Ensure that the type is generated (but throw away it's VHDLId)
472 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
474 -- Get the types map, lookup and unpack the VHDL TypeDef
475 types <- getA tsTypes
476 -- Assume the type for which we want labels is really translatable
477 Right htype <- mkHType ty
478 case Map.lookup htype types of
479 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
480 Just Nothing -> return [] -- The type is empty
481 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
483 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
484 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
485 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
487 mkHType :: Type.Type -> TypeSession (Either String HType)
489 -- FIXME: Do we really need to do this here again?
490 let builtin_ty = do -- See if this is a tycon and lookup its name
491 (tycon, args) <- Type.splitTyConApp_maybe ty
492 let name = Name.getOccString (TyCon.tyConName tycon)
493 Map.lookup name builtin_types
496 return $ Right $ BuiltinType $ prettyShow typ
498 case Type.splitTyConApp_maybe ty of
499 Just (tycon, args) -> do
500 let name = Name.getOccString (TyCon.tyConName tycon)
503 let el_ty = tfvec_elem ty
504 elem_htype_either <- mkHType el_ty
505 case elem_htype_either of
506 -- Could create element type
507 Right elem_htype -> do
508 len <- tfp_to_int (tfvec_len_ty ty)
509 return $ Right $ VecType len elem_htype
510 -- Could not create element type
511 Left err -> return $ Left $
512 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
515 len <- tfp_to_int (sized_word_len_ty ty)
516 return $ Right $ SizedWType len
518 len <- tfp_to_int (sized_word_len_ty ty)
519 return $ Right $ SizedIType len
521 bound <- tfp_to_int (ranged_word_bound_ty ty)
522 return $ Right $ RangedWType bound
524 mkTyConHType tycon args
525 Nothing -> return $ Right $ StdType $ OrdType ty
527 -- FIXME: Do we really need to do this here again?
528 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
529 mkTyConHType tycon args =
530 case TyCon.tyConDataCons tycon of
531 -- Not an algebraic type
532 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
534 let arg_tys = DataCon.dataConRepArgTys dc
535 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
536 elem_htys_either <- mapM mkHType real_arg_tys
537 case Either.partitionEithers elem_htys_either of
538 -- No errors in element types
539 ([], elem_htys) -> do
540 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
541 -- There were errors in element types
542 (errors, _) -> return $ Left $
543 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
545 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
547 tyvars = TyCon.tyConTyVars tycon
548 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
550 -- Is the given type representable at runtime?
551 isReprType :: Type.Type -> TypeSession Bool
553 ty_either <- vhdl_ty_either ty
554 return $ case ty_either of
559 tfp_to_int :: Type.Type -> TypeSession Int
561 hscenv <- getA tsHscEnv
562 let norm_ty = normalise_tfp_int hscenv ty
563 case Type.splitTyConApp_maybe norm_ty of
564 Just (tycon, args) -> do
565 let name = Name.getOccString (TyCon.tyConName tycon)
568 len <- tfp_to_int' ty
571 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
572 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
573 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
575 tfp_to_int' :: Type.Type -> TypeSession Int
577 lens <- getA tsTfpInts
578 hscenv <- getA tsHscEnv
579 let norm_ty = normalise_tfp_int hscenv ty
580 let existing_len = Map.lookup (OrdType norm_ty) lens
582 Just len -> return len
584 let new_len = eval_tfp_int hscenv ty
585 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
589 [AST.TypeMark] -- ^ type of each tuple element
590 -> AST.TypeMark -- ^ type of the tuple
592 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
594 tupPar = AST.unsafeVHDLBasicId "tup"
595 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
596 showExpr = AST.ReturnSm (Just $
597 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
599 showMiddle = if null elemTMs then
602 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
603 map ((genExprFCall showId).
606 (AST.NSimple tupPar AST.:.:).
608 (take tupSize recordlabels)
609 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
610 tupSize = length elemTMs
613 AST.TypeMark -- ^ elemtype
614 -> AST.TypeMark -- ^ vectype
615 -> [(String,AST.SubProgBody)]
616 mkVectorShow elemTM vectorTM =
617 [ (headId, AST.SubProgBody headSpec [] [headExpr])
618 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
619 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
622 vecPar = AST.unsafeVHDLBasicId "vec"
623 resId = AST.unsafeVHDLBasicId "res"
624 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
626 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
627 (AST.NSimple vecPar) [AST.PrimLit "0"])))
628 vecSlice init last = AST.PrimName (AST.NSlice
631 (AST.ToRange init last)))
632 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
633 -- variable res : fsvec_x (0 to vec'length-2);
636 (AST.SubtypeIn vectorTM
637 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
638 [AST.ToRange (AST.PrimLit "0")
639 (AST.PrimName (AST.NAttribute $
640 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
641 (AST.PrimLit "2")) ]))
643 -- res AST.:= vec(1 to vec'length-1)
644 tailExpr = AST.NSimple resId AST.:= (vecSlice
646 (AST.PrimName (AST.NAttribute $
647 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
648 AST.:-: AST.PrimLit "1"))
649 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
650 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
651 doShowId = AST.unsafeVHDLExtId "doshow"
652 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
653 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
656 -- when 0 => return "";
657 -- when 1 => return head(vec);
658 -- when others => return show(head(vec)) & ',' &
659 -- doshow (tail(vec));
662 AST.CaseSm (AST.PrimName (AST.NAttribute $
663 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
664 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
665 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
666 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
667 [AST.ReturnSm (Just $
669 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
670 AST.CaseSmAlt [AST.Others]
671 [AST.ReturnSm (Just $
673 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
674 AST.PrimLit "','" AST.:&:
675 genExprFCall doShowId
676 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
677 -- return '<' & doshow(vec) & '>';
678 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
679 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
682 mkBuiltInShow :: [AST.SubProgBody]
683 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
684 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
685 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
686 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
687 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
690 bitPar = AST.unsafeVHDLBasicId "s"
691 boolPar = AST.unsafeVHDLBasicId "b"
692 signedPar = AST.unsafeVHDLBasicId "sint"
693 unsignedPar = AST.unsafeVHDLBasicId "uint"
694 -- naturalPar = AST.unsafeVHDLBasicId "nat"
695 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
696 -- if s = '1' then return "'1'" else return "'0'"
697 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
698 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
700 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
701 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
702 -- if b then return "True" else return "False"
703 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
704 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
706 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
707 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
708 showSignedExpr = AST.ReturnSm (Just $
709 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
710 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
712 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
713 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
714 showUnsignedExpr = AST.ReturnSm (Just $
715 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
716 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
718 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
719 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
720 -- showNaturalExpr = AST.ReturnSm (Just $
721 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
722 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
725 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
726 genExprFCall fName args =
727 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
728 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
730 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
731 genExprPCall2 entid arg1 arg2 =
732 AST.ProcCall (AST.NSimple entid) $
733 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
735 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
737 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
738 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
739 case type_mark_maybe of
740 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
741 Nothing -> return Nothing
743 -- | Does the given thing have a non-empty type?
744 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
745 t -> TranslatorSession Bool
746 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)