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