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