1 {-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-}
3 module CLasH.Translator where
5 import qualified Directory
6 import qualified System.FilePath as FilePath
9 import qualified Control.Arrow as Arrow
10 import GHC hiding (loadModule, sigName)
12 import qualified CoreUtils
15 import qualified TyCon
16 import qualified DataCon
17 import qualified HscMain
18 import qualified SrcLoc
19 import qualified FastString
20 import qualified Maybe
21 import qualified Module
22 import qualified Data.Foldable as Foldable
23 import qualified Control.Monad.Trans.State as State
24 import qualified Control.Monad as Monad
26 import qualified Data.Map as Map
29 import NameEnv ( lookupNameEnv )
30 import qualified HscTypes
31 import HscTypes ( cm_binds, cm_types )
32 import MonadUtils ( liftIO )
33 import Outputable ( showSDoc, ppr, showSDocDebug )
34 import DynFlags ( defaultDynFlags )
35 import qualified UniqSupply
38 import qualified Monad
39 import qualified Annotations
40 import qualified Serialized
42 -- The following modules come from the ForSyDe project. They are really
43 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
44 -- ForSyDe to get access to these modules.
45 import qualified Language.VHDL.AST as AST
46 import qualified Language.VHDL.FileIO
47 import qualified Language.VHDL.Ppr as Ppr
48 -- This is needed for rendering the pretty printed VHDL
49 import Text.PrettyPrint.HughesPJ (render)
51 import CLasH.Translator.TranslatorTypes
52 import CLasH.Translator.Annotations
53 import CLasH.Utils.Pretty
54 import CLasH.Normalize
55 import CLasH.VHDL.VHDLTypes
56 import CLasH.Utils.Core.CoreTools
57 import qualified CLasH.VHDL as VHDL
59 -- | Turn Haskell to VHDL
61 FilePath -- ^ The GHC Library Dir
62 -> [FilePath] -- ^ The FileNames
63 -> String -- ^ The TopEntity
64 -> String -- ^ The InitState
65 -> String -- ^ The TestInput
66 -> Bool -- ^ Is It a stateful (in case InitState is not specified)
68 makeVHDL libdir filenames topentity initstate testinput stateful = do
70 (core, top, init, test, env) <- loadModules libdir filenames (findBind topentity) (findBind initstate) (findExpr testinput)
72 vhdl <- moduleToVHDL env core top init test stateful
74 let top_entity = Maybe.fromJust $ head top
75 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
77 mapM (writeVHDL dir) vhdl
81 FilePath -- ^ The GHC Library Dir
82 -> [FilePath] -- ^ The FileNames
83 -> Bool -- ^ Is It a stateful (in case InitState is not specified)
85 makeVHDLAnn libdir filenames stateful = do
87 (cores, top, init, test, env) <- loadModules libdir filenames findTopEntity findInitState findTestInput
89 vhdl <- moduleToVHDL env cores top init test stateful
91 let top_entity = Maybe.fromJust $ head top
92 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
94 mapM (writeVHDL dir) vhdl
97 findTopEntity = findBindAnn (hasCLasHAnnotation isTopEntity)
98 findInitState = findBindAnn (hasCLasHAnnotation isInitState)
99 findTestInput = findExprAnn (hasCLasHAnnotation isTestInput)
101 -- | Translate the binds with the given names from the given core module to
102 -- VHDL. The Bool in the tuple makes the function stateful (True) or
103 -- stateless (False).
105 HscTypes.HscEnv -- ^ The GHC Environment
106 -> [HscTypes.CoreModule] -- ^ The Core Modules
107 -> [Maybe CoreBndr] -- ^ The TopEntity
108 -> [Maybe CoreBndr] -- ^ The InitState
109 -> [Maybe CoreExpr] -- ^ The TestInput
110 -> Bool -- ^ Is it stateful (in case InitState is not specified)
111 -> IO [(AST.VHDLId, AST.DesignFile)]
112 moduleToVHDL env cores top init test stateful = do
113 let topEntity = Maybe.catMaybes top
115 [] -> error "Top Entity Not Found"
117 let initialState = Maybe.catMaybes init
118 let isStateful = not (null initialState) || stateful
119 let testInput = Maybe.catMaybes test
120 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
121 let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (cm_binds x)) cores)
122 let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
123 let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
124 let vhdl = VHDL.createDesignFiles typestate normalized_bindings topEnt test_bindings
125 mapM (putStr . render . Ppr.ppr . snd) vhdl
127 xs -> error "More than one topentity found"
129 -- | Prepares the directory for writing VHDL files. This means creating the
130 -- dir if it does not exist and removing all existing .vhdl files from it.
131 prepareDir :: String -> IO()
133 -- Create the dir if needed
134 exists <- Directory.doesDirectoryExist dir
135 Monad.unless exists $ Directory.createDirectory dir
136 -- Find all .vhdl files in the directory
137 files <- Directory.getDirectoryContents dir
138 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
139 -- Prepend the dirname to the filenames
140 let abs_to_remove = map (FilePath.combine dir) to_remove
142 mapM_ Directory.removeFile abs_to_remove
144 -- | Write the given design file to a file with the given name inside the
146 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
147 writeVHDL dir (name, vhdl) = do
149 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
151 Language.VHDL.FileIO.writeDesignFile vhdl fname
153 -- | Loads the given files and turns it into a core module
155 FilePath -- ^ The GHC Library directory
156 -> [String] -- ^ The files that need to be loaded
157 -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder
158 -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder
159 -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder
160 -> IO ( [HscTypes.CoreModule] -- The loaded modules
161 , [Maybe CoreBndr] -- The TopEntity
162 , [Maybe CoreBndr] -- The InitState
163 , [Maybe CoreExpr] -- The TestInput
164 , HscTypes.HscEnv -- The Environment corresponding ot the loaded modules
166 loadModules libdir filenames topEntLoc initSLoc testLoc =
167 defaultErrorHandler defaultDynFlags $ do
168 runGhc (Just libdir) $ do
169 dflags <- getSessionDynFlags
170 setSessionDynFlags dflags
171 cores <- mapM GHC.compileToCoreModule filenames
172 env <- GHC.getSession
173 top_entity <- mapM topEntLoc cores
174 init_state <- mapM initSLoc cores
175 test_input <- mapM testLoc cores
176 return (cores, top_entity, init_state, test_input, env)
181 -> HscTypes.CoreModule
182 -> m (Maybe CoreBndr)
183 findBindAnn annotation core = do
184 let binds = CoreSyn.flattenBinds $ cm_binds core
185 annbinds <- Monad.filterM (annotation . fst) binds
186 let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
192 -> HscTypes.CoreModule
193 -> m (Maybe CoreExpr)
194 findExprAnn annotation core = do
195 let binds = CoreSyn.flattenBinds $ cm_binds core
196 annbinds <- Monad.filterM (annotation . fst) binds
197 let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
200 hasCLasHAnnotation ::
205 hasCLasHAnnotation clashAnn var = do
206 let deserializer = Serialized.deserializeWithData
207 let target = Annotations.NamedTarget (Var.varName var)
208 (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
209 let top_ents = filter clashAnn anns
214 -- | Extracts the named binder from the given module.
217 String -- ^ The Name of the Binder
218 -> HscTypes.CoreModule -- ^ The Module to look in
219 -> m (Maybe CoreBndr) -- ^ The resulting binder
221 case (findBinder (CoreSyn.flattenBinds $ cm_binds core)) name of
222 Nothing -> return Nothing
223 Just bndr -> return $ Just $ fst bndr
225 -- | Extracts the named expression from the given module.
228 String -- ^ The Name of the Binder
229 -> HscTypes.CoreModule -- ^ The Module to look in
230 -> m (Maybe CoreExpr) -- ^ The resulting expression
232 case (findBinder (CoreSyn.flattenBinds $ cm_binds core)) name of
233 Nothing -> return Nothing
234 Just bndr -> return $ Just $ snd bndr
236 -- | Extract a named bind from the given list of binds
237 findBinder :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
238 findBinder binds lookfor =
239 -- This ignores Recs and compares the name of the bind with lookfor,
240 -- disregarding any namespaces in OccName and extra attributes in Name and
242 find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
244 -- vim: set ts=8 sw=2 sts=2 expandtab: