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 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
90 -> [AST.Expr] -- ^ The conditions
91 -> [AST.Expr] -- ^ The expressions
92 -> AST.ConcSm -- ^ The Alt assigns
93 mkAltsAssign dst conds exprs
94 | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
97 whenelses = zipWith mkWhenElse conds exprs
98 false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
99 dst_name = case dst of
100 Left bndr -> AST.NSimple (varToVHDLId bndr)
102 assign = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
106 mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
107 mkWhenElse cond true_expr =
109 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
111 AST.WhenElse true_wform cond
114 [AST.Expr] -- ^ The argument that are applied to function
115 -> AST.VHDLName -- ^ The binder in which to store the result
116 -> Entity -- ^ The entity to map against.
117 -> [AST.AssocElem] -- ^ The resulting port maps
118 mkAssocElems args res entity =
119 arg_maps ++ (Maybe.maybeToList res_map_maybe)
121 arg_ports = ent_args entity
122 res_port_maybe = ent_res entity
123 -- Create an expression of res to map against the output port
124 res_expr = vhdlNameToVHDLExpr res
125 -- Map each of the input ports
126 arg_maps = zipWith mkAssocElem (map fst arg_ports) args
127 -- Map the output port, if present
128 res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
130 -- | Create an VHDL port -> signal association
131 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
132 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
134 -- | Create an aggregate signal
135 mkAggregateSignal :: [AST.Expr] -> AST.Expr
136 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
139 String -- ^ The portmap label
140 -> AST.VHDLId -- ^ The entity name
141 -> [AST.AssocElem] -- ^ The port assignments
143 mkComponentInst label entity_id portassigns = AST.CSISm compins
145 -- We always have a clock port, so no need to map it anywhere but here
146 clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
147 resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
148 compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
150 -----------------------------------------------------------------------------
151 -- Functions to generate VHDL Exprs
152 -----------------------------------------------------------------------------
154 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
155 varToVHDLExpr var = do
156 case Id.isDataConWorkId_maybe var of
157 Just dc -> dataconToVHDLExpr dc
158 -- This is a dataconstructor.
159 -- Not a datacon, just another signal. Perhaps we should check for
160 -- local/global here as well?
161 -- Sadly so.. tfp decimals are types, not data constructors, but instances
162 -- should still be translated to integer literals. It is probebly not the
163 -- best solution to translate them here.
164 -- FIXME: Find a better solution for translating instances of tfp integers
166 let ty = Var.varType var
167 case Type.splitTyConApp_maybe ty of
168 Just (tycon, args) ->
169 case Name.getOccString (TyCon.tyConName tycon) of
172 return $ AST.PrimLit $ (show len)
173 otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
175 -- Turn a VHDLName into an AST expression
176 vhdlNameToVHDLExpr = AST.PrimName
178 -- Turn a VHDL Id into an AST expression
179 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
181 -- Turn a Core expression into an AST expression
182 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
184 -- Turn a alternative constructor into an AST expression. For
185 -- dataconstructors, this is only the constructor itself, not any arguments it
186 -- has. Should not be called with a DEFAULT constructor.
187 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
188 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
190 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
191 altconToVHDLExpr DEFAULT = return $ AST.PrimLit "undefined" -- error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
193 -- Turn a datacon (without arguments!) into a VHDL expression.
194 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
195 dataconToVHDLExpr dc = do
196 typemap <- getA tsTypes
197 htype_either <- mkHType (DataCon.dataConRepType dc)
201 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
204 let dcname = DataCon.dataConName dc
205 let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
208 let tycon = DataCon.dataConTyCon dc
209 let tyname = TyCon.tyConName tycon
210 let dcname = DataCon.dataConName dc
211 let lit = case Name.getOccString tyname of
212 -- TODO: Do something more robust than string matching
213 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
214 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
215 return $ AST.PrimLit lit
216 -- Error when constructing htype
217 Left err -> error err
219 -----------------------------------------------------------------------------
220 -- Functions dealing with names, variables and ids
221 -----------------------------------------------------------------------------
223 -- Creates a VHDL Id from a binder
227 varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
229 lowers :: String -> Int
230 lowers xs = length [x | x <- xs, Char.isLower x]
232 -- Creates a VHDL Name from a binder
236 varToVHDLName = AST.NSimple . varToVHDLId
238 -- Extracts the binder name as a String
242 varToString = OccName.occNameString . Name.nameOccName . Var.varName
244 -- Get the string version a Var's unique
245 varToStringUniq :: Var.Var -> String
246 varToStringUniq = show . Var.varUnique
248 -- Extracts the string version of the name
249 nameToString :: Name.Name -> String
250 nameToString = OccName.occNameString . Name.nameOccName
252 -- Shortcut for Basic VHDL Ids.
253 -- Can only contain alphanumerics and underscores. The supplied string must be
254 -- a valid basic id, otherwise an error value is returned. This function is
255 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
257 mkVHDLBasicId :: String -> AST.VHDLId
259 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
261 -- Strip invalid characters.
262 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
263 -- Strip leading numbers and underscores
264 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
265 -- Strip multiple adjacent underscores
266 strip_multiscore = concat . map (\cs ->
272 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
273 -- different characters than basic ids, but can never be used to refer to
275 -- Use extended Ids for any values that are taken from the source file.
276 mkVHDLExtId :: String -> AST.VHDLId
278 AST.unsafeVHDLExtId $ strip_invalid s
280 -- Allowed characters, taken from ForSyde's mkVHDLExtId
281 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
282 strip_invalid = filter (`elem` allowed)
284 -- Create a record field selector that selects the given label from the record
285 -- stored in the given binder.
286 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
287 mkSelectedName name label =
288 AST.NSelected $ name AST.:.: (AST.SSimple label)
290 -- Create an indexed name that selects a given element from a vector.
291 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
292 -- Special case for already indexed names. Just add an index
293 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
294 AST.NIndexed (AST.IndexedName name (indexes++[index]))
295 -- General case for other names
296 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
298 -----------------------------------------------------------------------------
299 -- Functions dealing with VHDL types
300 -----------------------------------------------------------------------------
302 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
303 -- for a few builtin types.
306 ("Bit", Just std_logicTM),
307 ("Bool", Just booleanTM), -- TysWiredIn.boolTy
308 ("Dec", Just integerTM)
311 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
312 -- Returns an error value, using the given message, when no type could be
313 -- created. Returns Nothing when the type is valid, but empty.
314 vhdl_ty :: (TypedThing t, Outputable.Outputable t) =>
315 String -> t -> TypeSession (Maybe AST.TypeMark)
317 tm_either <- vhdl_ty_either ty
319 Right tm -> return tm
320 Left err -> error $ msg ++ "\n" ++ err
322 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
323 -- Returns either an error message or the resulting type.
324 vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) =>
325 t -> TypeSession (Either String (Maybe AST.TypeMark))
326 vhdl_ty_either tything =
327 case getType tything of
328 Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
329 Just ty -> vhdl_ty_either' ty
331 vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
332 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
334 typemap <- getA tsTypes
335 htype_either <- mkHType ty
339 let builtin_ty = do -- See if this is a tycon and lookup its name
340 (tycon, args) <- Type.splitTyConApp_maybe ty
341 let name = Name.getOccString (TyCon.tyConName tycon)
342 Map.lookup name builtin_types
343 -- If not a builtin type, try the custom types
344 let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
345 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
346 -- Found a type, return it
347 Just t -> return (Right t)
348 -- No type yet, try to construct it
350 newty_either <- (construct_vhdl_ty ty)
353 -- TODO: Check name uniqueness
354 modA tsTypes (Map.insert htype newty)
356 Just (ty_id, ty_def) -> do
357 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
358 return (Right $ Just ty_id)
359 Nothing -> return $ Right Nothing
360 Left err -> return $ Left $
361 "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
363 -- Error when constructing htype
364 Left err -> return $ Left err
366 -- Construct a new VHDL type for the given Haskell type. Returns an error
367 -- message or the resulting typemark and typedef.
368 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
369 -- State types don't generate VHDL
370 construct_vhdl_ty ty | isStateType ty = return $ Right Nothing
371 construct_vhdl_ty ty = do
372 case Type.splitTyConApp_maybe ty of
373 Just (tycon, args) -> do
374 let name = Name.getOccString (TyCon.tyConName tycon)
376 "TFVec" -> mk_vector_ty ty
377 "SizedWord" -> mk_unsigned_ty ty
378 "SizedInt" -> mk_signed_ty ty
380 bound <- tfp_to_int (ranged_word_bound_ty ty)
381 mk_natural_ty 0 bound
382 -- Create a custom type from this tycon
383 otherwise -> mk_tycon_ty ty tycon args
384 Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
386 -- | Create VHDL type for a custom tycon
387 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
388 mk_tycon_ty ty tycon args =
389 case TyCon.tyConDataCons tycon of
390 -- Not an algebraic type
391 [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
393 let arg_tys = DataCon.dataConRepArgTys dc
394 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
395 -- violation? Or does it only mean not to apply it again to the same
397 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
398 elem_tys_either <- mapM vhdl_ty_either real_arg_tys
399 case Either.partitionEithers elem_tys_either of
400 -- No errors in element types
401 ([], elem_tys') -> do
402 -- Throw away all empty members
403 case Maybe.catMaybes elem_tys' of
404 [] -> -- No non-empty members
405 return $ Right Nothing
407 let elems = zipWith AST.ElementDec recordlabels elem_tys
408 -- For a single construct datatype, build a record with one field for
410 -- TODO: Add argument type ids to this, to ensure uniqueness
411 -- TODO: Special handling for tuples?
412 let elem_names = concat $ map prettyShow elem_tys
413 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
414 let ty_def = AST.TDR $ AST.RecordTypeDef elems
415 let tupshow = mkTupleShow elem_tys ty_id
416 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
417 return $ Right $ Just (ty_id, Left ty_def)
418 -- There were errors in element types
419 (errors, _) -> return $ Left $
420 "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
423 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
424 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
427 let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
428 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
429 let ty_def = AST.TDE $ AST.EnumTypeDef elems
430 let enumShow = mkEnumShow elems ty_id
431 modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow)
432 return $ Right $ Just (ty_id, Left ty_def)
433 xs -> return $ Left $
434 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
436 -- Create a subst that instantiates all types passed to the tycon
437 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
438 -- to work so far, though..
439 tyvars = TyCon.tyConTyVars tycon
440 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
441 -- Generate a bunch of labels for fields of a record
442 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
444 -- | Create a VHDL vector type
446 Type.Type -- ^ The Haskell type of the Vector
447 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
448 -- ^ An error message or The typemark created.
451 types_map <- getA tsTypes
453 let (nvec_l, nvec_el) = Type.splitAppTy ty
454 let (nvec, leng) = Type.splitAppTy nvec_l
455 let vec_ty = Type.mkAppTy nvec nvec_el
456 len <- tfp_to_int (tfvec_len_ty ty)
457 let el_ty = tfvec_elem ty
458 el_ty_tm_either <- vhdl_ty_either el_ty
459 case el_ty_tm_either of
460 -- Could create element type
461 Right (Just el_ty_tm) -> do
462 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
463 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
464 let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
465 case existing_elem_ty of
467 let ty_def = AST.SubtypeIn t (Just range)
468 return (Right $ Just (ty_id, Right ty_def))
470 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
471 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
472 modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
473 modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
474 let vecShowFuns = mkVectorShow el_ty_tm vec_id
475 mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
476 let ty_def = AST.SubtypeIn vec_id (Just range)
477 return (Right $ Just (ty_id, Right ty_def))
478 -- Empty element type? Empty vector type then. TODO: Does this make sense?
479 -- Probably needs changes in the builtin functions as well...
480 Right Nothing -> return $ Right Nothing
481 -- Could not create element type
482 Left err -> return $ Left $
483 "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
487 Int -- ^ The minimum bound (> 0)
488 -> Int -- ^ The maximum bound (> minimum bound)
489 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
490 -- ^ An error message or The typemark created.
491 mk_natural_ty min_bound max_bound = do
492 let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
493 let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
494 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
495 let ty_def = AST.SubtypeIn unsignedTM (Just range)
496 return (Right $ Just (ty_id, Right ty_def))
499 Type.Type -- ^ Haskell type of the unsigned integer
500 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
501 mk_unsigned_ty ty = do
502 size <- tfp_to_int (sized_word_len_ty ty)
503 let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
504 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
505 let ty_def = AST.SubtypeIn unsignedTM (Just range)
506 return (Right $ Just (ty_id, Right ty_def))
509 Type.Type -- ^ Haskell type of the signed integer
510 -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
512 size <- tfp_to_int (sized_int_len_ty ty)
513 let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
514 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
515 let ty_def = AST.SubtypeIn signedTM (Just range)
516 return (Right $ Just (ty_id, Right ty_def))
518 -- Finds the field labels for VHDL type generated for the given Core type,
519 -- which must result in a record type.
520 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
521 getFieldLabels ty = do
522 -- Ensure that the type is generated (but throw away it's VHDLId)
523 let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
525 -- Get the types map, lookup and unpack the VHDL TypeDef
526 types <- getA tsTypes
527 -- Assume the type for which we want labels is really translatable
528 Right htype <- mkHType ty
529 case Map.lookup htype types of
530 Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
531 Just Nothing -> return [] -- The type is empty
532 _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
534 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
535 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
536 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
538 mkHType :: Type.Type -> TypeSession (Either String HType)
540 -- FIXME: Do we really need to do this here again?
541 let builtin_ty = do -- See if this is a tycon and lookup its name
542 (tycon, args) <- Type.splitTyConApp_maybe ty
543 let name = Name.getOccString (TyCon.tyConName tycon)
544 Map.lookup name builtin_types
547 return $ Right $ BuiltinType $ prettyShow typ
549 case Type.splitTyConApp_maybe ty of
550 Just (tycon, args) -> do
551 let name = Name.getOccString (TyCon.tyConName tycon)
554 let el_ty = tfvec_elem ty
555 elem_htype_either <- mkHType el_ty
556 case elem_htype_either of
557 -- Could create element type
558 Right elem_htype -> do
559 len <- tfp_to_int (tfvec_len_ty ty)
560 return $ Right $ VecType len elem_htype
561 -- Could not create element type
562 Left err -> return $ Left $
563 "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
566 len <- tfp_to_int (sized_word_len_ty ty)
567 return $ Right $ SizedWType len
569 len <- tfp_to_int (sized_word_len_ty ty)
570 return $ Right $ SizedIType len
572 bound <- tfp_to_int (ranged_word_bound_ty ty)
573 return $ Right $ RangedWType bound
575 mkTyConHType tycon args
576 Nothing -> return $ Right $ StdType $ OrdType ty
578 -- FIXME: Do we really need to do this here again?
579 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
580 mkTyConHType tycon args =
581 case TyCon.tyConDataCons tycon of
582 -- Not an algebraic type
583 [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
585 let arg_tys = DataCon.dataConRepArgTys dc
586 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
587 elem_htys_either <- mapM mkHType real_arg_tys
588 case Either.partitionEithers elem_htys_either of
589 -- No errors in element types
590 ([], elem_htys) -> do
591 return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
592 -- There were errors in element types
593 (errors, _) -> return $ Left $
594 "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
597 let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
598 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
601 return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
602 xs -> return $ Left $
603 "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
605 tyvars = TyCon.tyConTyVars tycon
606 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
608 -- Is the given type representable at runtime?
609 isReprType :: Type.Type -> TypeSession Bool
611 ty_either <- vhdl_ty_either ty
612 return $ case ty_either of
617 tfp_to_int :: Type.Type -> TypeSession Int
619 hscenv <- getA tsHscEnv
620 let norm_ty = normalise_tfp_int hscenv ty
621 case Type.splitTyConApp_maybe norm_ty of
622 Just (tycon, args) -> do
623 let name = Name.getOccString (TyCon.tyConName tycon)
626 len <- tfp_to_int' ty
629 modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))
630 return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
631 Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
633 tfp_to_int' :: Type.Type -> TypeSession Int
635 lens <- getA tsTfpInts
636 hscenv <- getA tsHscEnv
637 let norm_ty = normalise_tfp_int hscenv ty
638 let existing_len = Map.lookup (OrdType norm_ty) lens
640 Just len -> return len
642 let new_len = eval_tfp_int hscenv ty
643 modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))
647 [AST.TypeMark] -- ^ type of each tuple element
648 -> AST.TypeMark -- ^ type of the tuple
650 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
652 tupPar = AST.unsafeVHDLBasicId "tup"
653 showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
654 showExpr = AST.ReturnSm (Just $
655 AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
657 showMiddle = if null elemTMs then
660 foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
661 map ((genExprFCall showId).
664 (AST.NSimple tupPar AST.:.:).
666 (take tupSize recordlabels)
667 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
668 tupSize = length elemTMs
674 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
676 enumPar = AST.unsafeVHDLBasicId "enum"
677 showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
678 showExpr = AST.ReturnSm (Just $
679 AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
682 AST.TypeMark -- ^ elemtype
683 -> AST.TypeMark -- ^ vectype
684 -> [(String,AST.SubProgBody)]
685 mkVectorShow elemTM vectorTM =
686 [ (headId, AST.SubProgBody headSpec [] [headExpr])
687 , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet])
688 , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
691 vecPar = AST.unsafeVHDLBasicId "vec"
692 resId = AST.unsafeVHDLBasicId "res"
693 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
695 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
696 (AST.NSimple vecPar) [AST.PrimLit "0"])))
697 vecSlice init last = AST.PrimName (AST.NSlice
700 (AST.ToRange init last)))
701 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
702 -- variable res : fsvec_x (0 to vec'length-2);
705 (AST.SubtypeIn vectorTM
706 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
707 [AST.ToRange (AST.PrimLit "0")
708 (AST.PrimName (AST.NAttribute $
709 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
710 (AST.PrimLit "2")) ]))
712 -- res AST.:= vec(1 to vec'length-1)
713 tailExpr = AST.NSimple resId AST.:= (vecSlice
715 (AST.PrimName (AST.NAttribute $
716 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
717 AST.:-: AST.PrimLit "1"))
718 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
719 showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
720 doShowId = AST.unsafeVHDLExtId "doshow"
721 doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
722 where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
725 -- when 0 => return "";
726 -- when 1 => return head(vec);
727 -- when others => return show(head(vec)) & ',' &
728 -- doshow (tail(vec));
731 AST.CaseSm (AST.PrimName (AST.NAttribute $
732 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
733 [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
734 [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
735 AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
736 [AST.ReturnSm (Just $
738 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
739 AST.CaseSmAlt [AST.Others]
740 [AST.ReturnSm (Just $
742 (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
743 AST.PrimLit "','" AST.:&:
744 genExprFCall doShowId
745 (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
746 -- return '<' & doshow(vec) & '>';
747 showRet = AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
748 genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
751 mkBuiltInShow :: [AST.SubProgBody]
752 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
753 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
754 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
755 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
756 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
759 bitPar = AST.unsafeVHDLBasicId "s"
760 boolPar = AST.unsafeVHDLBasicId "b"
761 signedPar = AST.unsafeVHDLBasicId "sint"
762 unsignedPar = AST.unsafeVHDLBasicId "uint"
763 -- naturalPar = AST.unsafeVHDLBasicId "nat"
764 showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
765 -- if s = '1' then return "'1'" else return "'0'"
766 showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
767 [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
769 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
770 showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
771 -- if b then return "True" else return "False"
772 showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
773 [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
775 (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
776 showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
777 showSignedExpr = AST.ReturnSm (Just $
778 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
779 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
781 signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
782 showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
783 showUnsignedExpr = AST.ReturnSm (Just $
784 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
785 (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
787 unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
788 -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
789 -- showNaturalExpr = AST.ReturnSm (Just $
790 -- AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
791 -- (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
794 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
795 genExprFCall fName args =
796 AST.PrimFCall $ AST.FCall (AST.NSimple fName) $
797 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
799 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
800 genExprPCall2 entid arg1 arg2 =
801 AST.ProcCall (AST.NSimple entid) $
802 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
804 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
806 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
807 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
808 case type_mark_maybe of
809 Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
810 Nothing -> return Nothing
812 -- | Does the given thing have a non-empty type?
813 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) =>
814 t -> TranslatorSession Bool
815 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)