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 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
124 -----------------------------------------------------------------------------
125 -- Functions to generate VHDL Exprs
126 -----------------------------------------------------------------------------
128 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
129 varToVHDLExpr var = do
130 case Id.isDataConWorkId_maybe var of
131 Just dc -> return $ dataconToVHDLExpr dc
132 -- This is a dataconstructor.
133 -- Not a datacon, just another signal. Perhaps we should check for
134 -- local/global here as well?
135 -- Sadly so.. tfp decimals are types, not data constructors, but instances
136 -- should still be translated to integer literals. It is probebly not the
137 -- best solution to translate them here.
138 -- FIXME: Find a better solution for translating instances of tfp integers
140 let ty = Var.varType var
141 case Type.splitTyConApp_maybe ty of
142 Just (tycon, args) ->
143 case Name.getOccString (TyCon.tyConName tycon) of
146 return $ AST.PrimLit $ (show len)
147 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
149 -- Turn a VHDLName into an AST expression
150 vhdlNameToVHDLExpr = AST.PrimName
152 -- Turn a VHDL Id into an AST expression
153 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
155 -- Turn a Core expression into an AST expression
156 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
158 -- Turn a alternative constructor into an AST expression. For
159 -- dataconstructors, this is only the constructor itself, not any arguments it
160 -- has. Should not be called with a DEFAULT constructor.
161 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
162 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
164 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
165 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
167 -- Turn a datacon (without arguments!) into a VHDL expression.
168 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
169 dataconToVHDLExpr dc = AST.PrimLit lit
171 tycon = DataCon.dataConTyCon dc
172 tyname = TyCon.tyConName tycon
173 dcname = DataCon.dataConName dc
174 lit = case Name.getOccString tyname of
175 -- TODO: Do something more robust than string matching
176 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
177 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
179 -----------------------------------------------------------------------------
180 -- Functions dealing with names, variables and ids
181 -----------------------------------------------------------------------------
183 -- Creates a VHDL Id from a binder
187 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
189 lowers :: String -> Int
190 lowers xs = length [x | x <- xs, Char.isLower x]
192 -- Creates a VHDL Name from a binder
196 varToVHDLName = AST.NSimple . varToVHDLId
198 -- Extracts the binder name as a String
202 varToString = OccName.occNameString . Name.nameOccName . Var.varName
204 -- Get the string version a Var's unique
205 varToStringUniq :: Var.Var -> String
206 varToStringUniq = show . Var.varUnique
208 -- Extracts the string version of the name
209 nameToString :: Name.Name -> String
210 nameToString = OccName.occNameString . Name.nameOccName
212 -- Shortcut for Basic VHDL Ids.
213 -- Can only contain alphanumerics and underscores. The supplied string must be
214 -- a valid basic id, otherwise an error value is returned. This function is
215 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
217 mkVHDLBasicId :: String -> AST.VHDLId
219 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
221 -- Strip invalid characters.
222 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
223 -- Strip leading numbers and underscores
224 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
225 -- Strip multiple adjacent underscores
226 strip_multiscore = concat . map (\cs ->
232 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
233 -- different characters than basic ids, but can never be used to refer to
235 -- Use extended Ids for any values that are taken from the source file.
236 mkVHDLExtId :: String -> AST.VHDLId
238 AST.unsafeVHDLExtId $ strip_invalid s
240 -- Allowed characters, taken from ForSyde's mkVHDLExtId
241 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
242 strip_invalid = filter (`elem` allowed)
244 -- Create a record field selector that selects the given label from the record
245 -- stored in the given binder.
246 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
247 mkSelectedName name label =
248 AST.NSelected $ name AST.:.: (AST.SSimple label)
250 -- Create an indexed name that selects a given element from a vector.
251 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
252 -- Special case for already indexed names. Just add an index
253 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
254 AST.NIndexed (AST.IndexedName name (indexes++[index]))
255 -- General case for other names
256 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
258 -----------------------------------------------------------------------------
259 -- Functions dealing with VHDL types
260 -----------------------------------------------------------------------------
262 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
263 -- for a few builtin types.
266 ("Bit", Just std_logicTM),
267 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
268 ("Dec", Just integerTM)
271 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
272 -- Returns an error value, using the given message, when no type could be
273 -- created. Returns Nothing when the type is valid, but empty.
274 vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
275 String -> t -> TypeSession (Maybe AST.TypeMark)
277 tm_either <- vhdl_ty_either ty
279 Right tm -> return tm
280 Left err -> error $ msg ++ "\n" ++ err
282 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
283 -- Returns either an error message or the resulting type.
284 vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
285 t -> TypeSession (Either String (Maybe AST.TypeMark))
286 vhdl_ty_either tything =
287 case getType tything of
288 Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
289 Just ty -> vhdl_ty_either' ty
291 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
292 vhdl_ty_either' ty = do
293 typemap <- getA tsTypes
294 htype_either <- mkHType ty
298 let builtin_ty = do -- See if this is a tycon and lookup its name
299 (tycon, args) <- Type.splitTyConApp_maybe ty
300 let name = Name.getOccString (TyCon.tyConName tycon)
301 Map.lookup name builtin_types
302 -- If not a builtin type, try the custom types
303 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
304 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
305 -- Found a type, return it
306 Just t -> return (Right t)
307 -- No type yet, try to construct it
309 newty_either <- (construct_vhdl_ty ty)
312 -- TODO: Check name uniqueness
313 modA tsTypes (Map.insert htype newty)
315 Just (ty_id, ty_def) -> do
316 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
317 return (Right $ Just ty_id)
318 Nothing -> return $ Right Nothing
319 Left err -> return $ Left $
320 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
322 -- Error when constructing htype
323 Left err -> return $ Left err
325 -- Construct a new VHDL type for the given Haskell type. Returns an error
326 -- message or the resulting typemark and typedef.
327 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
328 -- State types don't generate VHDL
329 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
330 construct_vhdl_ty ty = do
331 case Type.splitTyConApp_maybe ty of
332 Just (tycon, args) -> do
333 let name = Name.getOccString (TyCon.tyConName tycon)
335 "TFVec" -> mk_vector_ty ty
336 "SizedWord" -> mk_unsigned_ty ty
337 "SizedInt" -> mk_signed_ty ty
339 bound <- tfp_to_int (ranged_word_bound_ty ty)
340 mk_natural_ty 0 bound
341 -- Create a custom type from this tycon
342 otherwise -> mk_tycon_ty ty tycon args
343 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
345 -- | Create VHDL type for a custom tycon
346 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
347 mk_tycon_ty ty tycon args =
348 case TyCon.tyConDataCons tycon of
349 -- Not an algebraic type
350 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
352 let arg_tys = DataCon.dataConRepArgTys dc
353 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
354 -- violation? Or does it only mean not to apply it again to the same
356 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
357 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
358 case Either.partitionEithers elem_tys_either of
359 -- No errors in element types
360 ([], elem_tys') -> do
361 -- Throw away all empty members
362 case Maybe.catMaybes elem_tys' of
363 [] -> -- No non-empty members
364 return $ Right Nothing
366 let elems = zipWith AST.ElementDec recordlabels elem_tys
367 -- For a single construct datatype, build a record with one field for
369 -- TODO: Add argument type ids to this, to ensure uniqueness
370 -- TODO: Special handling for tuples?
371 let elem_names = concat $ map prettyShow elem_tys
372 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
373 let ty_def = AST.TDR $ AST.RecordTypeDef elems
374 let tupshow = mkTupleShow elem_tys ty_id
375 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
376 return $ Right $ Just (ty_id, Left ty_def)
377 -- There were errors in element types
378 (errors, _) -> return $ Left $
379 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
381 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
383 -- Create a subst that instantiates all types passed to the tycon
384 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
385 -- to work so far, though..
386 tyvars = TyCon.tyConTyVars tycon
387 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
388 -- Generate a bunch of labels for fields of a record
389 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
391 -- | Create a VHDL vector type
393 Type.Type -- ^ The Haskell type of the Vector
394 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
395 -- ^ An error message or The typemark created.
398 types_map <- getA tsTypes
400 let (nvec_l, nvec_el) = Type.splitAppTy ty
401 let (nvec, leng) = Type.splitAppTy nvec_l
402 let vec_ty = Type.mkAppTy nvec nvec_el
403 len <- tfp_to_int (tfvec_len_ty ty)
404 let el_ty = tfvec_elem ty
405 el_ty_tm_either <- vhdl_ty_either el_ty
406 case el_ty_tm_either of
407 -- Could create element type
408 Right (Just el_ty_tm) -> do
409 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
410 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
411 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
412 case existing_elem_ty of
414 let ty_def = AST.SubtypeIn t (Just range)
415 return (Right $ Just (ty_id, Right ty_def))
417 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
418 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
419 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
420 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
421 let vecShowFuns = mkVectorShow el_ty_tm vec_id
422 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
423 let ty_def = AST.SubtypeIn vec_id (Just range)
424 return (Right $ Just (ty_id, Right ty_def))
425 -- Empty element type? Empty vector type then. TODO: Does this make sense?
426 -- Probably needs changes in the builtin functions as well...
427 Right Nothing -> return $ Right Nothing
428 -- Could not create element type
429 Left err -> return $ Left $
430 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
434 Int -- ^ The minimum bound (> 0)
435 -> Int -- ^ The maximum bound (> minimum bound)
436 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
437 -- ^ An error message or The typemark created.
438 mk_natural_ty min_bound max_bound = do
439 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
440 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
441 let ty_def = AST.SubtypeIn naturalTM (Just range)
442 return (Right $ Just (ty_id, Right ty_def))
445 Type.Type -- ^ Haskell type of the unsigned integer
446 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
447 mk_unsigned_ty ty = do
448 size <- tfp_to_int (sized_word_len_ty ty)
449 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
450 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
451 let ty_def = AST.SubtypeIn unsignedTM (Just range)
452 return (Right $ Just (ty_id, Right ty_def))
455 Type.Type -- ^ Haskell type of the signed integer
456 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
458 size <- tfp_to_int (sized_int_len_ty ty)
459 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
460 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
461 let ty_def = AST.SubtypeIn signedTM (Just range)
462 return (Right $ Just (ty_id, Right ty_def))
464 -- Finds the field labels for VHDL type generated for the given Core type,
465 -- which must result in a record type.
466 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
467 getFieldLabels ty = do
468 -- Ensure that the type is generated (but throw away it's VHDLId)
469 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
471 -- Get the types map, lookup and unpack the VHDL TypeDef
472 types <- getA tsTypes
473 -- Assume the type for which we want labels is really translatable
474 Right htype <- mkHType ty
475 case Map.lookup htype types of
476 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
477 Just Nothing -> return [] -- The type is empty
478 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
480 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
481 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
482 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
484 mkHType :: Type.Type -> TypeSession (Either String HType)
486 -- FIXME: Do we really need to do this here again?
487 let builtin_ty = do -- See if this is a tycon and lookup its name
488 (tycon, args) <- Type.splitTyConApp_maybe ty
489 let name = Name.getOccString (TyCon.tyConName tycon)
490 Map.lookup name builtin_types
493 return $ Right $ BuiltinType $ prettyShow typ
495 case Type.splitTyConApp_maybe ty of
496 Just (tycon, args) -> do
497 let name = Name.getOccString (TyCon.tyConName tycon)
500 let el_ty = tfvec_elem ty
501 elem_htype_either <- mkHType el_ty
502 case elem_htype_either of
503 -- Could create element type
504 Right elem_htype -> do
505 len <- tfp_to_int (tfvec_len_ty ty)
506 return $ Right $ VecType len elem_htype
507 -- Could not create element type
508 Left err -> return $ Left $
509 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
512 len <- tfp_to_int (sized_word_len_ty ty)
513 return $ Right $ SizedWType len
515 len <- tfp_to_int (sized_word_len_ty ty)
516 return $ Right $ SizedIType len
518 bound <- tfp_to_int (ranged_word_bound_ty ty)
519 return $ Right $ RangedWType bound
521 mkTyConHType tycon args
522 Nothing -> return $ Right $ StdType $ OrdType ty
524 -- FIXME: Do we really need to do this here again?
525 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
526 mkTyConHType tycon args =
527 case TyCon.tyConDataCons tycon of
528 -- Not an algebraic type
529 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
531 let arg_tys = DataCon.dataConRepArgTys dc
532 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
533 elem_htys_either <- mapM mkHType real_arg_tys
534 case Either.partitionEithers elem_htys_either of
535 -- No errors in element types
536 ([], elem_htys) -> do
537 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
538 -- There were errors in element types
539 (errors, _) -> return $ Left $
540 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
542 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
544 tyvars = TyCon.tyConTyVars tycon
545 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
547 -- Is the given type representable at runtime?
548 isReprType :: Type.Type -> TypeSession Bool
550 ty_either <- vhdl_ty_either ty
551 return $ case ty_either of
556 tfp_to_int :: Type.Type -> TypeSession Int
558 hscenv <- getA tsHscEnv
559 let norm_ty = normalise_tfp_int hscenv ty
560 case Type.splitTyConApp_maybe norm_ty of
561 Just (tycon, args) -> do
562 let name = Name.getOccString (TyCon.tyConName tycon)
565 len <- tfp_to_int' ty
568 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
569 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
570 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
572 tfp_to_int' :: Type.Type -> TypeSession Int
574 lens <- getA tsTfpInts
575 hscenv <- getA tsHscEnv
576 let norm_ty = normalise_tfp_int hscenv ty
577 let existing_len = Map.lookup (OrdType norm_ty) lens
579 Just len -> return len
581 let new_len = eval_tfp_int hscenv ty
582 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
586 [AST.TypeMark] -- ^ type of each tuple element
587 -> AST.TypeMark -- ^ type of the tuple
589 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
591 tupPar = AST.unsafeVHDLBasicId "tup"
592 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
593 showExpr = AST.ReturnSm (Just $
594 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
596 showMiddle = if null elemTMs then
599 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
600 map ((genExprFCall showId).
603 (AST.NSimple tupPar AST.:.:).
605 (take tupSize recordlabels)
606 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
607 tupSize = length elemTMs
610 AST.TypeMark -- ^ elemtype
611 -> AST.TypeMark -- ^ vectype
612 -> [(String,AST.SubProgBody)]
613 mkVectorShow elemTM vectorTM =
614 [ (headId, AST.SubProgBody headSpec [] [headExpr])
615 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
616 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
619 vecPar = AST.unsafeVHDLBasicId "vec"
620 resId = AST.unsafeVHDLBasicId "res"
621 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
623 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
624 (AST.NSimple vecPar) [AST.PrimLit "0"])))
625 vecSlice init last = AST.PrimName (AST.NSlice
628 (AST.ToRange init last)))
629 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
630 -- variable res : fsvec_x (0 to vec'length-2);
633 (AST.SubtypeIn vectorTM
634 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
635 [AST.ToRange (AST.PrimLit "0")
636 (AST.PrimName (AST.NAttribute $
637 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
638 (AST.PrimLit "2")) ]))
640 -- res AST.:= vec(1 to vec'length-1)
641 tailExpr = AST.NSimple resId AST.:= (vecSlice
643 (AST.PrimName (AST.NAttribute $
644 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
645 AST.:-: AST.PrimLit "1"))
646 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
647 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
648 doShowId = AST.unsafeVHDLExtId "doshow"
649 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
650 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
653 -- when 0 => return "";
654 -- when 1 => return head(vec);
655 -- when others => return show(head(vec)) & ',' &
656 -- doshow (tail(vec));
659 AST.CaseSm (AST.PrimName (AST.NAttribute $
660 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
661 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
662 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
663 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
664 [AST.ReturnSm (Just $
666 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
667 AST.CaseSmAlt [AST.Others]
668 [AST.ReturnSm (Just $
670 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
671 AST.PrimLit "','" AST.:&:
672 genExprFCall doShowId
673 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
674 -- return '<' & doshow(vec) & '>';
675 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
676 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
679 mkBuiltInShow :: [AST.SubProgBody]
680 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
681 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
682 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
683 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
684 , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
687 bitPar = AST.unsafeVHDLBasicId "s"
688 boolPar = AST.unsafeVHDLBasicId "b"
689 signedPar = AST.unsafeVHDLBasicId "sint"
690 unsignedPar = AST.unsafeVHDLBasicId "uint"
691 naturalPar = AST.unsafeVHDLBasicId "nat"
692 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
693 -- if s = '1' then return "'1'" else return "'0'"
694 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
695 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
697 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
698 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
699 -- if b then return "True" else return "False"
700 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
701 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
703 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
704 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
705 showSignedExpr = AST.ReturnSm (Just $
706 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
707 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
709 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
710 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
711 showUnsignedExpr = AST.ReturnSm (Just $
712 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
713 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
715 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
716 showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
717 showNaturalExpr = AST.ReturnSm (Just $
718 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
719 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
722 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
723 genExprFCall fName args =
724 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
725 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
727 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
728 genExprPCall2 entid arg1 arg2 =
729 AST.ProcCall (AST.NSimple entid) $
730 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
732 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
734 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
735 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
736 case type_mark_maybe of
737 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
738 Nothing -> return Nothing
740 -- | Does the given thing have a non-empty type?
741 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
742 t -> TranslatorSession Bool
743 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)