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