1 module CLasH.Translator where
3 import qualified Directory
4 import qualified System.FilePath as FilePath
7 import qualified Control.Arrow as Arrow
8 import GHC hiding (loadModule, sigName)
10 import qualified CoreUtils
13 import qualified TyCon
14 import qualified DataCon
15 import qualified HscMain
16 import qualified SrcLoc
17 import qualified FastString
18 import qualified Maybe
19 import qualified Module
20 import qualified Data.Foldable as Foldable
21 import qualified Control.Monad.Trans.State as State
23 import qualified Data.Map as Map
26 import NameEnv ( lookupNameEnv )
27 import qualified HscTypes
28 import HscTypes ( cm_binds, cm_types )
29 import MonadUtils ( liftIO )
30 import Outputable ( showSDoc, ppr, showSDocDebug )
31 import GHC.Paths ( libdir )
32 import DynFlags ( defaultDynFlags )
33 import qualified UniqSupply
36 import qualified Monad
38 -- The following modules come from the ForSyDe project. They are really
39 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
40 -- ForSyDe to get access to these modules.
41 import qualified Language.VHDL.AST as AST
42 import qualified Language.VHDL.FileIO
43 import qualified Language.VHDL.Ppr as Ppr
44 -- This is needed for rendering the pretty printed VHDL
45 import Text.PrettyPrint.HughesPJ (render)
47 import CLasH.Translator.TranslatorTypes
48 import CLasH.Utils.Pretty
49 import CLasH.Normalize
50 import CLasH.VHDL.VHDLTypes
51 import qualified CLasH.VHDL as VHDL
53 makeVHDL :: String -> String -> Bool -> IO ()
54 makeVHDL filename name stateful = do
56 (core, env) <- loadModule filename
58 vhdl <- moduleToVHDL env core [(name, stateful)]
60 let dir = "./vhdl/" ++ name ++ "/"
62 mapM (writeVHDL dir) vhdl
65 listBindings :: String -> IO [()]
66 listBindings filename = do
67 (core, env) <- loadModule filename
68 let binds = CoreSyn.flattenBinds $ cm_binds core
69 mapM (listBinding) binds
71 listBinding :: (CoreBndr, CoreExpr) -> IO ()
72 listBinding (b, e) = do
75 putStr "\nExpression: \n"
78 putStr $ showSDoc $ ppr e
80 putStr $ showSDoc $ ppr $ CoreUtils.exprType e
83 -- | Show the core structure of the given binds in the given file.
84 listBind :: String -> String -> IO ()
85 listBind filename name = do
86 (core, env) <- loadModule filename
87 let [(b, expr)] = findBinds core [name]
89 putStr $ prettyShow expr
91 putStr $ showSDoc $ ppr expr
93 putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
96 -- | Translate the binds with the given names from the given core module to
97 -- VHDL. The Bool in the tuple makes the function stateful (True) or
99 moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
100 moduleToVHDL env core list = do
101 let (names, statefuls) = unzip list
102 let binds = map fst $ findBinds core names
103 -- Generate a UniqSupply
105 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
106 -- on the compiler dir of ghc suggests that 'z' is not used to generate a
107 -- unique supply anywhere.
108 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
109 -- Turn bind into VHDL
110 let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
111 let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
112 let vhdl = VHDL.createDesignFiles typestate normalized_bindings
113 mapM (putStr . render . Ppr.ppr . snd) vhdl
114 --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
118 -- | Prepares the directory for writing VHDL files. This means creating the
119 -- dir if it does not exist and removing all existing .vhdl files from it.
120 prepareDir :: String -> IO()
122 -- Create the dir if needed
123 exists <- Directory.doesDirectoryExist dir
124 Monad.unless exists $ Directory.createDirectory dir
125 -- Find all .vhdl files in the directory
126 files <- Directory.getDirectoryContents dir
127 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
128 -- Prepend the dirname to the filenames
129 let abs_to_remove = map (FilePath.combine dir) to_remove
131 mapM_ Directory.removeFile abs_to_remove
133 -- | Write the given design file to a file with the given name inside the
135 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
136 writeVHDL dir (name, vhdl) = do
138 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
140 Language.VHDL.FileIO.writeDesignFile vhdl fname
142 -- | Loads the given file and turns it into a core module.
143 loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
144 loadModule filename =
145 defaultErrorHandler defaultDynFlags $ do
146 runGhc (Just libdir) $ do
147 dflags <- getSessionDynFlags
148 setSessionDynFlags dflags
149 --target <- guessTarget "adder.hs" Nothing
150 --liftIO (print (showSDoc (ppr (target))))
151 --liftIO $ printTarget target
152 --setTargets [target]
153 --load LoadAllTargets
154 --core <- GHC.compileToCoreSimplified "Adders.hs"
155 core <- GHC.compileToCoreModule filename
156 env <- GHC.getSession
159 -- | Extracts the named binds from the given module.
160 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
161 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
163 -- | Extract a named bind from the given list of binds
164 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
165 findBind binds lookfor =
166 -- This ignores Recs and compares the name of the bind with lookfor,
167 -- disregarding any namespaces in OccName and extra attributes in Name and
169 find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
171 -- | Flattens the given bind into the given signature and adds it to the
172 -- session. Then (recursively) finds any functions it uses and does the same
175 -- HsFunction -- The signature to flatten into
176 -- -> (CoreBndr, CoreExpr) -- The bind to flatten
177 -- -> TranslatorState ()
179 -- flattenBind hsfunc bind@(var, expr) = do
180 -- -- Flatten the function
181 -- let flatfunc = flattenFunction hsfunc bind
182 -- -- Propagate state variables
183 -- let flatfunc' = propagateState hsfunc flatfunc
184 -- -- Store the flat function in the session
185 -- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
186 -- -- Flatten any functions used
187 -- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
188 -- mapM_ resolvFunc used_hsfuncs
190 -- | Decide which incoming state variables will become state in the
191 -- given function, and which will be propagate to other applied
198 -- propagateState hsfunc flatfunc =
199 -- flatfunc {flat_defs = apps', flat_sigs = sigs'}
201 -- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
202 -- states' = zip olds news
203 -- -- Find all signals used by all sigdefs
204 -- uses = concatMap sigDefUses (flat_defs flatfunc)
205 -- -- Find all signals that are used more than once (is there a
206 -- -- prettier way to do this?)
207 -- multiple_uses = uses List.\\ (List.nub uses)
208 -- -- Find the states whose "old state" signal is used only once
209 -- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
210 -- -- See if these single use states can be propagated
211 -- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
212 -- substate_sigs = concat substate_sigss
213 -- -- Mark any propagated state signals as SigSubState
215 -- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
216 -- (flat_sigs flatfunc)
218 -- | Propagate the state into a single function application.
219 -- propagateState' ::
220 -- [(SignalId, SignalId)]
222 -- -> SigDef -- ^ The SigDef to process.
223 -- -> ([SignalId], SigDef)
224 -- -- ^ Any signal ids that should become substates,
225 -- -- and the resulting application.
227 -- propagateState' states def =
228 -- if (is_FApp def) then
229 -- (our_old ++ our_new, def {appFunc = hsfunc'})
233 -- hsfunc = appFunc def
234 -- args = appArgs def
236 -- our_states = filter our_state states
237 -- -- A state signal belongs in this function if the old state is
238 -- -- passed in, and the new state returned
239 -- our_state (old, new) =
240 -- any (old `Foldable.elem`) args
241 -- && new `Foldable.elem` res
242 -- (our_old, our_new) = unzip our_states
243 -- -- Mark the result
244 -- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
245 -- res' = fmap (mark_state (zip our_new [0..])) zipped_res
247 -- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
248 -- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
249 -- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
251 -- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
252 -- mark_state states (id, use) =
253 -- case lookup id states of
255 -- Just state_id -> State state_id
257 -- | Returns pairs of signals that should be mapped to state in this function.
258 -- getStateSignals ::
259 -- HsFunction -- | The function to look at
260 -- -> FlatFunction -- | The function to look at
261 -- -> [(SignalId, SignalId)]
262 -- -- | TODO The state signals. The first is the state number, the second the
263 -- -- signal to assign the current state to, the last is the signal
264 -- -- that holds the new state.
266 -- getStateSignals hsfunc flatfunc =
268 -- | (old_num, old_id) <- args
269 -- , (new_num, new_id) <- res
270 -- , old_num == new_num]
272 -- sigs = flat_sigs flatfunc
273 -- -- Translate args and res to lists of (statenum, sigid)
274 -- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
275 -- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
277 -- | Find the given function, flatten it and add it to the session. Then
278 -- (recursively) do the same for any functions used.
280 -- HsFunction -- | The function to look for
281 -- -> TranslatorState ()
283 -- resolvFunc hsfunc = do
284 -- flatfuncmap <- getA tsFlatFuncs
285 -- -- Don't do anything if there is already a flat function for this hsfunc or
286 -- -- when it is a builtin function.
287 -- Monad.unless (Map.member hsfunc flatfuncmap) $ do
288 -- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
289 -- -- New function, resolve it
290 -- core <- getA tsCoreModule
291 -- -- Find the named function
292 -- let name = (hsFuncName hsfunc)
293 -- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
295 -- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
296 -- Just b -> flattenBind hsfunc b
298 -- | Translate a top level function declaration to a HsFunction. i.e., which
299 -- interface will be provided by this function. This function essentially
300 -- defines the "calling convention" for hardware models.
302 -- Var.Var -- ^ The function defined
303 -- -> Type -- ^ The function type (including arguments!)
304 -- -> Bool -- ^ Is this a stateful function?
305 -- -> HsFunction -- ^ The resulting HsFunction
307 -- mkHsFunction f ty stateful=
308 -- HsFunction hsname hsargs hsres
310 -- hsname = getOccString f
311 -- (arg_tys, res_ty) = Type.splitFunTys ty
316 -- -- The last argument must be state
317 -- state_ty = last arg_tys
318 -- state = useAsState (mkHsValueMap state_ty)
319 -- -- All but the last argument are inports
320 -- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
321 -- hsargs = inports ++ [state]
322 -- hsres = case splitTupleType res_ty of
323 -- -- Result type must be a two tuple (state, ports)
324 -- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
326 -- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
328 -- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
329 -- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
333 -- -- Just use everything as a port
334 -- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
336 -- | Adds signal names to the given FlatFunction
337 -- nameFlatFunction ::
341 -- nameFlatFunction flatfunc =
342 -- -- Name the signals
344 -- s = flat_sigs flatfunc
345 -- s' = map nameSignal s in
346 -- flatfunc { flat_sigs = s' }
348 -- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
349 -- nameSignal (id, info) =
350 -- let hints = nameHints info in
351 -- let parts = ("sig" : hints) ++ [show id] in
352 -- let name = concat $ List.intersperse "_" parts in
353 -- (id, info {sigName = Just name})
355 -- -- | Splits a tuple type into a list of element types, or Nothing if the type
356 -- -- is not a tuple type.
358 -- Type -- ^ The type to split
359 -- -> Maybe [Type] -- ^ The tuples element types
361 -- splitTupleType ty =
362 -- case Type.splitTyConApp_maybe ty of
363 -- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
368 -- Nothing -> Nothing
370 -- vim: set ts=8 sw=2 sts=2 expandtab: