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])
117 -- | Looks up all pairs of old state, new state signals, together with
118 -- the state id they represent.
119 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
120 makeStatePairs flatfunc =
121 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
122 | old_info <- map snd (flat_sigs flatfunc)
123 , new_info <- map snd (flat_sigs flatfunc)
124 -- old_info must be an old state (and, because of the next equality,
125 -- new_info must be a new state).
126 , Maybe.isJust $ oldStateId $ sigUse old_info
127 -- And the state numbers must match
128 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
130 -- Replace the second tuple element with the corresponding SignalInfo
131 --args_states = map (Arrow.second $ signalInfo sigs) args
132 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
133 mkStateProcSm (num, old, new) =
134 AST.ProcSm label [clk] [statement]
136 label = mkVHDLExtId $ "state_" ++ (show num)
137 clk = mkVHDLExtId "clk"
138 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
139 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
140 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
141 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
142 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
144 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
146 getSignalId :: SignalInfo -> AST.VHDLId
148 mkVHDLExtId $ Maybe.fromMaybe
149 (error $ "Unnamed signal? This should not happen!")