cλash/CLasH/VHDL/VHDLTools.hs

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