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