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