2 -- Functions to generate VHDL from FlatFunctions
4 module CLasH.VHDL where
7 import qualified Data.Map as Map
9 import qualified Control.Arrow as Arrow
11 import qualified Data.Accessor.Monad.Trans.State as MonadState
14 import qualified Language.VHDL.AST as AST
17 import qualified CoreSyn
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
27 [CoreSyn.CoreBndr] -- ^ Top binders
28 -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
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
39 mkUseAll ["work", "types"]
44 AST.Library $ mkVHDLBasicId "IEEE",
45 mkUseAll ["IEEE", "std_logic_1164"],
46 mkUseAll ["IEEE", "numeric_std"],
47 mkUseAll ["std", "textio"]
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)
63 -- | Creates the types package, based on the current type state.
65 TranslatorSession (AST.VHDLId, AST.DesignFile)
66 -- ^ The id and content of the types package
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])
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)
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
86 AST.Use $ from AST.:.: AST.All
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)
94 -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
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])