cλash/CLasH/VHDL/VHDLTools.hs

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