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