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