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