cλash/CLasH/VHDL/VHDLTools.hs

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