clash/CLasH/VHDL.hs

   1 --
   2 -- Functions to generate VHDL from FlatFunctions
   3 --
   4 module CLasH.VHDL where
   5
   6 -- Standard modules
   7 import qualified Data.Map as Map
   8 import qualified Maybe
   9 import qualified Control.Arrow as Arrow
  10 import Data.Accessor
  11 import qualified Data.Accessor.Monad.Trans.State as MonadState
  12
  13 -- VHDL Imports
  14 import qualified Language.VHDL.AST as AST
  15
  16 -- GHC API
  17 import qualified CoreSyn
  18
  19 -- Local imports
  20 import CLasH.Translator.TranslatorTypes
  21 import CLasH.VHDL.VHDLTypes
  22 import CLasH.VHDL.VHDLTools
  23 import CLasH.VHDL.Constants
  24 import CLasH.VHDL.Generate
  25
  26 createDesignFiles ::
  27   [CoreSyn.CoreBndr] -- ^ Top binders
  28   -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
  29
  30 createDesignFiles topbndrs = do
  31   bndrss <- mapM recurseArchitectures topbndrs
  32   let bndrs = concat bndrss
  33   lunits <- mapM createLibraryUnit bndrs
  34   typepackage <- createTypesPackage
  35   let files = map (Arrow.second $ AST.DesignFile full_context) lunits
  36   return $ typepackage : files
  37   where
  38     full_context =
  39       mkUseAll ["work", "types"]
  40       : (mkUseAll ["work"]
  41       : ieee_context)
  42
  43 ieee_context = [
  44     AST.Library $ mkVHDLBasicId "IEEE",
  45     mkUseAll ["IEEE", "std_logic_1164"],
  46     mkUseAll ["IEEE", "numeric_std"],
  47     mkUseAll ["std", "textio"]
  48   ]
  49
  50 -- | Find out which entities are needed for the given top level binders.
  51 recurseArchitectures ::
  52   CoreSyn.CoreBndr -- ^ The top level binder
  53   -> TranslatorSession [CoreSyn.CoreBndr]
  54   -- ^ The binders of all needed functions.
  55 recurseArchitectures bndr = do
  56   -- See what this binder directly uses
  57   (_, used) <- getArchitecture bndr
  58   -- Recursively check what each of the used functions uses
  59   useds <- mapM recurseArchitectures used
  60   -- And return all of them
  61   return $ bndr : (concat useds)
  62
  63 -- | Creates the types package, based on the current type state.
  64 createTypesPackage ::
  65   TranslatorSession (AST.VHDLId, AST.DesignFile)
  66   -- ^ The id and content of the types package
  67
  68 createTypesPackage = do
  69   tyfuns <- MonadState.get (tsType .> tsTypeFuns)
  70   let tyfun_decls = mkBuiltInShow ++ map snd (Map.elems tyfuns)
  71   ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
  72   let ty_decls = Maybe.catMaybes ty_decls_maybes
  73   let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
  74   let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
  75   let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
  76   return (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
  77   where
  78     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
  79     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple highId) Nothing)
  80     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
  81
  82 -- Create a use foo.bar.all statement. Takes a list of components in the used
  83 -- name. Must contain at least two components
  84 mkUseAll :: [String] -> AST.ContextItem
  85 mkUseAll ss =
  86   AST.Use $ from AST.:.: AST.All
  87   where
  88     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
  89     from = foldl select base_prefix (tail ss)
  90     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
  91
  92 createLibraryUnit ::
  93   CoreSyn.CoreBndr
  94   -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
  95
  96 createLibraryUnit bndr = do
  97   entity <- getEntity bndr
  98   (arch, _) <- getArchitecture bndr
  99   return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])