2 -- Functions to generate VHDL from FlatFunctions
4 module CLasH.VHDL where
7 import qualified Data.Map as Map
9 import qualified Control.Monad as Monad
10 import qualified Control.Arrow as Arrow
11 import qualified Control.Monad.Trans.State as State
12 import qualified Data.Monoid as Monoid
14 import Data.Accessor.MonadState as MonadState
18 import qualified Language.VHDL.AST as AST
22 --import qualified Type
25 import qualified IdInfo
26 import qualified TyCon
27 import qualified DataCon
28 --import qualified CoreSubst
29 import qualified CoreUtils
30 import Outputable ( showSDoc, ppr )
33 import CLasH.Translator.TranslatorTypes
34 import CLasH.VHDL.VHDLTypes
35 import CLasH.VHDL.VHDLTools
36 import CLasH.Utils.Pretty
37 import CLasH.Utils.Core.CoreTools
38 import CLasH.VHDL.Constants
39 import CLasH.VHDL.Generate
40 import CLasH.VHDL.Testbench
43 [CoreSyn.CoreBndr] -- ^ Top binders
44 -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
46 createDesignFiles topbndrs = do
47 bndrss <- mapM recurseArchitectures topbndrs
48 let bndrs = concat bndrss
49 lunits <- mapM createLibraryUnit bndrs
50 typepackage <- createTypesPackage
51 let files = map (Arrow.second $ AST.DesignFile full_context) lunits
52 return $ typepackage : files
55 mkUseAll ["work", "types"]
60 AST.Library $ mkVHDLBasicId "IEEE",
61 mkUseAll ["IEEE", "std_logic_1164"],
62 mkUseAll ["IEEE", "numeric_std"],
63 mkUseAll ["std", "textio"]
66 -- | Find out which entities are needed for the given top level binders.
67 recurseArchitectures ::
68 CoreSyn.CoreBndr -- ^ The top level binder
69 -> TranslatorSession [CoreSyn.CoreBndr]
70 -- ^ The binders of all needed functions.
71 recurseArchitectures bndr = do
72 -- See what this binder directly uses
73 (_, used) <- getArchitecture bndr
74 -- Recursively check what each of the used functions uses
75 useds <- mapM recurseArchitectures used
76 -- And return all of them
77 return $ bndr : (concat useds)
79 -- | Creates the types package, based on the current type state.
81 TranslatorSession (AST.VHDLId, AST.DesignFile)
82 -- ^ The id and content of the types package
84 createTypesPackage = do
85 tyfuns <- getA (tsType .> tsTypeFuns)
86 let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns)
87 ty_decls <- getA (tsType .> tsTypeDecls)
88 let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
89 let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
90 let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
91 return $ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
93 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
94 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing)
95 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
97 -- Create a use foo.bar.all statement. Takes a list of components in the used
98 -- name. Must contain at least two components
99 mkUseAll :: [String] -> AST.ContextItem
101 AST.Use $ from AST.:.: AST.All
103 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
104 from = foldl select base_prefix (tail ss)
105 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
109 -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
111 createLibraryUnit bndr = do
112 entity <- getEntity bndr
113 (arch, _) <- getArchitecture bndr
114 return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])