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