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