1 {-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-}
3 module CLasH.Translator (makeVHDLStrings, makeVHDLAnnotations) where
6 import qualified Directory
9 import qualified System.FilePath as FilePath
10 import Text.PrettyPrint.HughesPJ (render)
13 import qualified Annotations
15 import DynFlags ( defaultDynFlags )
16 import GHC hiding (loadModule, sigName)
17 import qualified HscTypes
18 import HscTypes ( cm_binds, cm_types )
20 import qualified Serialized
21 import qualified UniqSupply
25 import qualified Language.VHDL.AST as AST
26 import qualified Language.VHDL.FileIO
27 import qualified Language.VHDL.Ppr as Ppr
30 import CLasH.Translator.Annotations
31 import CLasH.Normalize
32 import CLasH.Utils.Core.CoreTools
35 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
36 -- State and Test Inputs.
38 FilePath -- ^ The GHC Library Dir
39 -> [FilePath] -- ^ The FileNames
40 -> String -- ^ The TopEntity
41 -> String -- ^ The InitState
42 -> String -- ^ The TestInput
43 -> Bool -- ^ Is it stateful? (in case InitState is empty)
45 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
46 makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
48 findTopEntity = findBind (hasVarName topentity)
49 findInitState = findBind (hasVarName initstate)
50 findTestInput = findExpr (hasVarName testinput)
52 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
53 -- and Test Inputs found in the Files.
54 makeVHDLAnnotations ::
55 FilePath -- ^ The GHC Library Dir
56 -> [FilePath] -- ^ The FileNames
57 -> Bool -- ^ Is it stateful? (in case InitState is not specified)
59 makeVHDLAnnotations libdir filenames stateful = do
60 makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
62 findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
63 findInitState = findBind (hasCLasHAnnotation isInitState)
64 findTestInput = findExpr (hasCLasHAnnotation isTestInput)
66 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
67 -- Entity, Initial State and Test Inputs in the Haskell Files.
69 FilePath -- ^ The GHC Library Dir
70 -> [FilePath] -- ^ The Filenames
71 -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Top Entity Finder
72 -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Init State Finder
73 -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The Test Input Finder
74 -> Bool -- ^ Indicates if it is meant to be stateful
76 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
78 (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
80 vhdl <- moduleToVHDL env cores top init test stateful
82 let top_entity = Maybe.fromJust $ head top
83 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
85 mapM (writeVHDL dir) vhdl
88 -- | Translate the binds with the given names from the given core module to
89 -- VHDL. The Bool in the tuple makes the function stateful (True) or
92 HscTypes.HscEnv -- ^ The GHC Environment
93 -> [HscTypes.CoreModule] -- ^ The Core Modules
94 -> [Maybe CoreBndr] -- ^ The TopEntity
95 -> [Maybe CoreBndr] -- ^ The InitState
96 -> [Maybe CoreExpr] -- ^ The TestInput
97 -> Bool -- ^ Is it stateful (in case InitState is not specified)
98 -> IO [(AST.VHDLId, AST.DesignFile)]
99 moduleToVHDL env cores top init test stateful = do
100 let topEntity = Maybe.catMaybes top
102 [] -> error "Top Entity Not Found"
104 let initialState = Maybe.catMaybes init
105 let isStateful = not (null initialState) || stateful
106 let testInput = Maybe.catMaybes test
107 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
108 let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (cm_binds x)) cores)
109 let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
110 let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
111 let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
112 mapM (putStr . render . Ppr.ppr . snd) vhdl
114 xs -> error "More than one topentity found"
116 -- | Prepares the directory for writing VHDL files. This means creating the
117 -- dir if it does not exist and removing all existing .vhdl files from it.
118 prepareDir :: String -> IO()
120 -- Create the dir if needed
121 exists <- Directory.doesDirectoryExist dir
122 Monad.unless exists $ Directory.createDirectory dir
123 -- Find all .vhdl files in the directory
124 files <- Directory.getDirectoryContents dir
125 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
126 -- Prepend the dirname to the filenames
127 let abs_to_remove = map (FilePath.combine dir) to_remove
129 mapM_ Directory.removeFile abs_to_remove
131 -- | Write the given design file to a file with the given name inside the
133 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
134 writeVHDL dir (name, vhdl) = do
136 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
138 Language.VHDL.FileIO.writeDesignFile vhdl fname
140 -- | Loads the given files and turns it into a core module
142 FilePath -- ^ The GHC Library directory
143 -> [String] -- ^ The files that need to be loaded
144 -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder
145 -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder
146 -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder
147 -> IO ( [HscTypes.CoreModule]
152 ) -- ^ (The loaded modules , The TopEntity , The InitState, The TestInput, The Environment corresponding ot the loaded modules)
153 loadModules libdir filenames topEntLoc initSLoc testLoc =
154 defaultErrorHandler defaultDynFlags $ do
155 runGhc (Just libdir) $ do
156 dflags <- getSessionDynFlags
157 setSessionDynFlags dflags
158 cores <- mapM GHC.compileToCoreModule filenames
159 env <- GHC.getSession
160 top_entity <- mapM topEntLoc cores
161 init_state <- mapM initSLoc cores
162 test_input <- mapM testLoc cores
163 return (cores, top_entity, init_state, test_input, env)
165 -- | Find a binder in module according to a certain criteria
168 (Var.Var -> m Bool) -- ^ The criteria to filter the binds on
169 -> HscTypes.CoreModule -- ^ The module to be inspected
170 -> m (Maybe CoreBndr) -- ^ The (first) bind to meet the criteria
171 findBind annotation core = do
172 let binds = CoreSyn.flattenBinds $ cm_binds core
173 annbinds <- Monad.filterM (annotation . fst) binds
174 let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
177 -- | Find an expresion in module according to a certain criteria
180 (Var.Var -> m Bool) -- ^ The criteria to filter the binds on
181 -> HscTypes.CoreModule -- ^ The module to be inspected
182 -> m (Maybe CoreExpr) -- ^ The (first) expr to meet the criteria
183 findExpr annotation core = do
184 let binds = CoreSyn.flattenBinds $ cm_binds core
185 annbinds <- Monad.filterM (annotation . fst) binds
186 let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
189 -- | Determine if a binder has an Annotation meeting a certain criteria
190 hasCLasHAnnotation ::
192 (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
193 -> Var.Var -- ^ The Binder
194 -> m Bool -- ^ Indicates if binder has the Annotation
195 hasCLasHAnnotation clashAnn var = do
196 let deserializer = Serialized.deserializeWithData
197 let target = Annotations.NamedTarget (Var.varName var)
198 (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
199 let annEnts = filter clashAnn anns
204 -- | Determine if a binder has a certain name
207 String -- ^ The name the binder has to have
208 -> Var.Var -- ^ The Binder
209 -> m Bool -- ^ Indicate if the binder has the name
210 hasVarName lookfor bind = return $ lookfor == (occNameString $ nameOccName $ getName bind)
212 -- vim: set ts=8 sw=2 sts=2 expandtab: