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 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", std_logicTM),
 262     ("Bool", booleanTM), -- TysWiredIn.boolTy
 263     ("Dec", 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.
 269 vhdl_ty :: String -> Type.Type -> TypeSession 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 AST.TypeMark)
 279 vhdl_ty_either ty = do
 280   typemap <- getA vsTypes
 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 = (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_maybe <- (construct_vhdl_ty ty)
 297           case newty_maybe of
 298             Right (ty_id, ty_def) -> do
 299               -- TODO: Check name uniqueness
 300               modA vsTypes (Map.insert htype (ty_id, ty_def))
 301               modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
 302               return (Right ty_id)
 303             Left err -> return $ Left $
 304               "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
 305               ++ err
 306     -- Error when constructing htype
 307     Left err -> return $ Left err
 308
 309 -- Construct a new VHDL type for the given Haskell type. Returns an error
 310 -- message or the resulting typemark and typedef.
 311 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 312 construct_vhdl_ty ty = do
 313   case Type.splitTyConApp_maybe ty of
 314     Just (tycon, args) -> do
 315       let name = Name.getOccString (TyCon.tyConName tycon)
 316       case name of
 317         "TFVec" -> mk_vector_ty ty
 318         "SizedWord" -> mk_unsigned_ty ty
 319         "SizedInt"  -> mk_signed_ty ty
 320         "RangedWord" -> do
 321           bound <- tfp_to_int (ranged_word_bound_ty ty)
 322           mk_natural_ty 0 bound
 323         -- Create a custom type from this tycon
 324         otherwise -> mk_tycon_ty ty tycon args
 325     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
 326
 327 -- | Create VHDL type for a custom tycon
 328 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 329 mk_tycon_ty ty tycon args =
 330   case TyCon.tyConDataCons tycon of
 331     -- Not an algebraic type
 332     [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
 333     [dc] -> do
 334       let arg_tys = DataCon.dataConRepArgTys dc
 335       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
 336       -- violation? Or does it only mean not to apply it again to the same
 337       -- subject?
 338       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 339       elem_tys_either <- mapM vhdl_ty_either real_arg_tys
 340       case Either.partitionEithers elem_tys_either of
 341         -- No errors in element types
 342         ([], elem_tys) -> do
 343           let elems = zipWith AST.ElementDec recordlabels elem_tys
 344           -- For a single construct datatype, build a record with one field for
 345           -- each argument.
 346           -- TODO: Add argument type ids to this, to ensure uniqueness
 347           -- TODO: Special handling for tuples?
 348           let elem_names = concat $ map prettyShow elem_tys
 349           let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
 350           let ty_def = AST.TDR $ AST.RecordTypeDef elems
 351           let tupshow = mkTupleShow elem_tys ty_id
 352           modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
 353           return $ Right (ty_id, Left ty_def)
 354         -- There were errors in element types
 355         (errors, _) -> return $ Left $
 356           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 357           ++ (concat errors)
 358     dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
 359   where
 360     -- Create a subst that instantiates all types passed to the tycon
 361     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
 362     -- to work so far, though..
 363     tyvars = TyCon.tyConTyVars tycon
 364     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 365     -- Generate a bunch of labels for fields of a record
 366     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 367
 368 -- | Create a VHDL vector type
 369 mk_vector_ty ::
 370   Type.Type -- ^ The Haskell type of the Vector
 371   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 372       -- ^ An error message or The typemark created.
 373
 374 mk_vector_ty ty = do
 375   types_map <- getA vsTypes
 376   env <- getA vsHscEnv
 377   let (nvec_l, nvec_el) = Type.splitAppTy ty
 378   let (nvec, leng) = Type.splitAppTy nvec_l
 379   let vec_ty = Type.mkAppTy nvec nvec_el
 380   len <- tfp_to_int (tfvec_len_ty ty)
 381   let el_ty = tfvec_elem ty
 382   el_ty_tm_either <- vhdl_ty_either el_ty
 383   case el_ty_tm_either of
 384     -- Could create element type
 385     Right el_ty_tm -> do
 386       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
 387       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 388       let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
 389       case existing_elem_ty of
 390         Just t -> do
 391           let ty_def = AST.SubtypeIn t (Just range)
 392           return (Right (ty_id, Right ty_def))
 393         Nothing -> do
 394           let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
 395           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
 396           modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
 397           modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
 398           let vecShowFuns = mkVectorShow el_ty_tm vec_id
 399           mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
 400           let ty_def = AST.SubtypeIn vec_id (Just range)
 401           return (Right (ty_id, Right ty_def))
 402     -- Could not create element type
 403     Left err -> return $ Left $
 404       "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
 405       ++ err
 406
 407 mk_natural_ty ::
 408   Int -- ^ The minimum bound (> 0)
 409   -> Int -- ^ The maximum bound (> minimum bound)
 410   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 411       -- ^ An error message or The typemark created.
 412 mk_natural_ty min_bound max_bound = do
 413   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
 414   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
 415   let ty_def = AST.SubtypeIn naturalTM (Just range)
 416   return (Right (ty_id, Right ty_def))
 417
 418 mk_unsigned_ty ::
 419   Type.Type -- ^ Haskell type of the unsigned integer
 420   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 421 mk_unsigned_ty ty = do
 422   size <- tfp_to_int (sized_word_len_ty ty)
 423   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
 424   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
 425   let ty_def = AST.SubtypeIn unsignedTM (Just range)
 426   let unsignedshow = mkIntegerShow ty_id
 427   modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
 428   return (Right (ty_id, Right ty_def))
 429
 430 mk_signed_ty ::
 431   Type.Type -- ^ Haskell type of the signed integer
 432   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 433 mk_signed_ty ty = do
 434   size <- tfp_to_int (sized_int_len_ty ty)
 435   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
 436   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
 437   let ty_def = AST.SubtypeIn signedTM (Just range)
 438   let signedshow = mkIntegerShow ty_id
 439   modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
 440   return (Right (ty_id, Right ty_def))
 441
 442 -- Finds the field labels for VHDL type generated for the given Core type,
 443 -- which must result in a record type.
 444 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
 445 getFieldLabels ty = do
 446   -- Ensure that the type is generated (but throw away it's VHDLId)
 447   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated."
 448   vhdl_ty error_msg ty
 449   -- Get the types map, lookup and unpack the VHDL TypeDef
 450   types <- getA vsTypes
 451   -- Assume the type for which we want labels is really translatable
 452   Right htype <- mkHType ty
 453   case Map.lookup htype types of
 454     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
 455     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
 456
 457 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
 458 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
 459 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
 460
 461 mkHType :: Type.Type -> TypeSession (Either String HType)
 462 mkHType ty = do
 463   -- FIXME: Do we really need to do this here again?
 464   let builtin_ty = do -- See if this is a tycon and lookup its name
 465         (tycon, args) <- Type.splitTyConApp_maybe ty
 466         let name = Name.getOccString (TyCon.tyConName tycon)
 467         Map.lookup name builtin_types
 468   case builtin_ty of
 469     Just typ ->
 470       return $ Right $ BuiltinType $ prettyShow typ
 471     Nothing ->
 472       case Type.splitTyConApp_maybe ty of
 473         Just (tycon, args) -> do
 474           let name = Name.getOccString (TyCon.tyConName tycon)
 475           case name of
 476             "TFVec" -> do
 477               let el_ty = tfvec_elem ty
 478               elem_htype_either <- mkHType el_ty
 479               case elem_htype_either of
 480                 -- Could create element type
 481                 Right elem_htype -> do
 482                   len <- tfp_to_int (tfvec_len_ty ty)
 483                   return $ Right $ VecType len elem_htype
 484                 -- Could not create element type
 485                 Left err -> return $ Left $
 486                   "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
 487                   ++ err
 488             "SizedWord" -> do
 489               len <- tfp_to_int (sized_word_len_ty ty)
 490               return $ Right $ SizedWType len
 491             "SizedInt" -> do
 492               len <- tfp_to_int (sized_word_len_ty ty)
 493               return $ Right $ SizedIType len
 494             "RangedWord" -> do
 495               bound <- tfp_to_int (ranged_word_bound_ty ty)
 496               return $ Right $ RangedWType bound
 497             otherwise -> do
 498               mkTyConHType tycon args
 499         Nothing -> return $ Right $ StdType $ OrdType ty
 500
 501 -- FIXME: Do we really need to do this here again?
 502 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 503 mkTyConHType tycon args =
 504   case TyCon.tyConDataCons tycon of
 505     -- Not an algebraic type
 506     [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
 507     [dc] -> do
 508       let arg_tys = DataCon.dataConRepArgTys dc
 509       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
 510       elem_htys_either <- mapM mkHType real_arg_tys
 511       case Either.partitionEithers elem_htys_either of
 512         -- No errors in element types
 513         ([], elem_htys) -> do
 514           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
 515         -- There were errors in element types
 516         (errors, _) -> return $ Left $
 517           "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
 518           ++ (concat errors)
 519     dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
 520   where
 521     tyvars = TyCon.tyConTyVars tycon
 522     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
 523
 524 -- Is the given type representable at runtime?
 525 isReprType :: Type.Type -> TypeSession Bool
 526 isReprType ty = do
 527   ty_either <- vhdl_ty_either ty
 528   return $ case ty_either of
 529     Left _ -> False
 530     Right _ -> True
 531
 532
 533 tfp_to_int :: Type.Type -> TypeSession Int
 534 tfp_to_int ty = do
 535   hscenv <- getA vsHscEnv
 536   let norm_ty = normalise_tfp_int hscenv ty
 537   case Type.splitTyConApp_maybe norm_ty of
 538     Just (tycon, args) -> do
 539       let name = Name.getOccString (TyCon.tyConName tycon)
 540       case name of
 541         "Dec" -> do
 542           len <- tfp_to_int' ty
 543           return len
 544         otherwise -> do
 545           modA vsTfpInts (Map.insert (OrdType norm_ty) (-1))
 546           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
 547     Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
 548
 549 tfp_to_int' :: Type.Type -> TypeSession Int
 550 tfp_to_int' ty = do
 551   lens <- getA vsTfpInts
 552   hscenv <- getA vsHscEnv
 553   let norm_ty = normalise_tfp_int hscenv ty
 554   let existing_len = Map.lookup (OrdType norm_ty) lens
 555   case existing_len of
 556     Just len -> return len
 557     Nothing -> do
 558       let new_len = eval_tfp_int hscenv ty
 559       modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
 560       return new_len
 561
 562 mkTupleShow ::
 563   [AST.TypeMark] -- ^ type of each tuple element
 564   -> AST.TypeMark -- ^ type of the tuple
 565   -> AST.SubProgBody
 566 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
 567   where
 568     tupPar    = AST.unsafeVHDLBasicId "tup"
 569     showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
 570     showExpr  = AST.ReturnSm (Just $
 571                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
 572       where
 573         showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
 574           map ((genExprFCall showId).
 575                 AST.PrimName .
 576                 AST.NSelected .
 577                 (AST.NSimple tupPar AST.:.:).
 578                 tupVHDLSuffix)
 579               (take tupSize recordlabels)
 580     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 581     tupSize = length elemTMs
 582
 583 mkVectorShow ::
 584   AST.TypeMark -- ^ elemtype
 585   -> AST.TypeMark -- ^ vectype
 586   -> [(String,AST.SubProgBody)]
 587 mkVectorShow elemTM vectorTM =
 588   [ (headId, AST.SubProgBody headSpec []                   [headExpr])
 589   , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar]   [tailExpr, tailRet])
 590   , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
 591   ]
 592   where
 593     vecPar  = AST.unsafeVHDLBasicId "vec"
 594     resId   = AST.unsafeVHDLBasicId "res"
 595     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 596     -- return vec(0);
 597     headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 598                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
 599     vecSlice init last =  AST.PrimName (AST.NSlice
 600                                       (AST.SliceName
 601                                             (AST.NSimple vecPar)
 602                                             (AST.ToRange init last)))
 603     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 604        -- variable res : fsvec_x (0 to vec'length-2);
 605     tailVar =
 606          AST.VarDec resId
 607                 (AST.SubtypeIn vectorTM
 608                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 609                    [AST.ToRange (AST.PrimLit "0")
 610                             (AST.PrimName (AST.NAttribute $
 611                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 612                                 (AST.PrimLit "2"))   ]))
 613                 Nothing
 614        -- res AST.:= vec(1 to vec'length-1)
 615     tailExpr = AST.NSimple resId AST.:= (vecSlice
 616                                (AST.PrimLit "1")
 617                                (AST.PrimName (AST.NAttribute $
 618                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 619                                                              AST.:-: AST.PrimLit "1"))
 620     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 621     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
 622     doShowId  = AST.unsafeVHDLExtId "doshow"
 623     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
 624       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM]
 625                                            stringTM
 626             -- case vec'len is
 627             --  when  0 => return "";
 628             --  when  1 => return head(vec);
 629             --  when others => return show(head(vec)) & ',' &
 630             --                        doshow (tail(vec));
 631             -- end case;
 632             doShowRet =
 633               AST.CaseSm (AST.PrimName (AST.NAttribute $
 634                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
 635               [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"]
 636                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
 637                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"]
 638                          [AST.ReturnSm (Just $
 639                           genExprFCall showId
 640                                (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
 641                AST.CaseSmAlt [AST.Others]
 642                          [AST.ReturnSm (Just $
 643                            genExprFCall showId
 644                              (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
 645                            AST.PrimLit "','" AST.:&:
 646                            genExprFCall doShowId
 647                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
 648     -- return '<' & doshow(vec) & '>';
 649     showRet =  AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
 650                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
 651                                AST.PrimLit "'>'" )
 652
 653 mkIntegerShow ::
 654   AST.TypeMark -- ^ The specific signed
 655   -> AST.SubProgBody
 656 mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
 657   where
 658     signedPar = AST.unsafeVHDLBasicId "sint"
 659     showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
 660     showExpr = AST.ReturnSm (Just $
 661                 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
 662                   (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
 663       where
 664         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
 665
 666 mkBuiltInShow :: [AST.SubProgBody]
 667 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
 668                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
 669                 ]
 670   where
 671     bitPar    = AST.unsafeVHDLBasicId "s"
 672     boolPar    = AST.unsafeVHDLBasicId "b"
 673     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
 674     -- if s = '1' then return "'1'" else return "'0'"
 675     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
 676                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
 677                         []
 678                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
 679     showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
 680     -- if b then return "True" else return "False"
 681     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
 682                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
 683                         []
 684                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
 685
 686 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 687 genExprFCall fName args =
 688    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
 689              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args]
 690
 691 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm
 692 genExprPCall2 entid arg1 arg2 =
 693         AST.ProcCall (AST.NSimple entid) $
 694          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 695
 696 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
 697 mkSigDec bndr =
 698   if True then do --isInternalSigUse use || isStateSigUse use then do
 699     let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
 700     type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
 701     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
 702   else
 703     return Nothing