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