f04c1dcfb01af46e6187f6e3cf390184b3a94122
[matthijs/master-project/cλash.git] / clash / 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 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 String into a VHDL expr containing an id
166 stringToVHDLExpr :: String -> AST.Expr
167 stringToVHDLExpr = idToVHDLExpr . mkVHDLExtId 
168
169
170 -- Turn a alternative constructor into an AST expression. For
171 -- dataconstructors, this is only the constructor itself, not any arguments it
172 -- has. Should not be called with a DEFAULT constructor.
173 altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
174 altconToVHDLExpr (CoreSyn.DataAlt dc) = dataconToVHDLExpr dc
175
176 altconToVHDLExpr (CoreSyn.LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
177 altconToVHDLExpr CoreSyn.DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
178
179 -- Turn a datacon (without arguments!) into a VHDL expression.
180 dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
181 dataconToVHDLExpr dc = do
182   typemap <- MonadState.get tsTypes
183   htype_either <- mkHTypeEither (DataCon.dataConRepType dc)
184   case htype_either of
185     -- No errors
186     Right htype -> do
187       let dcname = DataCon.dataConName dc
188       case htype of
189         (BuiltinType "Bit") -> return $ AST.PrimLit $ case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
190         (BuiltinType "Bool") -> return $ AST.PrimLit $ case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
191         otherwise -> do
192           let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap
193           case existing_ty of
194             Just ty -> do
195               let lit    = AST.PrimLit $ show $ getConstructorIndex htype $ Name.getOccString dcname
196               return lit
197             Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc
198     -- Error when constructing htype
199     Left err -> error err
200
201 -----------------------------------------------------------------------------
202 -- Functions dealing with names, variables and ids
203 -----------------------------------------------------------------------------
204
205 -- Creates a VHDL Id from a binder
206 varToVHDLId ::
207   CoreSyn.CoreBndr
208   -> AST.VHDLId
209 varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))
210   where
211     lowers :: String -> Int
212     lowers xs = length [x | x <- xs, Char.isLower x]
213
214 -- Creates a VHDL Name from a binder
215 varToVHDLName ::
216   CoreSyn.CoreBndr
217   -> AST.VHDLName
218 varToVHDLName = AST.NSimple . varToVHDLId
219
220 -- Extracts the binder name as a String
221 varToString ::
222   CoreSyn.CoreBndr
223   -> String
224 varToString = OccName.occNameString . Name.nameOccName . Var.varName
225
226 -- Get the string version a Var's unique
227 varToStringUniq :: Var.Var -> String
228 varToStringUniq = show . Var.varUnique
229
230 -- Extracts the string version of the name
231 nameToString :: Name.Name -> String
232 nameToString = OccName.occNameString . Name.nameOccName
233
234 -- Shortcut for Basic VHDL Ids.
235 -- Can only contain alphanumerics and underscores. The supplied string must be
236 -- a valid basic id, otherwise an error value is returned. This function is
237 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
238 -- that.
239 mkVHDLBasicId :: String -> AST.VHDLId
240 mkVHDLBasicId s = 
241   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
242   where
243     -- Strip invalid characters.
244     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
245     -- Strip leading numbers and underscores
246     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
247     -- Strip multiple adjacent underscores
248     strip_multiscore = concatMap (\cs -> 
249         case cs of 
250           ('_':_) -> "_"
251           _ -> cs
252       ) . List.group
253
254 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
255 -- different characters than basic ids, but can never be used to refer to
256 -- basic ids.
257 -- Use extended Ids for any values that are taken from the source file.
258 mkVHDLExtId :: String -> AST.VHDLId
259 mkVHDLExtId s =
260   (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s
261   where 
262     -- Allowed characters, taken from ForSyde's mkVHDLExtId
263     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"
264     strip_invalid = filter (`elem` allowed)
265     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
266     strip_multiscore = concatMap (\cs -> 
267         case cs of 
268           ('_':_) -> "_"
269           _ -> cs
270       ) . List.group
271
272 -- Create a record field selector that selects the given label from the record
273 -- stored in the given binder.
274 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
275 mkSelectedName name label =
276    AST.NSelected $ name AST.:.: (AST.SSimple label) 
277
278 -- Create an indexed name that selects a given element from a vector.
279 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
280 -- Special case for already indexed names. Just add an index
281 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
282  AST.NIndexed (AST.IndexedName name (indexes++[index]))
283 -- General case for other names
284 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
285
286 -----------------------------------------------------------------------------
287 -- Functions dealing with VHDL types
288 -----------------------------------------------------------------------------
289 builtin_types :: TypeMap
290 builtin_types = 
291   Map.fromList [
292     (BuiltinType "Bit", Just (std_logicTM, Nothing)),
293     (BuiltinType "Bool", Just (booleanTM, Nothing)) -- TysWiredIn.boolTy
294   ]
295
296 -- Is the given type representable at runtime?
297 isReprType :: Type.Type -> TypeSession Bool
298 isReprType ty = do
299   ty_either <- mkHTypeEither ty
300   return $ case ty_either of
301     Left _ -> False
302     Right _ -> True
303
304 -- | Turn a Core type into a HType, returning an error using the given
305 -- error string if the type was not representable.
306 mkHType :: (TypedThing t, Outputable.Outputable t) => 
307   String -> t -> TypeSession HType
308 mkHType msg ty = do
309   htype_either <- mkHTypeEither ty
310   case htype_either of
311     Right htype -> return htype
312     Left err -> error $ msg ++ err  
313
314 -- | Turn a Core type into a HType. Returns either an error message if
315 -- the type was not representable, or the HType generated.
316 mkHTypeEither :: (TypedThing t, Outputable.Outputable t) => 
317   t -> TypeSession (Either String HType)
318 mkHTypeEither tything =
319   case getType tything of
320     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither: Typed thing without a type: " ++ pprString tything
321     Just ty -> mkHTypeEither' ty
322
323 mkHTypeEither' :: Type.Type -> TypeSession (Either String HType)
324 mkHTypeEither' ty | ty_has_free_tyvars ty = return $ Left $ "\nVHDLTools.mkHTypeEither': Cannot create type: type has free type variables: " ++ pprString ty
325                   | isStateType ty = return $ Right StateType
326                   | otherwise =
327   case Type.splitTyConApp_maybe ty of
328     Just (tycon, args) -> do
329       typemap <- MonadState.get tsTypes
330       let name = Name.getOccString (TyCon.tyConName tycon)
331       let builtinTyMaybe = Map.lookup (BuiltinType name) typemap  
332       case builtinTyMaybe of
333         (Just x) -> return $ Right $ BuiltinType name
334         Nothing ->
335           case name of
336                 "Vector" -> do
337                   let el_ty = tfvec_elem ty
338                   elem_htype_either <- mkHTypeEither el_ty
339                   case elem_htype_either of
340                     -- Could create element type
341                     Right elem_htype -> do
342                       len <- tfp_to_int (tfvec_len_ty ty)
343                       return $ Right $ VecType len elem_htype
344                     -- Could not create element type
345                     Left err -> return $ Left $ 
346                       "\nVHDLTools.mkHTypeEither': Can not construct vectortype for elementtype: " ++ pprString el_ty ++ err
347                 "Unsigned" -> do
348                   len <- tfp_to_int (sized_word_len_ty ty)
349                   return $ Right $ SizedWType len
350                 "Signed" -> do
351                   len <- tfp_to_int (sized_word_len_ty ty)
352                   return $ Right $ SizedIType len
353                 "Index" -> do
354                   bound <- tfp_to_int (ranged_word_bound_ty ty)
355                   -- Upperbound is exclusive, hence the -1
356                   return $ Right $ RangedWType (bound - 1)
357                 otherwise ->
358                   mkTyConHType tycon args
359     Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty
360
361 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
362 mkTyConHType tycon args =
363   case TyCon.tyConDataCons tycon of
364     -- Not an algebraic type
365     [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon
366     dcs -> do
367       let arg_tyss = map DataCon.dataConRepArgTys dcs
368       let enum_ty = EnumType name (map (nameToString . DataCon.dataConName) dcs)
369       case (concat arg_tyss) of
370         -- No arguments, this is just an enumeration type
371         [] -> return (Right enum_ty)
372         -- At least one argument, this becomes an aggregate type
373         _ -> do
374           -- Resolve any type arguments to this type
375           let real_arg_tyss = map (map (CoreSubst.substTy subst)) arg_tyss
376           -- Remove any state type fields
377           let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss
378           elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate
379           let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either)
380           case (all null errors) of
381             True -> case (dcs, concat elem_htyss) of
382                 -- A single constructor with a single (non-state) field?
383                 ([dc], [elem_hty]) -> return $ Right elem_hty
384                 -- If we get here, then all of the argument types were state
385                 -- types (we check for enumeration types at the top). Not
386                 -- sure how to handle this, so error out for now.
387                 (_, []) -> error $ "ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args
388                 -- A full ADT (with multiple fields and one or multiple
389                 -- constructors).
390                 (_, elem_htys) -> do
391                   let (_, fieldss) = List.mapAccumL (List.mapAccumL label_field) labels elem_htyss
392                   -- Only put in an enumeration as part of the aggregation
393                   -- when there are multiple datacons
394                   let enum_ty_part = case dcs of
395                                       [dc] -> Nothing
396                                       _ -> Just ("constructor", enum_ty)
397                   -- Create the AggrType HType
398                   return $ Right $ AggrType name enum_ty_part fieldss
399                 -- There were errors in element types
400             False -> return $ Left $
401               "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" 
402               ++ (concat $ concat errors)
403   where
404     name = (nameToString (TyCon.tyConName tycon))
405     tyvars = TyCon.tyConTyVars tycon
406     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
407     -- Label a field by taking the first available label and returning
408     -- the rest.
409     label_field :: [String] -> HType -> ([String], (String, HType))
410     label_field (l:ls) htype = (ls, (l, htype))
411     labels = map (:[]) ['A'..'Z']
412
413 vhdlTy :: (TypedThing t, Outputable.Outputable t) => 
414   String -> t -> TypeSession (Maybe AST.TypeMark)
415 vhdlTy msg ty = do
416   htype <- mkHType msg ty
417   vhdlTyMaybe htype
418
419 -- | Translate a Haskell type to a VHDL type, generating a new type if needed.
420 -- Returns an error value, using the given message, when no type could be
421 -- created. Returns Nothing when the type is valid, but empty.
422 vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark)
423 vhdlTyMaybe htype = do
424   typemap <- MonadState.get tsTypes
425   -- If not a builtin type, try the custom types
426   let existing_ty = Map.lookup htype typemap
427   case existing_ty of
428     -- Found a type, return it
429     Just (Just (t, _)) -> return $ Just t
430     Just (Nothing) -> return Nothing
431     -- No type yet, try to construct it
432     Nothing -> do
433       newty <- (construct_vhdl_ty htype)
434       MonadState.modify tsTypes (Map.insert htype newty)
435       case newty of
436         Just (ty_id, ty_def) -> do
437           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
438           return $ Just ty_id
439         Nothing -> return Nothing
440
441 -- Construct a new VHDL type for the given Haskell type. Returns an error
442 -- message or the resulting typemark and typedef.
443 construct_vhdl_ty :: HType -> TypeSession TypeMapRec
444 -- State types don't generate VHDL
445 construct_vhdl_ty htype =
446     case htype of
447       StateType -> return  Nothing
448       (SizedWType w) -> mkUnsignedTy w
449       (SizedIType i) -> mkSignedTy i
450       (RangedWType u) -> mkNaturalTy 0 u
451       (VecType n e) -> mkVectorTy (VecType n e)
452       -- Create a custom type from this tycon
453       otherwise -> mkTyconTy htype
454
455 -- | Create VHDL type for a custom tycon
456 mkTyconTy :: HType -> TypeSession TypeMapRec
457 mkTyconTy htype =
458   case htype of
459     (AggrType name enum_field_maybe fieldss) -> do
460       let (labelss, elem_htypess) = unzip (map unzip fieldss)
461       elemTyMaybess <- mapM (mapM vhdlTyMaybe) elem_htypess
462       let elem_tyss = map Maybe.catMaybes elemTyMaybess
463       case concat elem_tyss of
464         [] -> -- No non-empty fields
465           return Nothing
466         _ -> do
467           let reclabelss = map (map mkVHDLBasicId) labelss
468           let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss
469           let elem_names = concatMap (concatMap prettyShow) elem_tyss
470           let ty_id = mkVHDLExtId $ name ++ elem_names
471           -- Find out if we need to add an extra field at the start of
472           -- the record type containing the constructor (only needed
473           -- when there's more than one constructor).
474           enum_ty_maybe <- case enum_field_maybe of
475             Nothing -> return Nothing
476             Just (_, enum_htype) -> do
477               enum_ty_maybe' <- vhdlTyMaybe enum_htype
478               case enum_ty_maybe' of
479                 Nothing -> error $ "Couldn't translate enumeration type part of AggrType: " ++ show htype
480                 -- Note that the first Just means the type is
481                 -- translateable, while the second Just means that there
482                 -- is a enum_ty at all (e.g., there's multiple
483                 -- constructors).
484                 Just enum_ty -> return $ Just enum_ty
485           -- Create an record field declaration for the first
486           -- constructor field, if needed.
487           enum_dec_maybe <- case enum_field_maybe of
488             Nothing -> return $ Nothing
489             Just (enum_name, enum_htype) -> do
490               enum_vhdl_ty_maybe <- vhdlTyMaybe  enum_htype
491               let enum_vhdl_ty = Maybe.fromMaybe (error $ "\nVHDLTools.mkTyconTy: Enumeration field should not have empty type: " ++ show enum_htype) enum_vhdl_ty_maybe
492               return $ Just $ AST.ElementDec (mkVHDLBasicId enum_name) enum_vhdl_ty
493           -- Turn the maybe into a list, so we can prepend it.
494           let enum_decs = Maybe.maybeToList enum_dec_maybe
495           let enum_tys = Maybe.maybeToList enum_ty_maybe
496           let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)
497           let aggrshow = case enum_field_maybe of 
498                           Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id
499                           Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id
500           MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow)
501           return $ Just (ty_id, Just $ Left ty_def)
502     (EnumType tycon dcs) -> do
503       let ty_id = mkVHDLExtId tycon
504       let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))
505       let ty_def = AST.TDI $ AST.IntegerTypeDef range
506       let enumShow = mkEnumShow dcs ty_id
507       MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow)
508       return $ Just (ty_id, Just $ Left ty_def)
509     otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype
510
511 -- | Create a VHDL vector type
512 mkVectorTy ::
513   HType -- ^ The Haskell type of the Vector
514   -> TypeSession TypeMapRec
515       -- ^ An error message or The typemark created.
516
517 mkVectorTy (VecType len elHType) = do
518   typesMap <- MonadState.get tsTypes
519   elTyTmMaybe <- vhdlTyMaybe elHType
520   case elTyTmMaybe of
521     (Just elTyTm) -> do
522       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId elTyTm) ++ "-0_to_" ++ (show len)
523       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
524       let existing_uvec_ty = fmap (fmap fst) $ Map.lookup (UVecType elHType) typesMap
525       case existing_uvec_ty of
526         Just (Just t) -> do
527           let ty_def = AST.SubtypeIn t (Just range)
528           return (Just (ty_id, Just $ Right ty_def))
529         Nothing -> do
530           let vec_id  = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elTyTm)
531           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] elTyTm
532           MonadState.modify tsTypes (Map.insert (UVecType elHType) (Just (vec_id, (Just $ Left vec_def))))
533           MonadState.modify tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Just $ Left vec_def))])
534           let vecShowFuns = mkVectorShow elTyTm vec_id
535           mapM_ (\(id, subprog) -> MonadState.modify tsTypeFuns $ Map.insert (UVecType elHType, id) ((mkVHDLExtId id), subprog)) vecShowFuns
536           let ty_def = AST.SubtypeIn vec_id (Just range)
537           return (Just (ty_id, Just $ Right ty_def))
538     -- Vector of empty elements becomes empty itself.
539     Nothing -> return Nothing
540 mkVectorTy htype = error $ "\nVHDLTools.mkVectorTy: Called for HType that is not a VecType: " ++ show htype
541
542 mkNaturalTy ::
543   Int -- ^ The minimum bound (> 0)
544   -> Int -- ^ The maximum bound (> minimum bound)
545   -> TypeSession TypeMapRec
546       -- ^ An error message or The typemark created.
547 mkNaturalTy min_bound max_bound = do
548   let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
549   let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
550   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)]
551   let ty_def = AST.SubtypeIn unsignedTM (Just range)
552   return (Just (ty_id, Just $ Right ty_def))
553
554 mkUnsignedTy ::
555   Int -- ^ Haskell type of the unsigned integer
556   -> TypeSession TypeMapRec
557 mkUnsignedTy size = do
558   let ty_id = mkVHDLExtId $ "unsigned_" ++ show size
559   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
560   let ty_def = AST.SubtypeIn unsignedTM (Just range)
561   return (Just (ty_id, Just $ Right ty_def))
562   
563 mkSignedTy ::
564   Int -- ^ Haskell type of the signed integer
565   -> TypeSession TypeMapRec
566 mkSignedTy size = do
567   let ty_id = mkVHDLExtId $ "signed_" ++ show size
568   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")]
569   let ty_def = AST.SubtypeIn signedTM (Just range)
570   return (Just (ty_id, Just $ Right ty_def))
571
572 -- Finds the field labels and types for aggregation HType. Returns an
573 -- error on other types.
574 getFields ::
575   HType                -- ^ The HType to get fields for
576   -> Int               -- ^ The constructor to get fields for (e.g., 0
577                        --   for the first constructor, etc.)
578   -> [(String, HType)] -- ^ A list of fields, with their name and type
579 getFields htype dc_i = case htype of
580   (AggrType name _ fieldss) 
581     | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i
582     | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)
583   _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype
584
585 -- Finds the field labels for an aggregation type, as VHDLIds.
586 getFieldLabels ::
587   HType                -- ^ The HType to get field labels for
588   -> Int               -- ^ The constructor to get fields for (e.g., 0
589                        --   for the first constructor, etc.)
590   -> [AST.VHDLId]      -- ^ The labels
591 getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i)
592
593 -- Finds the field label for the constructor field, if any.
594 getConstructorFieldLabel ::
595   HType
596   -> Maybe AST.VHDLId
597 getConstructorFieldLabel (AggrType _ (Just con) _) =
598         Just $ mkVHDLBasicId (fst con)
599 getConstructorFieldLabel (AggrType _ Nothing _) =
600         Nothing
601 getConstructorFieldLabel htype =
602         error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype
603
604
605 getConstructorIndex ::
606   HType ->
607   String ->
608   Int
609 getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of
610   Just (index) -> index
611   Nothing -> error $ "VHDLTools.getConstructor: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons
612 getConstructorIndex htype _ = error $ "Can't get constructor index for non-Enum type: " ++ show htype
613
614
615 mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem
616 mytydecl (_, Nothing) = Nothing
617 mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def
618 mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def
619
620 mkTupleShow :: 
621   [AST.TypeMark] -- ^ type of each tuple element
622   -> AST.TypeMark -- ^ type of the tuple
623   -> AST.SubProgBody
624 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
625   where
626     tupPar    = AST.unsafeVHDLBasicId "tup"
627     parenPar  = AST.unsafeVHDLBasicId "paren"
628     showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM, AST.IfaceVarDec parenPar booleanTM] stringTM
629     showExpr  = AST.ReturnSm (Just $
630                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
631       where
632         showMiddle = if null elemTMs then
633             AST.PrimLit "''"
634           else
635             foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
636               map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false")))
637                   (take tupSize recordlabels)
638     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
639     tupSize = length elemTMs
640     selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
641
642 mkAdtShow ::
643   String
644   -> [String] -- Constructors
645   -> [[String]] -- Fields for every constructor
646   -> AST.TypeMark
647   -> AST.SubProgBody
648 mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]
649   where  
650     adtPar   = AST.unsafeVHDLBasicId "adt"
651     parenPar = AST.unsafeVHDLBasicId "paren"
652     showSpec  = AST.Function showId [AST.IfaceVarDec adtPar adtTM, AST.IfaceVarDec parenPar booleanTM] stringTM
653     showExpr  = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))
654                   [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] (
655                     if (null (elemIdss!!x)) then
656                         [AST.ReturnSm (Just $ ((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
657                       else
658                         [addParens (((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]
659                     ) | x <- [0..(length conIds) -1]]
660     showFields i = if (null (elemIdss!!i)) then
661         AST.PrimLit "\"\""
662       else
663         foldr1 (\e1 e2 -> e1 AST.:&: e2) $
664               map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "true")))
665                   (map mkVHDLBasicId (elemIdss!!i))
666     selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)
667     addParens :: AST.Expr -> AST.SeqSm
668     addParens k = AST.IfSm (AST.PrimName (AST.NSimple parenPar))
669                     [AST.ReturnSm (Just (AST.PrimLit "'('" AST.:&: k AST.:&: AST.PrimLit "')'" ))]
670                     []
671                     (Just $ AST.Else [AST.ReturnSm (Just k)])
672     
673 mkEnumShow ::
674   [String]
675   -> AST.TypeMark
676   -> AST.SubProgBody
677 mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
678   where  
679     enumPar   = AST.unsafeVHDLBasicId "enum"
680     parenPar  = AST.unsafeVHDLBasicId "paren"
681     showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM, AST.IfaceVarDec parenPar booleanTM] stringTM
682     showExpr  = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)
683                   [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]
684             
685
686 mkVectorShow ::
687   AST.TypeMark -- ^ elemtype
688   -> AST.TypeMark -- ^ vectype
689   -> [(String,AST.SubProgBody)]
690 mkVectorShow elemTM vectorTM = 
691   [ (headId, AST.SubProgBody headSpec []                   [headExpr])
692   , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar]   [tailExpr, tailRet])
693   , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
694   ]
695   where
696     vecPar  = AST.unsafeVHDLBasicId "vec"
697     resId   = AST.unsafeVHDLBasicId "res"
698     parenPar = AST.unsafeVHDLBasicId "paren"
699     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
700     -- return vec(0);
701     headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName 
702                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
703     vecSlice init last =  AST.PrimName (AST.NSlice 
704                                       (AST.SliceName 
705                                             (AST.NSimple vecPar) 
706                                             (AST.ToRange init last)))
707     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
708        -- variable res : fsvec_x (0 to vec'length-2); 
709     tailVar = 
710          AST.VarDec resId 
711                 (AST.SubtypeIn vectorTM
712                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
713                    [AST.ToRange (AST.PrimLit "0")
714                             (AST.PrimName (AST.NAttribute $ 
715                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
716                                 (AST.PrimLit "2"))   ]))
717                 Nothing       
718        -- res AST.:= vec(1 to vec'length-1)
719     tailExpr = AST.NSimple resId AST.:= (vecSlice 
720                                (AST.PrimLit "1") 
721                                (AST.PrimName (AST.NAttribute $ 
722                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
723                                                              AST.:-: AST.PrimLit "1"))
724     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
725     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM
726     doShowId  = AST.unsafeVHDLExtId "doshow"
727     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
728       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] 
729                                            stringTM
730             -- case vec'len is
731             --  when  0 => return "";
732             --  when  1 => return head(vec);
733             --  when others => return show(head(vec)) & ',' &
734             --                        doshow (tail(vec));
735             -- end case;
736             doShowRet = 
737               AST.CaseSm (AST.PrimName (AST.NAttribute $ 
738                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
739               [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"] 
740                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
741                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"] 
742                          [AST.ReturnSm (Just $ 
743                           genExprFCall2 showId 
744                                (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar),AST.PrimLit "false") )],
745                AST.CaseSmAlt [AST.Others] 
746                          [AST.ReturnSm (Just $ 
747                            genExprFCall2 showId 
748                              (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar), AST.PrimLit "false") AST.:&:
749                            AST.PrimLit "','" AST.:&:
750                            genExprFCall doShowId 
751                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
752     -- return '<' & doshow(vec) & '>';
753     showRet =  AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
754                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
755                                AST.PrimLit "'>'" )
756
757 mkBuiltInShow :: [AST.SubProgBody]
758 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
759                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
760                 , AST.SubProgBody showSingedSpec [] [showSignedExpr]
761                 , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
762                 -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]
763                 ]
764   where
765     bitPar      = AST.unsafeVHDLBasicId "s"
766     boolPar     = AST.unsafeVHDLBasicId "b"
767     signedPar   = AST.unsafeVHDLBasicId "sint"
768     unsignedPar = AST.unsafeVHDLBasicId "uint"
769     parenPar    = AST.unsafeVHDLBasicId "paren"
770     -- naturalPar  = AST.unsafeVHDLBasicId "nat"
771     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM, AST.IfaceVarDec parenPar booleanTM] stringTM
772     -- if s = '1' then return "'1'" else return "'0'"
773     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
774                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
775                         []
776                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
777     showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM, AST.IfaceVarDec parenPar booleanTM] stringTM
778     -- if b then return "True" else return "False"
779     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
780                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
781                         []
782                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
783     showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
784     showSignedExpr =  AST.ReturnSm (Just $
785                         AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
786                         (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
787                       where
788                         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)
789     showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM, AST.IfaceVarDec parenPar booleanTM] stringTM
790     showUnsignedExpr =  AST.ReturnSm (Just $
791                           AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
792                           (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
793                         where
794                           unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple unsignedPar)
795     -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
796     -- showNaturalExpr = AST.ReturnSm (Just $
797     --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
798     --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
799                       
800   
801 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
802 genExprFCall fName args = 
803    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
804              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args] 
805
806 genExprFCall2 :: AST.VHDLId -> (AST.Expr, AST.Expr) -> AST.Expr
807 genExprFCall2 fName (arg1, arg2) = 
808    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
809              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] 
810
811 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm             
812 genExprPCall2 entid arg1 arg2 =
813         AST.ProcCall (AST.NSimple entid) $
814          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
815
816 mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
817 mkSigDec bndr = do
818   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
819   type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType bndr)
820   case type_mark_maybe of
821     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
822     Nothing -> return Nothing
823
824 -- | Does the given thing have a non-empty type?
825 hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => 
826   t -> TranslatorSession Bool
827 hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)