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