cλash/CLasH/VHDL/VHDLTools.hs

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