1 module CLasH.VHDL.VHDLTools where
5 import qualified Data.Either as Either
6 import qualified Data.List as List
7 import qualified Data.Map as Map
8 import qualified Control.Monad as Monad
9 import qualified Control.Arrow as Arrow
10 import qualified Control.Monad.Trans.State as State
11 import qualified Data.Monoid as Monoid
13 import Data.Accessor.MonadState as MonadState
17 import qualified Language.VHDL.AST as AST
22 import qualified OccName
25 import qualified IdInfo
26 import qualified TyCon
28 import qualified DataCon
29 import qualified CoreSubst
32 import CLasH.VHDL.VHDLTypes
33 import CLasH.Translator.TranslatorTypes
34 import CLasH.Utils.Core.CoreTools
35 import CLasH.Utils.Pretty
36 import CLasH.VHDL.Constants
38 -----------------------------------------------------------------------------
39 -- Functions to generate concurrent statements
40 -----------------------------------------------------------------------------
42 -- Create an unconditional assignment statement
44 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
45 -> AST.Expr -- ^ The expression to assign
46 -> AST.ConcSm -- ^ The resulting concurrent statement
47 mkUncondAssign dst expr = mkAssign dst Nothing expr
49 -- Create a conditional assignment statement
51 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
52 -> AST.Expr -- ^ The condition
53 -> AST.Expr -- ^ The value when true
54 -> AST.Expr -- ^ The value when false
55 -> AST.ConcSm -- ^ The resulting concurrent statement
56 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
58 -- Create a conditional or unconditional assignment statement
60 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
61 -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
62 -- and the value to assign when true.
63 -> AST.Expr -- ^ The value to assign when false or no condition
64 -> AST.ConcSm -- ^ The resulting concurrent statement
65 mkAssign dst cond false_expr =
67 -- I'm not 100% how this assignment AST works, but this gets us what we
69 whenelse = case cond of
70 Just (cond_expr, true_expr) ->
72 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
74 [AST.WhenElse true_wform cond_expr]
76 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
77 dst_name = case dst of
78 Left bndr -> AST.NSimple (varToVHDLId bndr)
80 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
85 [AST.Expr] -- ^ The argument that are applied to function
86 -> AST.VHDLName -- ^ The binder in which to store the result
87 -> Entity -- ^ The entity to map against.
88 -> TranslatorSession [AST.AssocElem] -- ^ The resulting port maps
89 mkAssocElems args res entity =
90 -- Create the actual AssocElems
91 return $ zipWith mkAssocElem ports sigs
93 -- Turn the ports and signals from a map into a flat list. This works,
94 -- since the maps must have an identical form by definition. TODO: Check
96 arg_ports = ent_args entity
97 res_port = ent_res entity
98 -- Extract the id part from the (id, type) tuple
99 ports = map fst (res_port : arg_ports)
100 -- Translate signal numbers into names
101 sigs = (vhdlNameToVHDLExpr res : args)
103 -- | Create an VHDL port -> signal association
104 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
105 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
107 -- | Create an aggregate signal
108 mkAggregateSignal :: [AST.Expr] -> AST.Expr
109 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
112 String -- ^ The portmap label
113 -> AST.VHDLId -- ^ The entity name
114 -> [AST.AssocElem] -- ^ The port assignments
116 mkComponentInst label entity_id portassigns = AST.CSISm compins
118 -- We always have a clock port, so no need to map it anywhere but here
119 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
120 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
122 -----------------------------------------------------------------------------
123 -- Functions to generate VHDL Exprs
124 -----------------------------------------------------------------------------
126 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
127 varToVHDLExpr var = do
128 case Id.isDataConWorkId_maybe var of
129 Just dc -> return $ dataconToVHDLExpr dc
130 -- This is a dataconstructor.
131 -- Not a datacon, just another signal. Perhaps we should check for
132 -- local/global here as well?
133 -- Sadly so.. tfp decimals are types, not data constructors, but instances
134 -- should still be translated to integer literals. It is probebly not the
135 -- best solution to translate them here.
136 -- FIXME: Find a better solution for translating instances of tfp integers
138 let ty = Var.varType var
139 case Type.splitTyConApp_maybe ty of
140 Just (tycon, args) ->
141 case Name.getOccString (TyCon.tyConName tycon) of
144 return $ AST.PrimLit $ (show len)
145 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
147 -- Turn a VHDLName into an AST expression
148 vhdlNameToVHDLExpr = AST.PrimName
150 -- Turn a VHDL Id into an AST expression
151 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
153 -- Turn a Core expression into an AST expression
154 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
156 -- Turn a alternative constructor into an AST expression. For
157 -- dataconstructors, this is only the constructor itself, not any arguments it
158 -- has. Should not be called with a DEFAULT constructor.
159 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
160 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
162 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
163 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
165 -- Turn a datacon (without arguments!) into a VHDL expression.
166 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
167 dataconToVHDLExpr dc = AST.PrimLit lit
169 tycon = DataCon.dataConTyCon dc
170 tyname = TyCon.tyConName tycon
171 dcname = DataCon.dataConName dc
172 lit = case Name.getOccString tyname of
173 -- TODO: Do something more robust than string matching
174 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
175 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
177 -----------------------------------------------------------------------------
178 -- Functions dealing with names, variables and ids
179 -----------------------------------------------------------------------------
181 -- Creates a VHDL Id from a binder
185 varToVHDLId = mkVHDLExtId . varToString
187 -- Creates a VHDL Name from a binder
191 varToVHDLName = AST.NSimple . varToVHDLId
193 -- Extracts the binder name as a String
197 varToString = OccName.occNameString . Name.nameOccName . Var.varName
199 -- Get the string version a Var's unique
200 varToStringUniq :: Var.Var -> String
201 varToStringUniq = show . Var.varUnique
203 -- Extracts the string version of the name
204 nameToString :: Name.Name -> String
205 nameToString = OccName.occNameString . Name.nameOccName
207 -- Shortcut for Basic VHDL Ids.
208 -- Can only contain alphanumerics and underscores. The supplied string must be
209 -- a valid basic id, otherwise an error value is returned. This function is
210 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
212 mkVHDLBasicId :: String -> AST.VHDLId
214 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
216 -- Strip invalid characters.
217 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
218 -- Strip leading numbers and underscores
219 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
220 -- Strip multiple adjacent underscores
221 strip_multiscore = concat . map (\cs ->
227 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
228 -- different characters than basic ids, but can never be used to refer to
230 -- Use extended Ids for any values that are taken from the source file.
231 mkVHDLExtId :: String -> AST.VHDLId
233 AST.unsafeVHDLExtId $ strip_invalid s
235 -- Allowed characters, taken from ForSyde's mkVHDLExtId
236 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
237 strip_invalid = filter (`elem` allowed)
239 -- Create a record field selector that selects the given label from the record
240 -- stored in the given binder.
241 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
242 mkSelectedName name label =
243 AST.NSelected $ name AST.:.: (AST.SSimple label)
245 -- Create an indexed name that selects a given element from a vector.
246 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
247 -- Special case for already indexed names. Just add an index
248 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
249 AST.NIndexed (AST.IndexedName name (indexes++[index]))
250 -- General case for other names
251 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
253 -----------------------------------------------------------------------------
254 -- Functions dealing with VHDL types
255 -----------------------------------------------------------------------------
257 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
258 -- for a few builtin types.
261 ("Bit", Just std_logicTM),
262 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
263 ("Dec", Just integerTM)
266 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
267 -- Returns an error value, using the given message, when no type could be
268 -- created. Returns Nothing when the type is valid, but empty.
269 vhdl_ty :: String -> Type.Type -> TypeSession (Maybe AST.TypeMark)
271 tm_either <- vhdl_ty_either ty
273 Right tm -> return tm
274 Left err -> error $ msg ++ "\n" ++ err
276 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
277 -- Returns either an error message or the resulting type.
278 vhdl_ty_either :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
279 vhdl_ty_either ty = do
280 typemap <- getA tsTypes
281 htype_either <- mkHType ty
285 let builtin_ty = do -- See if this is a tycon and lookup its name
286 (tycon, args) <- Type.splitTyConApp_maybe ty
287 let name = Name.getOccString (TyCon.tyConName tycon)
288 Map.lookup name builtin_types
289 -- If not a builtin type, try the custom types
290 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
291 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
292 -- Found a type, return it
293 Just t -> return (Right t)
294 -- No type yet, try to construct it
296 newty_either <- (construct_vhdl_ty ty)
299 -- TODO: Check name uniqueness
300 modA tsTypes (Map.insert htype newty)
302 Just (ty_id, ty_def) -> do
303 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
304 return (Right $ Just ty_id)
305 Nothing -> return $ Right Nothing
306 Left err -> return $ Left $
307 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
309 -- Error when constructing htype
310 Left err -> return $ Left err
312 -- Construct a new VHDL type for the given Haskell type. Returns an error
313 -- message or the resulting typemark and typedef.
314 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
315 -- State types don't generate VHDL
316 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
317 construct_vhdl_ty ty = do
318 case Type.splitTyConApp_maybe ty of
319 Just (tycon, args) -> do
320 let name = Name.getOccString (TyCon.tyConName tycon)
322 "TFVec" -> mk_vector_ty ty
323 "SizedWord" -> mk_unsigned_ty ty
324 "SizedInt" -> mk_signed_ty ty
326 bound <- tfp_to_int (ranged_word_bound_ty ty)
327 mk_natural_ty 0 bound
328 -- Create a custom type from this tycon
329 otherwise -> mk_tycon_ty ty tycon args
330 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
332 -- | Create VHDL type for a custom tycon
333 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
334 mk_tycon_ty ty tycon args =
335 case TyCon.tyConDataCons tycon of
336 -- Not an algebraic type
337 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
339 let arg_tys = DataCon.dataConRepArgTys dc
340 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
341 -- violation? Or does it only mean not to apply it again to the same
343 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
344 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
345 case Either.partitionEithers elem_tys_either of
346 -- No errors in element types
347 ([], elem_tys') -> do
348 -- Throw away all empty members
349 case Maybe.catMaybes elem_tys' of
350 [] -> -- No non-empty members
351 return $ Right Nothing
353 let elems = zipWith AST.ElementDec recordlabels elem_tys
354 -- For a single construct datatype, build a record with one field for
356 -- TODO: Add argument type ids to this, to ensure uniqueness
357 -- TODO: Special handling for tuples?
358 let elem_names = concat $ map prettyShow elem_tys
359 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
360 let ty_def = AST.TDR $ AST.RecordTypeDef elems
361 let tupshow = mkTupleShow elem_tys ty_id
362 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
363 return $ Right $ Just (ty_id, Left ty_def)
364 -- There were errors in element types
365 (errors, _) -> return $ Left $
366 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
368 dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
370 -- Create a subst that instantiates all types passed to the tycon
371 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
372 -- to work so far, though..
373 tyvars = TyCon.tyConTyVars tycon
374 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
375 -- Generate a bunch of labels for fields of a record
376 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
378 -- | Create a VHDL vector type
380 Type.Type -- ^ The Haskell type of the Vector
381 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
382 -- ^ An error message or The typemark created.
385 types_map <- getA tsTypes
387 let (nvec_l, nvec_el) = Type.splitAppTy ty
388 let (nvec, leng) = Type.splitAppTy nvec_l
389 let vec_ty = Type.mkAppTy nvec nvec_el
390 len <- tfp_to_int (tfvec_len_ty ty)
391 let el_ty = tfvec_elem ty
392 el_ty_tm_either <- vhdl_ty_either el_ty
393 case el_ty_tm_either of
394 -- Could create element type
395 Right (Just el_ty_tm) -> do
396 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
397 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
398 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
399 case existing_elem_ty of
401 let ty_def = AST.SubtypeIn t (Just range)
402 return (Right $ Just (ty_id, Right ty_def))
404 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
405 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
406 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
407 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
408 let vecShowFuns = mkVectorShow el_ty_tm vec_id
409 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
410 let ty_def = AST.SubtypeIn vec_id (Just range)
411 return (Right $ Just (ty_id, Right ty_def))
412 -- Empty element type? Empty vector type then. TODO: Does this make sense?
413 -- Probably needs changes in the builtin functions as well...
414 Right Nothing -> return $ Right Nothing
415 -- Could not create element type
416 Left err -> return $ Left $
417 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
421 Int -- ^ The minimum bound (> 0)
422 -> Int -- ^ The maximum bound (> minimum bound)
423 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
424 -- ^ An error message or The typemark created.
425 mk_natural_ty min_bound max_bound = do
426 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
427 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
428 let ty_def = AST.SubtypeIn naturalTM (Just range)
429 return (Right $ Just (ty_id, Right ty_def))
432 Type.Type -- ^ Haskell type of the unsigned integer
433 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
434 mk_unsigned_ty ty = do
435 size <- tfp_to_int (sized_word_len_ty ty)
436 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
437 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
438 let ty_def = AST.SubtypeIn unsignedTM (Just range)
439 let unsignedshow = mkIntegerShow ty_id
440 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
441 return (Right $ Just (ty_id, Right ty_def))
444 Type.Type -- ^ Haskell type of the signed integer
445 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
447 size <- tfp_to_int (sized_int_len_ty ty)
448 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
449 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
450 let ty_def = AST.SubtypeIn signedTM (Just range)
451 let signedshow = mkIntegerShow ty_id
452 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
453 return (Right $ Just (ty_id, Right ty_def))
455 -- Finds the field labels for VHDL type generated for the given Core type,
456 -- which must result in a record type.
457 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
458 getFieldLabels ty = do
459 -- Ensure that the type is generated (but throw away it's VHDLId)
460 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
462 -- Get the types map, lookup and unpack the VHDL TypeDef
463 types <- getA tsTypes
464 -- Assume the type for which we want labels is really translatable
465 Right htype <- mkHType ty
466 case Map.lookup htype types of
467 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
468 Just Nothing -> return [] -- The type is empty
469 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
471 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
472 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
473 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
475 mkHType :: Type.Type -> TypeSession (Either String HType)
477 -- FIXME: Do we really need to do this here again?
478 let builtin_ty = do -- See if this is a tycon and lookup its name
479 (tycon, args) <- Type.splitTyConApp_maybe ty
480 let name = Name.getOccString (TyCon.tyConName tycon)
481 Map.lookup name builtin_types
484 return $ Right $ BuiltinType $ prettyShow typ
486 case Type.splitTyConApp_maybe ty of
487 Just (tycon, args) -> do
488 let name = Name.getOccString (TyCon.tyConName tycon)
491 let el_ty = tfvec_elem ty
492 elem_htype_either <- mkHType el_ty
493 case elem_htype_either of
494 -- Could create element type
495 Right elem_htype -> do
496 len <- tfp_to_int (tfvec_len_ty ty)
497 return $ Right $ VecType len elem_htype
498 -- Could not create element type
499 Left err -> return $ Left $
500 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
503 len <- tfp_to_int (sized_word_len_ty ty)
504 return $ Right $ SizedWType len
506 len <- tfp_to_int (sized_word_len_ty ty)
507 return $ Right $ SizedIType len
509 bound <- tfp_to_int (ranged_word_bound_ty ty)
510 return $ Right $ RangedWType bound
512 mkTyConHType tycon args
513 Nothing -> return $ Right $ StdType $ OrdType ty
515 -- FIXME: Do we really need to do this here again?
516 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
517 mkTyConHType tycon args =
518 case TyCon.tyConDataCons tycon of
519 -- Not an algebraic type
520 [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
522 let arg_tys = DataCon.dataConRepArgTys dc
523 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
524 elem_htys_either <- mapM mkHType real_arg_tys
525 case Either.partitionEithers elem_htys_either of
526 -- No errors in element types
527 ([], elem_htys) -> do
528 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
529 -- There were errors in element types
530 (errors, _) -> return $ Left $
531 "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
533 dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
535 tyvars = TyCon.tyConTyVars tycon
536 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
538 -- Is the given type representable at runtime?
539 isReprType :: Type.Type -> TypeSession Bool
541 ty_either <- vhdl_ty_either ty
542 return $ case ty_either of
547 tfp_to_int :: Type.Type -> TypeSession Int
549 hscenv <- getA tsHscEnv
550 let norm_ty = normalise_tfp_int hscenv ty
551 case Type.splitTyConApp_maybe norm_ty of
552 Just (tycon, args) -> do
553 let name = Name.getOccString (TyCon.tyConName tycon)
556 len <- tfp_to_int' ty
559 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
560 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
561 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
563 tfp_to_int' :: Type.Type -> TypeSession Int
565 lens <- getA tsTfpInts
566 hscenv <- getA tsHscEnv
567 let norm_ty = normalise_tfp_int hscenv ty
568 let existing_len = Map.lookup (OrdType norm_ty) lens
570 Just len -> return len
572 let new_len = eval_tfp_int hscenv ty
573 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
577 [AST.TypeMark] -- ^ type of each tuple element
578 -> AST.TypeMark -- ^ type of the tuple
580 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
582 tupPar = AST.unsafeVHDLBasicId "tup"
583 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
584 showExpr = AST.ReturnSm (Just $
585 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
587 showMiddle = if null elemTMs then
590 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
591 map ((genExprFCall showId).
594 (AST.NSimple tupPar AST.:.:).
596 (take tupSize recordlabels)
597 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
598 tupSize = length elemTMs
601 AST.TypeMark -- ^ elemtype
602 -> AST.TypeMark -- ^ vectype
603 -> [(String,AST.SubProgBody)]
604 mkVectorShow elemTM vectorTM =
605 [ (headId, AST.SubProgBody headSpec [] [headExpr])
606 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
607 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
610 vecPar = AST.unsafeVHDLBasicId "vec"
611 resId = AST.unsafeVHDLBasicId "res"
612 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
614 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
615 (AST.NSimple vecPar) [AST.PrimLit "0"])))
616 vecSlice init last = AST.PrimName (AST.NSlice
619 (AST.ToRange init last)))
620 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
621 -- variable res : fsvec_x (0 to vec'length-2);
624 (AST.SubtypeIn vectorTM
625 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
626 [AST.ToRange (AST.PrimLit "0")
627 (AST.PrimName (AST.NAttribute $
628 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
629 (AST.PrimLit "2")) ]))
631 -- res AST.:= vec(1 to vec'length-1)
632 tailExpr = AST.NSimple resId AST.:= (vecSlice
634 (AST.PrimName (AST.NAttribute $
635 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
636 AST.:-: AST.PrimLit "1"))
637 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
638 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
639 doShowId = AST.unsafeVHDLExtId "doshow"
640 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
641 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
644 -- when 0 => return "";
645 -- when 1 => return head(vec);
646 -- when others => return show(head(vec)) & ',' &
647 -- doshow (tail(vec));
650 AST.CaseSm (AST.PrimName (AST.NAttribute $
651 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
652 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
653 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
654 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
655 [AST.ReturnSm (Just $
657 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
658 AST.CaseSmAlt [AST.Others]
659 [AST.ReturnSm (Just $
661 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
662 AST.PrimLit "','" AST.:&:
663 genExprFCall doShowId
664 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
665 -- return '<' & doshow(vec) & '>';
666 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
667 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
671 AST.TypeMark -- ^ The specific signed
673 mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
675 signedPar = AST.unsafeVHDLBasicId "sint"
676 showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
677 showExpr = AST.ReturnSm (Just $
678 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
679 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
681 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
683 mkBuiltInShow :: [AST.SubProgBody]
684 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
685 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
688 bitPar = AST.unsafeVHDLBasicId "s"
689 boolPar = AST.unsafeVHDLBasicId "b"
690 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
691 -- if s = '1' then return "'1'" else return "'0'"
692 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
693 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
695 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
696 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
697 -- if b then return "True" else return "False"
698 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
699 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
701 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
703 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
704 genExprFCall fName args =
705 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
706 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
708 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
709 genExprPCall2 entid arg1 arg2 =
710 AST.ProcCall (AST.NSimple entid) $
711 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
713 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
715 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
716 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
717 case type_mark_maybe of
718 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
719 Nothing -> return Nothing