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.Monad.Trans.State 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 <- MonadState.get (tsType .> tsTypeFuns)
86 let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns)
87 ty_decls_maybes <- MonadState.get (tsType .> tsTypeDecls)
88 let ty_decls = Maybe.catMaybes ty_decls_maybes
89 let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
90 let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
91 let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
92 return $ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
94 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
95 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing)
96 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
98 -- Create a use foo.bar.all statement. Takes a list of components in the used
99 -- name. Must contain at least two components
100 mkUseAll :: [String] -> AST.ContextItem
102 AST.Use $ from AST.:.: AST.All
104 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
105 from = foldl select base_prefix (tail ss)
106 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
110 -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
112 createLibraryUnit bndr = do
113 entity <- getEntity bndr
114 (arch, _) <- getArchitecture bndr
115 return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])