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