716663025e9698753f3a3ce55be5c366f74fba7d
[matthijs/master-project/cλash.git] / VHDLTools.hs
1 {-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...
2 module CLasH.VHDL.VHDLTools where
3
4 -- Standard modules
5 import qualified Maybe
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 Data.Accessor.Monad.Trans.State as MonadState
12
13 -- VHDL Imports
14 import qualified Language.VHDL.AST as AST
15
16 -- GHC API
17 import qualified CoreSyn
18 import qualified Name
19 import qualified OccName
20 import qualified Var
21 import qualified Id
22 import qualified TyCon
23 import qualified Type
24 import qualified DataCon
25 import qualified CoreSubst
26 import qualified Outputable
27
28 -- Local imports
29 import CLasH.VHDL.VHDLTypes
30 import CLasH.Translator.TranslatorTypes
31 import CLasH.Utils.Core.CoreTools
32 import CLasH.Utils
33 import CLasH.Utils.Pretty
34 import CLasH.VHDL.Constants
35
36 -----------------------------------------------------------------------------
37 -- Functions to generate concurrent statements
38 -----------------------------------------------------------------------------
39
40 -- Create an unconditional assignment statement
41 mkUncondAssign ::
42   Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
43   -> AST.Expr -- ^ The expression to assign
44   -> AST.ConcSm -- ^ The resulting concurrent statement
45 mkUncondAssign dst expr = mkAssign dst Nothing expr
46
47 -- Create a conditional assignment statement
48 mkCondAssign ::
49   Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
50   -> AST.Expr -- ^ The condition
51   -> AST.Expr -- ^ The value when true
52   -> AST.Expr -- ^ The value when false
53   -> AST.ConcSm -- ^ The resulting concurrent statement
54 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
55
56 -- Create a conditional or unconditional assignment statement
57 mkAssign ::
58   Either CoreSyn.CoreBndr AST.VHDLName -- ^ The signal to assign to
59   -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
60                                  -- and the value to assign when true.
61   -> AST.Expr -- ^ The value to assign when false or no condition
62   -> AST.ConcSm -- ^ The resulting concurrent statement
63 mkAssign dst cond false_expr =
64   let
65     -- I'm not 100% how this assignment AST works, but this gets us what we
66     -- want...
67     whenelse = case cond of
68       Just (cond_expr, true_expr) -> 
69         let 
70           true_wform = AST.Wform [AST.WformElem true_expr Nothing]
71         in
72           [AST.WhenElse true_wform cond_expr]
73       Nothing -> []
74     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
75     dst_name  = case dst of
76       Left bndr -> AST.NSimple (varToVHDLId bndr)
77       Right name -> name
78     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
79   in
80     AST.CSSASm assign
81
82 mkAltsAssign ::
83   Either CoreSyn.CoreBndr AST.VHDLName            -- ^ The signal to assign to
84   -> [AST.Expr]       -- ^ The conditions
85   -> [AST.Expr]       -- ^ The expressions
86   -> AST.ConcSm   -- ^ The Alt assigns
87 mkAltsAssign dst conds exprs
88         | (length conds) /= ((length exprs) - 1) = error "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
89         | otherwise =
90   let
91     whenelses   = zipWith mkWhenElse conds exprs
92     false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
93     dst_name  = case dst of
94       Left bndr -> AST.NSimple (varToVHDLId bndr)
95       Right name -> name
96     assign    = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
97   in
98     AST.CSSASm assign
99   where
100     mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
101     mkWhenElse cond true_expr =
102       let
103         true_wform = AST.Wform [AST.WformElem true_expr Nothing]
104       in
105         AST.WhenElse true_wform cond
106
107 mkAssocElems :: 
108   [AST.Expr]                    -- ^ The argument that are applied to function
109   -> AST.VHDLName               -- ^ The binder in which to store the result
110   -> Entity                     -- ^ The entity to map against.
111   -> [AST.AssocElem]            -- ^ The resulting port maps
112 mkAssocElems args res entity =
113     arg_maps ++ (Maybe.maybeToList res_map_maybe)
114   where
115     arg_ports = ent_args entity
116     res_port_maybe = ent_res entity
117     -- Create an expression of res to map against the output port
118     res_expr = vhdlNameToVHDLExpr res
119     -- Map each of the input ports
120     arg_maps = zipWith mkAssocElem (map fst arg_ports) args
121     -- Map the output port, if present
122     res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe
123
124 -- | Create an VHDL port -> signal association
125 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
126 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
127
128 -- | Create an aggregate signal
129 mkAggregateSignal :: [AST.Expr] -> AST.Expr
130 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
131
132 mkComponentInst ::
133   String -- ^ The portmap label
134   -> AST.VHDLId -- ^ The entity name
135   -> [AST.AssocElem] -- ^ The port assignments
136   -> AST.ConcSm
137 mkComponentInst label entity_id portassigns = AST.CSISm compins
138   where
139     -- We always have a clock port, so no need to map it anywhere but here
140     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
141     resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
142     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))
143
144 -----------------------------------------------------------------------------
145 -- Functions to generate VHDL Exprs
146 -----------------------------------------------------------------------------
147
148 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
149 varToVHDLExpr var =
150   case Id.isDataConWorkId_maybe var of
151     -- This is a dataconstructor.
152     Just dc -> dataconToVHDLExpr dc
153     -- Not a datacon, just another signal.
154     Nothing -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
155
156 -- Turn a VHDLName into an AST expression
157 vhdlNameToVHDLExpr = AST.PrimName
158
159 -- Turn a VHDL Id into an AST expression
160 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
161
162 -- Turn a Core expression into an AST expression
163 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
164
165 -- Turn a alternative constructor into an AST expression. For
166 -- dataconstructors, this is only the constructor itself, not any arguments it
167 -- has. Should not be called with a DEFAULT constructor.
168 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
169 altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
170
171 altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
172 altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
173
174 -- Turn a datacon (without arguments!) into a VHDL expression.
175 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
176 dataconToVHDLExpr dc = do
177   typemap <- MonadState.get tsTypes
178   htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
179   case htype_either of
180     -- No errors
181     Right htype -> do
182       let dcname = DataCon.dataConName dc
183       case htype of
184         (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
185         (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
186         otherwise -> do
187           let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
188           case existing_ty of
189             Just ty -> do
190               let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
191               return lit
192             Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
193     -- Error when constructing htype
194     Left err -> error err
195
196 -----------------------------------------------------------------------------
197 -- Functions dealing with names, variables and ids
198 -----------------------------------------------------------------------------
199
200 -- Creates a VHDL Id from a binder
201 varToVHDLId ::
202   CoreSyn.CoreBndr
203   -> AST.VHDLId
204 varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
205   where
206     lowers :: String -> Int
207     lowers xs = length [x | x <- xs, Char.isLower x]
208
209 -- Creates a VHDL Name from a binder
210 varToVHDLName ::
211   CoreSyn.CoreBndr
212   -> AST.VHDLName
213 varToVHDLName = AST.NSimple . varToVHDLId
214
215 -- Extracts the binder name as a String
216 varToString ::
217   CoreSyn.CoreBndr
218   -> String
219 varToString = OccName.occNameString . Name.nameOccName . Var.varName
220
221 -- Get the string version a Var's unique
222 varToStringUniq :: Var.Var -> String
223 varToStringUniq = show . Var.varUnique
224
225 -- Extracts the string version of the name
226 nameToString :: Name.Name -> String
227 nameToString = OccName.occNameString . Name.nameOccName
228
229 -- Shortcut for Basic VHDL Ids.
230 -- Can only contain alphanumerics and underscores. The supplied string must be
231 -- a valid basic id, otherwise an error value is returned. This function is
232 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
233 -- that.
234 mkVHDLBasicId :: String -> AST.VHDLId
235 mkVHDLBasicId s = 
236   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
237   where
238     -- Strip invalid characters.
239     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
240     -- Strip leading numbers and underscores
241     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
242     -- Strip multiple adjacent underscores
243     strip_multiscore = concatMap (\cs -> 
244         case cs of 
245           ('_':_) -> "_"
246           _ -> cs
247       ) . List.group
248
249 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
250 -- different characters than basic ids, but can never be used to refer to
251 -- basic ids.
252 -- Use extended Ids for any values that are taken from the source file.
253 mkVHDLExtId :: String -> AST.VHDLId
254 mkVHDLExtId s = 
255   AST.unsafeVHDLExtId $ strip_invalid s
256   where 
257     -- Allowed characters, taken from ForSyde's mkVHDLExtId
258     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
259     strip_invalid = filter (`elem` allowed)
260
261 -- Create a record field selector that selects the given label from the record
262 -- stored in the given binder.
263 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
264 mkSelectedName name label =
265    AST.NSelected $ name AST.:.: (AST.SSimple label) 
266
267 -- Create an indexed name that selects a given element from a vector.
268 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
269 -- Special case for already indexed names. Just add an index
270 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
271  AST.NIndexed (AST.IndexedName name (indexes++[index]))
272 -- General case for other names
273 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
274
275 -----------------------------------------------------------------------------
276 -- Functions dealing with VHDL types
277 -----------------------------------------------------------------------------
278 builtin_types :: TypeMap
279 builtin_types = 
280   Map.fromList [
281     (BuiltinType "Bit", Just (std_logicTM, Nothing)),
282     (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
283   ]
284
285 -- Is the given type representable at runtime?
286 isReprType :: Type.Type -> TypeSession Bool
287 isReprType ty = do
288   ty_either <- mkHTypeEither ty
289   return $ case ty_either of
290     Left _ -> False
291     Right _ -> True
292
293 -- | Turn a Core type into a HType, returning an error using the given
294 -- error string if the type was not representable.
295 mkHType :: (TypedThing t, Outputable.Outputable t) => 
296   String -> t -> TypeSession HType
297 mkHType msg ty = do
298   htype_either <- mkHTypeEither ty
299   case htype_either of
300     Right htype -> return htype
301     Left err -> error $ msg ++ err  
302
303 -- | Turn a Core type into a HType. Returns either an error message if
304 -- the type was not representable, or the HType generated.
305 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => 
306   t -> TypeSession (Either String HType)
307 mkHTypeEither tything =
308   case getType tything of
309     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
310     Just ty -> mkHTypeEither' ty
311
312 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
313 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
314                   | isStateType ty = return $ Right StateType
315                   | otherwise =
316   case Type.splitTyConApp_maybe ty of
317     Just (tycon, args) -> do
318       typemap <- MonadState.get tsTypes
319       let name = Name.getOccString (TyCon.tyConName tycon)
320       let builtinTyMaybe = Map.lookup (BuiltinType name) typemap  
321       case builtinTyMaybe of
322         (Just x) -> return $ Right $ BuiltinType name
323         Nothing ->
324           case name of
325                 "TFVec" -> do
326                   let el_ty = tfvec_elem ty
327                   elem_htype_either <- mkHTypeEither el_ty
328                   case elem_htype_either of
329                     -- Could create element type
330                     Right elem_htype -> do
331                       len <- tfp_to_int (tfvec_len_ty ty)
332                       return $ Right $ VecType len elem_htype
333                     -- Could not create element type
334                     Left err -> return $ Left $ 
335                       "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
336                 "SizedWord" -> do
337                   len <- tfp_to_int (sized_word_len_ty ty)
338                   return $ Right $ SizedWType len
339                 "SizedInt" -> do
340                   len <- tfp_to_int (sized_word_len_ty ty)
341                   return $ Right $ SizedIType len
342                 "RangedWord" -> do
343                   bound <- tfp_to_int (ranged_word_bound_ty ty)
344                   return $ Right $ RangedWType bound
345                 otherwise ->
346                   mkTyConHType tycon args
347     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
348
349 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
350 mkTyConHType tycon args =
351   case TyCon.tyConDataCons tycon of
352     -- Not an algebraic type
353     [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
354     [dc] -> do
355       let arg_tys = DataCon.dataConRepArgTys dc
356       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
357       let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys
358       elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate
359       case Either.partitionEithers elem_htys_either of
360         ([], [elem_hty]) ->
361           return $ Right elem_hty
362         -- No errors in element types
363         ([], elem_htys) ->
364           return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys
365         -- There were errors in element types
366         (errors, _) -> return $ Left $
367           "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
368           ++ (concat errors)
369     dcs -> do
370       let arg_tys = concatMap DataCon.dataConRepArgTys dcs
371       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
372       case real_arg_tys of
373         [] ->
374           return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
375         xs -> return $ Left $
376           "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
377   where
378     tyvars = TyCon.tyConTyVars tycon
379     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
380
381 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
382 -- Returns an error value, using the given message, when no type could be
383 -- created. Returns Nothing when the type is valid, but empty.
384 vhdlTy :: (TypedThing t, Outputable.Outputable t) => 
385   String -> t -> TypeSession (Maybe AST.TypeMark)
386 vhdlTy msg ty = do
387   htype <- mkHType msg ty
388   vhdlTyMaybe htype
389
390 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
391 vhdlTyMaybe htype = do
392   typemap <- MonadState.get tsTypes
393   -- If not a builtin type, try the custom types
394   let existing_ty = Map.lookup htype typemap
395   case existing_ty of
396     -- Found a type, return it
397     Just (Just (t, _)) -> return $ Just t
398     Just (Nothing) -> return Nothing
399     -- No type yet, try to construct it
400     Nothing -> do
401       newty <- (construct_vhdl_ty htype)
402       MonadState.modify tsTypes (Map.insert htype newty)
403       case newty of
404         Just (ty_id, ty_def) -> do
405           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
406           return $ Just ty_id
407         Nothing -> return Nothing
408
409 -- Construct a new VHDL type for the given Haskell type. Returns an error
410 -- message or the resulting typemark and typedef.
411 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
412 -- State types don't generate VHDL
413 construct_vhdl_ty htype =
414     case htype of
415       StateType -> return  Nothing
416       (SizedWType w) -> mkUnsignedTy w
417       (SizedIType i) -> mkSignedTy i
418       (RangedWType u) -> mkNaturalTy 0 u
419       (VecType n e) -> mkVectorTy (VecType n e)
420       -- Create a custom type from this tycon
421       otherwise -> mkTyconTy htype
422
423 -- | Create VHDL type for a custom tycon
424 mkTyconTy :: HType -> TypeSession TypeMapRec
425 mkTyconTy htype =
426   case htype of
427     (AggrType tycon args) -> do
428       elemTysMaybe <- mapM vhdlTyMaybe args
429       case Maybe.catMaybes elemTysMaybe of
430         [] -> -- No non-empty members
431           return Nothing
432         elem_tys -> do
433           let elems = zipWith AST.ElementDec recordlabels elem_tys  
434           let elem_names = concatMap prettyShow elem_tys
435           let ty_id = mkVHDLExtId $ tycon ++ elem_names
436           let ty_def = AST.TDR $ AST.RecordTypeDef elems
437           let tupshow = mkTupleShow elem_tys ty_id
438           MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)
439           return $ Just (ty_id, Just $ Left ty_def)
440     (EnumType tycon dcs) -> do
441       let elems = map mkVHDLExtId dcs
442       let ty_id = mkVHDLExtId tycon
443       let ty_def = AST.TDE $ AST.EnumTypeDef elems
444       let enumShow = mkEnumShow elems ty_id
445       MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
446       return $ Just (ty_id, Just $ Left ty_def)
447     otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
448   where
449     -- Generate a bunch of labels for fields of a record
450     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
451
452 -- | Create a VHDL vector type
453 mkVectorTy ::
454   HType -- ^ The Haskell type of the Vector
455   -> TypeSession TypeMapRec
456       -- ^ An error message or The typemark created.
457
458 mkVectorTy (VecType len elHType) = do
459   typesMap <- MonadState.get tsTypes
460   elTyTmMaybe <- vhdlTyMaybe elHType
461   case elTyTmMaybe of
462     (Just elTyTm) -> do
463       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
464       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
465       let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
466       case existing_uvec_ty of
467         Just (Just t) -> do
468           let ty_def = AST.SubtypeIn t (Just range)
469           return (Just (ty_id, Just $ Right ty_def))
470         Nothing -> do
471           let vec_id  = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
472           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
473           MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
474           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
475           let vecShowFuns = mkVectorShow elTyTm vec_id
476           mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
477           let ty_def = AST.SubtypeIn vec_id (Just range)
478           return (Just (ty_id, Just $ Right ty_def))
479     -- Vector of empty elements becomes empty itself.
480     Nothing -> return Nothing
481 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
482
483 mkNaturalTy ::
484   Int -- ^ The minimum bound (> 0)
485   -> Int -- ^ The maximum bound (> minimum bound)
486   -> TypeSession TypeMapRec
487       -- ^ An error message or The typemark created.
488 mkNaturalTy min_bound max_bound = do
489   let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
490   let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
491   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
492   let ty_def = AST.SubtypeIn unsignedTM (Just range)
493   return (Just (ty_id, Just $ Right ty_def))
494
495 mkUnsignedTy ::
496   Int -- ^ Haskell type of the unsigned integer
497   -> TypeSession TypeMapRec
498 mkUnsignedTy size = do
499   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
500   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
501   let ty_def = AST.SubtypeIn unsignedTM (Just range)
502   return (Just (ty_id, Just $ Right ty_def))
503   
504 mkSignedTy ::
505   Int -- ^ Haskell type of the signed integer
506   -> TypeSession TypeMapRec
507 mkSignedTy size = do
508   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
509   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
510   let ty_def = AST.SubtypeIn signedTM (Just range)
511   return (Just (ty_id, Just $ Right ty_def))
512
513 -- Finds the field labels for VHDL type generated for the given Core type,
514 -- which must result in a record type.
515 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
516 getFieldLabels ty = do
517   -- Ensure that the type is generated (but throw away it's VHDLId)
518   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
519   vhdlTy error_msg ty
520   -- Get the types map, lookup and unpack the VHDL TypeDef
521   types <- MonadState.get tsTypes
522   -- Assume the type for which we want labels is really translatable
523   htype <- mkHType error_msg ty
524   case Map.lookup htype types of
525     Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype) 
526     Just Nothing -> return [] -- The type is empty
527     Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems
528     Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)
529     
530 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
531 mytydecl (_, Nothing) = Nothing
532 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
533 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
534
535 mkTupleShow :: 
536   [AST.TypeMark] -- ^ type of each tuple element
537   -> AST.TypeMark -- ^ type of the tuple
538   -> AST.SubProgBody
539 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
540   where
541     tupPar    = AST.unsafeVHDLBasicId "tup"
542     showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
543     showExpr  = AST.ReturnSm (Just $
544                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
545       where
546         showMiddle = if null elemTMs then
547             AST.PrimLit "''"
548           else
549             foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
550               map ((genExprFCall showId).
551                     AST.PrimName .
552                     AST.NSelected .
553                     (AST.NSimple tupPar AST.:.:).
554                     tupVHDLSuffix)
555                   (take tupSize recordlabels)
556     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
557     tupSize = length elemTMs
558
559 mkEnumShow ::
560   [AST.VHDLId]
561   -> AST.TypeMark
562   -> AST.SubProgBody
563 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
564   where
565     enumPar    = AST.unsafeVHDLBasicId "enum"
566     showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
567     showExpr  = AST.ReturnSm (Just $
568                   AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
569
570 mkVectorShow ::
571   AST.TypeMark -- ^ elemtype
572   -> AST.TypeMark -- ^ vectype
573   -> [(String,AST.SubProgBody)]
574 mkVectorShow elemTM vectorTM = 
575   [ (headId, AST.SubProgBody headSpec []                   [headExpr])
576   , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar]   [tailExpr, tailRet])
577   , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
578   ]
579   where
580     vecPar  = AST.unsafeVHDLBasicId "vec"
581     resId   = AST.unsafeVHDLBasicId "res"
582     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
583     -- return vec(0);
584     headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName 
585                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
586     vecSlice init last =  AST.PrimName (AST.NSlice 
587                                       (AST.SliceName 
588                                             (AST.NSimple vecPar) 
589                                             (AST.ToRange init last)))
590     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
591        -- variable res : fsvec_x (0 to vec'length-2); 
592     tailVar = 
593          AST.VarDec resId 
594                 (AST.SubtypeIn vectorTM
595                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
596                    [AST.ToRange (AST.PrimLit "0")
597                             (AST.PrimName (AST.NAttribute $ 
598                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
599                                 (AST.PrimLit "2"))   ]))
600                 Nothing       
601        -- res AST.:= vec(1 to vec'length-1)
602     tailExpr = AST.NSimple resId AST.:= (vecSlice 
603                                (AST.PrimLit "1") 
604                                (AST.PrimName (AST.NAttribute $ 
605                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
606                                                              AST.:-: AST.PrimLit "1"))
607     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
608     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
609     doShowId  = AST.unsafeVHDLExtId "doshow"
610     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
611       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] 
612                                            stringTM
613             -- case vec'len is
614             --  when  0 => return "";
615             --  when  1 => return head(vec);
616             --  when others => return show(head(vec)) & ',' &
617             --                        doshow (tail(vec));
618             -- end case;
619             doShowRet = 
620               AST.CaseSm (AST.PrimName (AST.NAttribute $ 
621                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
622               [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"] 
623                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
624                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"] 
625                          [AST.ReturnSm (Just $ 
626                           genExprFCall showId 
627                                (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
628                AST.CaseSmAlt [AST.Others] 
629                          [AST.ReturnSm (Just $ 
630                            genExprFCall showId 
631                              (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
632                            AST.PrimLit "','" AST.:&:
633                            genExprFCall doShowId 
634                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
635     -- return '<' & doshow(vec) & '>';
636     showRet =  AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
637                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
638                                AST.PrimLit "'>'" )
639
640 mkBuiltInShow :: [AST.SubProgBody]
641 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
642                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
643                 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
644                 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
645                 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
646                 ]
647   where
648     bitPar      = AST.unsafeVHDLBasicId "s"
649     boolPar     = AST.unsafeVHDLBasicId "b"
650     signedPar   = AST.unsafeVHDLBasicId "sint"
651     unsignedPar = AST.unsafeVHDLBasicId "uint"
652     -- naturalPar  = AST.unsafeVHDLBasicId "nat"
653     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
654     -- if s = '1' then return "'1'" else return "'0'"
655     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
656                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
657                         []
658                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
659     showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
660     -- if b then return "True" else return "False"
661     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
662                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
663                         []
664                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
665     showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
666     showSignedExpr =  AST.ReturnSm (Just $
667                         AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
668                         (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
669                       where
670                         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
671     showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
672     showUnsignedExpr =  AST.ReturnSm (Just $
673                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
674                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
675                         where
676                           unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
677     -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
678     -- showNaturalExpr = AST.ReturnSm (Just $
679     --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
680     --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
681                       
682   
683 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
684 genExprFCall fName args = 
685    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
686              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args] 
687
688 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm             
689 genExprPCall2 entid arg1 arg2 =
690         AST.ProcCall (AST.NSimple entid) $
691          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
692
693 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
694 mkSigDec bndr = do
695   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
696   type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
697   case type_mark_maybe of
698     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
699     Nothing -> return Nothing
700
701 -- | Does the given thing have a non-empty type?
702 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => 
703   t -> TranslatorSession Bool
704 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)