VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module VHDL where
   5
   6 -- Standard modules
   7 import qualified Data.Foldable as Foldable
   8 import qualified Data.List as List
   9 import qualified Data.Map as Map
  10 import qualified Maybe
  11 import qualified Control.Monad as Monad
  12 import qualified Control.Arrow as Arrow
  13 import qualified Control.Monad.Trans.State as State
  14 import qualified Data.Traversable as Traversable
  15 import qualified Data.Monoid as Monoid
  16 import Data.Accessor
  17 import qualified Data.Accessor.MonadState as MonadState
  18 import Text.Regex.Posix
  19
  20 -- ForSyDe
  21 import qualified ForSyDe.Backend.VHDL.AST as AST
  22
  23 -- GHC API
  24 import qualified Type
  25 import qualified Name
  26 import qualified TyCon
  27 import Outputable ( showSDoc, ppr )
  28
  29 -- Local imports
  30 import VHDLTypes
  31 import Flatten
  32 import FlattenTypes
  33 import TranslatorTypes
  34 import HsValueMap
  35 import Pretty
  36 import CoreTools
  37 import Constants
  38 import Generate
  39 import GlobalNameTable
  40
  41 createDesignFiles ::
  42   FlatFuncMap
  43   -> [(AST.VHDLId, AST.DesignFile)]
  44
  45 createDesignFiles flatfuncmap =
  46   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
  47   map (Arrow.second $ AST.DesignFile full_context) units
  48
  49   where
  50     init_session = VHDLSession Map.empty builtin_funcs
  51     (units, final_session) =
  52       State.runState (createLibraryUnits flatfuncmap) init_session
  53     ty_decls = Map.elems (final_session ^. vsTypes)
  54     ieee_context = [
  55         AST.Library $ mkVHDLBasicId "IEEE",
  56         mkUseAll ["IEEE", "std_logic_1164"],
  57         mkUseAll ["IEEE", "numeric_std"]
  58       ]
  59     full_context =
  60       mkUseAll ["work", "types"]
  61       : ieee_context
  62     type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
  63
  64 -- Create a use foo.bar.all statement. Takes a list of components in the used
  65 -- name. Must contain at least two components
  66 mkUseAll :: [String] -> AST.ContextItem
  67 mkUseAll ss =
  68   AST.Use $ from AST.:.: AST.All
  69   where
  70     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  71     from = foldl select base_prefix (tail ss)
  72     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  73
  74 createLibraryUnits ::
  75   FlatFuncMap
  76   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
  77
  78 createLibraryUnits flatfuncmap = do
  79   let hsfuncs = Map.keys flatfuncmap
  80   let flatfuncs = Map.elems flatfuncmap
  81   entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
  82   archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
  83   return $ zipWith
  84     (\ent arch ->
  85       let AST.EntityDec id _ = ent in
  86       (id, [AST.LUEntity ent, AST.LUArch arch])
  87     )
  88     entities archs
  89
  90 -- | Create an entity for a given function
  91 createEntity ::
  92   HsFunction -- | The function signature
  93   -> FlatFunction -- | The FlatFunction
  94   -> VHDLState AST.EntityDec -- | The resulting entity
  95
  96 createEntity hsfunc flatfunc = do
  97       let sigs    = flat_sigs flatfunc
  98       let args    = flat_args flatfunc
  99       let res     = flat_res  flatfunc
 100       args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
 101       res' <- Traversable.traverse (mkMap sigs) res
 102       let ent_decl' = createEntityAST hsfunc args' res'
 103       let AST.EntityDec entity_id _ = ent_decl'
 104       let signature = Entity entity_id args' res'
 105       modA vsSignatures (Map.insert hsfunc signature)
 106       return ent_decl'
 107   where
 108     mkMap ::
 109       [(SignalId, SignalInfo)]
 110       -> SignalId
 111       -> VHDLState VHDLSignalMapElement
 112     -- We only need the vsTypes element from the state
 113     mkMap sigmap = MonadState.lift vsTypes . (\id ->
 114       let
 115         info = Maybe.fromMaybe
 116           (error $ "Signal not found in the name map? This should not happen!")
 117           (lookup id sigmap)
 118         nm = Maybe.fromMaybe
 119           (error $ "Signal not named? This should not happen!")
 120           (sigName info)
 121         ty = sigTy info
 122       in
 123         if isPortSigUse $ sigUse info
 124           then do
 125             type_mark <- vhdl_ty ty
 126             return $ Just (mkVHDLExtId nm, type_mark)
 127           else
 128             return $ Nothing
 129        )
 130
 131   -- | Create the VHDL AST for an entity
 132 createEntityAST ::
 133   HsFunction            -- | The signature of the function we're working with
 134   -> [VHDLSignalMap]    -- | The entity's arguments
 135   -> VHDLSignalMap      -- | The entity's result
 136   -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
 137
 138 createEntityAST hsfunc args res =
 139   AST.EntityDec vhdl_id ports
 140   where
 141     vhdl_id = mkEntityId hsfunc
 142     ports = concatMap (mapToPorts AST.In) args
 143             ++ mapToPorts AST.Out res
 144             ++ clk_port
 145     mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
 146     mapToPorts mode m =
 147       Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
 148     -- Add a clk port if we have state
 149     clk_port = if hasState hsfunc
 150       then
 151         [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
 152       else
 153         []
 154
 155 -- | Create a port declaration
 156 mkIfaceSigDec ::
 157   AST.Mode                         -- | The mode for the port (In / Out)
 158   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
 159   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
 160
 161 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 162 mkIfaceSigDec _ Nothing = Nothing
 163
 164 -- | Generate a VHDL entity name for the given hsfunc
 165 mkEntityId hsfunc =
 166   -- TODO: This doesn't work for functions with multiple signatures!
 167   -- Use a Basic Id, since using extended id's for entities throws off
 168   -- precision and causes problems when generating filenames.
 169   mkVHDLBasicId $ hsFuncName hsfunc
 170
 171 -- | Create an architecture for a given function
 172 createArchitecture ::
 173   HsFunction -- ^ The function signature
 174   -> FlatFunction -- ^ The FlatFunction
 175   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 176
 177 createArchitecture hsfunc flatfunc = do
 178   signaturemap <- getA vsSignatures
 179   let signature = Maybe.fromMaybe
 180         (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
 181         (Map.lookup hsfunc signaturemap)
 182   let entity_id = ent_id signature
 183   -- Create signal declarations for all internal and state signals
 184   sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
 185   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 186   -- Create concurrent statements for all signal definitions
 187   statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
 188   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
 189   where
 190     sigs = flat_sigs flatfunc
 191     args = flat_args flatfunc
 192     res  = flat_res  flatfunc
 193     defs = flat_defs flatfunc
 194     procs = map mkStateProcSm (makeStatePairs flatfunc)
 195     procs' = map AST.CSPSm procs
 196     -- mkSigDec only uses vsTypes from the state
 197     mkSigDec' = MonadState.lift vsTypes . mkSigDec
 198
 199 -- | Looks up all pairs of old state, new state signals, together with
 200 --   the state id they represent.
 201 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 202 makeStatePairs flatfunc =
 203   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
 204     | old_info <- map snd (flat_sigs flatfunc)
 205     , new_info <- map snd (flat_sigs flatfunc)
 206         -- old_info must be an old state (and, because of the next equality,
 207         -- new_info must be a new state).
 208         , Maybe.isJust $ oldStateId $ sigUse old_info
 209         -- And the state numbers must match
 210     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
 211
 212     -- Replace the second tuple element with the corresponding SignalInfo
 213     --args_states = map (Arrow.second $ signalInfo sigs) args
 214 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 215 mkStateProcSm (num, old, new) =
 216   AST.ProcSm label [clk] [statement]
 217   where
 218     label       = mkVHDLExtId $ "state_" ++ (show num)
 219     clk         = mkVHDLExtId "clk"
 220     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 221     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
 222     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
 223     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 224     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 225
 226 mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
 227 mkSigDec info =
 228   let use = sigUse info in
 229   if isInternalSigUse use || isStateSigUse use then do
 230     type_mark <- vhdl_ty ty
 231     return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
 232   else
 233     return Nothing
 234   where
 235     ty = sigTy info
 236
 237 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 238 --   is not named.
 239 getSignalId :: SignalInfo -> AST.VHDLId
 240 getSignalId info =
 241     mkVHDLExtId $ Maybe.fromMaybe
 242       (error $ "Unnamed signal? This should not happen!")
 243       (sigName info)
 244
 245 -- | Transforms a signal definition into a VHDL concurrent statement
 246 mkConcSm ::
 247   [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
 248   -> SigDef                -- ^ The signal definition
 249   -> Int                   -- ^ A number that will be unique for all
 250                            --   concurrent statements in the architecture.
 251   -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
 252
 253 mkConcSm sigs (FApp hsfunc args res) num = do
 254   signatures <- getA vsSignatures
 255   let
 256       signature = Maybe.fromMaybe
 257           (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
 258           (Map.lookup hsfunc signatures)
 259       entity_id = ent_id signature
 260       label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
 261       -- Add a clk port if we have state
 262       clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 263       portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 264     in
 265       return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 266
 267 mkConcSm sigs (UncondDef src dst) _ = do
 268   src_expr <- vhdl_expr src
 269   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
 270   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 271   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
 272   return $ AST.CSSASm assign
 273   where
 274     vhdl_expr (Left id) = return $ mkIdExpr sigs id
 275     vhdl_expr (Right expr) =
 276       case expr of
 277         (EqLit id lit) ->
 278           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
 279         (Literal lit Nothing) ->
 280           return $ AST.PrimLit lit
 281         (Literal lit (Just ty)) -> do
 282           -- Create a cast expression, which is just a function call using the
 283           -- type name as the function name.
 284           let litexpr = AST.PrimLit lit
 285           ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
 286           let ty_name = AST.NSimple ty_id
 287           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
 288           return $ AST.PrimFCall $ AST.FCall ty_name args
 289         (Eq a b) ->
 290          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 291
 292 mkConcSm sigs (CondDef cond true false dst) _ =
 293   let
 294     cond_expr  = mkIdExpr sigs cond
 295     true_expr  = mkIdExpr sigs true
 296     false_expr  = mkIdExpr sigs false
 297     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
 298     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
 299     whenelse = AST.WhenElse true_wform cond_expr
 300     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
 301     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
 302   in
 303     return $ AST.CSSASm assign
 304
 305 -- | Turn a SignalId into a VHDL Expr
 306 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 307 mkIdExpr sigs id =
 308   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
 309   AST.PrimName src_name
 310
 311 mkAssocElems ::
 312   [(SignalId, SignalInfo)]      -- | The signals in the current architecture
 313   -> [SignalMap]                -- | The signals that are applied to function
 314   -> SignalMap                  -- | the signals in which to store the function result
 315   -> Entity                     -- | The entity to map against.
 316   -> [AST.AssocElem]            -- | The resulting port maps
 317
 318 mkAssocElems sigmap args res entity =
 319     -- Create the actual AssocElems
 320     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
 321   where
 322     -- Turn the ports and signals from a map into a flat list. This works,
 323     -- since the maps must have an identical form by definition. TODO: Check
 324     -- the similar form?
 325     arg_ports = concat (map Foldable.toList (ent_args entity))
 326     res_ports = Foldable.toList (ent_res entity)
 327     arg_sigs  = (concat (map Foldable.toList args))
 328     res_sigs  = Foldable.toList res
 329     -- Extract the id part from the (id, type) tuple
 330     ports     = (map (fmap fst) (arg_ports ++ res_ports))
 331     -- Translate signal numbers into names
 332     sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
 333
 334 -- | Look up a signal in the signal name map
 335 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 336 lookupSigName sigs sig = name
 337   where
 338     info = Maybe.fromMaybe
 339       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
 340       (lookup sig sigs)
 341     name = Maybe.fromMaybe
 342       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
 343       (sigName info)
 344
 345 -- | Create an VHDL port -> signal association
 346 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 347 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
 348 mkAssocElem Nothing _ = Nothing
 349
 350 -- | The VHDL Bit type
 351 bit_ty :: AST.TypeMark
 352 bit_ty = AST.unsafeVHDLBasicId "Bit"
 353
 354 -- | The VHDL Boolean type
 355 bool_ty :: AST.TypeMark
 356 bool_ty = AST.unsafeVHDLBasicId "Boolean"
 357
 358 -- | The VHDL std_logic
 359 std_logic_ty :: AST.TypeMark
 360 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 361
 362 -- Translate a Haskell type to a VHDL type
 363 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
 364 vhdl_ty ty = do
 365   typemap <- State.get
 366   let builtin_ty = do -- See if this is a tycon and lookup its name
 367         (tycon, args) <- Type.splitTyConApp_maybe ty
 368         let name = Name.getOccString (TyCon.tyConName tycon)
 369         Map.lookup name builtin_types
 370   -- If not a builtin type, try the custom types
 371   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
 372   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
 373     -- Found a type, return it
 374     Just t -> return t
 375     -- No type yet, try to construct it
 376     Nothing -> do
 377       let new_ty = do
 378             -- Use the Maybe Monad for failing when one of these fails
 379             (tycon, args) <- Type.splitTyConApp_maybe ty
 380             let name = Name.getOccString (TyCon.tyConName tycon)
 381             case name of
 382               "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
 383               "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
 384               otherwise -> Nothing
 385       -- Return new_ty when a new type was successfully created
 386       Maybe.fromMaybe
 387         (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
 388         new_ty
 389
 390 -- | Create a VHDL vector type
 391 mk_vector_ty ::
 392   Int -- ^ The length of the vector
 393   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 394   -> TypeState AST.TypeMark -- The typemark created.
 395
 396 mk_vector_ty len ty = do
 397   -- Assume there is a single type argument
 398   let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
 399   -- TODO: Use el_ty
 400   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
 401   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
 402   let ty_dec = AST.TypeDec ty_id ty_def
 403   -- TODO: Check name uniqueness
 404   State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
 405   return ty_id
 406
 407
 408 builtin_types =
 409   Map.fromList [
 410     ("Bit", std_logic_ty),
 411     ("Bool", bool_ty) -- TysWiredIn.boolTy
 412   ]
 413
 414 -- Shortcut for
 415 -- Can only contain alphanumerics and underscores. The supplied string must be
 416 -- a valid basic id, otherwise an error value is returned. This function is
 417 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 418 -- that.
 419 mkVHDLBasicId :: String -> AST.VHDLId
 420 mkVHDLBasicId s =
 421   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
 422   where
 423     -- Strip invalid characters.
 424     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
 425     -- Strip leading numbers and underscores
 426     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
 427     -- Strip multiple adjacent underscores
 428     strip_multiscore = concat . map (\cs ->
 429         case cs of
 430           ('_':_) -> "_"
 431           _ -> cs
 432       ) . List.group
 433
 434 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
 435 -- different characters than basic ids, but can never be used to refer to
 436 -- basic ids.
 437 -- Use extended Ids for any values that are taken from the source file.
 438 mkVHDLExtId :: String -> AST.VHDLId
 439 mkVHDLExtId s =
 440   AST.unsafeVHDLExtId $ strip_invalid s
 441   where
 442     -- Allowed characters, taken from ForSyde's mkVHDLExtId
 443     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
 444     strip_invalid = filter (`elem` allowed)
 445
 446 -- | A consise representation of a (set of) ports on a builtin function
 447 type PortMap = HsValueMap (String, AST.TypeMark)
 448 -- | A consise representation of a builtin function
 449 data BuiltIn = BuiltIn String [PortMap] PortMap
 450
 451 -- | Translate a list of concise representation of builtin functions to a
 452 --   SignatureMap
 453 mkBuiltins :: [BuiltIn] -> SignatureMap
 454 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
 455     (HsFunction name (map useAsPort args) (useAsPort res),
 456      Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
 457   )
 458
 459 builtin_hsfuncs = Map.keys builtin_funcs
 460 builtin_funcs = mkBuiltins
 461   [
 462     BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 463     BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 464     BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
 465     BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
 466   ]
 467
 468 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 469 --   a VHDLSignalMap
 470 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
 471 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))