1 {-# LANGUAGE ScopedTypeVariables #-}
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 -- makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
60 -- makeVHDL libdir filename name stateful = do
62 -- (core, env) <- loadModule libdir filename
63 -- -- Translate to VHDL
64 -- vhdl <- moduleToVHDL env core [(name, stateful)]
65 -- -- Write VHDL to file
66 -- let dir = "./vhdl/" ++ name ++ "/"
68 -- mapM (writeVHDL dir) vhdl
71 makeVHDLAnn :: FilePath -> String -> IO ()
72 makeVHDLAnn libdir filename = do
73 (core, top, init, test, env) <- loadModuleAnn libdir filename
74 let top_entity = head top
75 let test_expr = head test
77 [] -> moduleToVHDLAnn env core (top_entity, test_expr)
78 xs -> moduleToVHDLAnnState env core (top_entity, test_expr, (head xs))
79 let dir = "./vhdl/" ++ (show top_entity) ++ "/"
81 mapM (writeVHDL dir) vhdl
84 listBindings :: FilePath -> String -> IO [()]
85 listBindings libdir filename = do
86 (core, env) <- loadModule libdir filename
87 let binds = CoreSyn.flattenBinds $ cm_binds core
88 mapM (listBinding) binds
90 listBinding :: (CoreBndr, CoreExpr) -> IO ()
91 listBinding (b, e) = do
94 putStr "\nType of Binder: \n"
95 putStr $ showSDoc $ ppr $ Var.varType b
96 putStr "\n\nExpression: \n"
99 putStr $ showSDoc $ ppr e
100 putStr "\n\nType of Expression: \n"
101 putStr $ showSDoc $ ppr $ CoreUtils.exprType e
104 -- | Show the core structure of the given binds in the given file.
105 listBind :: FilePath -> String -> String -> IO ()
106 listBind libdir filename name = do
107 (core, env) <- loadModule libdir filename
108 let [(b, expr)] = findBinds core [name]
109 listBinding (b, expr)
111 -- | Translate the binds with the given names from the given core module to
112 -- VHDL. The Bool in the tuple makes the function stateful (True) or
113 -- stateless (False).
114 -- moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
115 -- moduleToVHDL env core list = do
116 -- let (names, statefuls) = unzip list
117 -- let binds = map fst $ findBinds core names
118 -- -- Generate a UniqSupply
120 -- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
121 -- -- on the compiler dir of ghc suggests that 'z' is not used to generate a
122 -- -- unique supply anywhere.
123 -- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
124 -- -- Turn bind into VHDL
125 -- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
126 -- let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
127 -- let vhdl = VHDL.createDesignFiles typestate normalized_bindings binds
128 -- mapM (putStr . render . Ppr.ppr . snd) vhdl
129 -- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
132 moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO [(AST.VHDLId, AST.DesignFile)]
133 moduleToVHDLAnn env core (topbind, test) = do
134 -- Generate a UniqSupply
136 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
137 -- on the compiler dir of ghc suggests that 'z' is not used to generate a
138 -- unique supply anywhere.
139 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
140 -- Turn bind into VHDL
141 let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
142 let testexprs = reduceCoreListToHsList test
143 let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [False]
144 let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
145 mapM (putStr . render . Ppr.ppr . snd) vhdl
146 --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
149 moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr, CoreSyn.CoreBndr) -> IO [(AST.VHDLId, AST.DesignFile)]
150 moduleToVHDLAnnState env core (topbind, test, init_state) = do
151 -- Generate a UniqSupply
153 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
154 -- on the compiler dir of ghc suggests that 'z' is not used to generate a
155 -- unique supply anywhere.
156 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
157 -- Turn bind into VHDL
158 let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
159 let testexprs = reduceCoreListToHsList test
160 let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [True]
161 let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
162 mapM (putStr . render . Ppr.ppr . snd) vhdl
163 --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
166 -- | Prepares the directory for writing VHDL files. This means creating the
167 -- dir if it does not exist and removing all existing .vhdl files from it.
168 prepareDir :: String -> IO()
170 -- Create the dir if needed
171 exists <- Directory.doesDirectoryExist dir
172 Monad.unless exists $ Directory.createDirectory dir
173 -- Find all .vhdl files in the directory
174 files <- Directory.getDirectoryContents dir
175 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
176 -- Prepend the dirname to the filenames
177 let abs_to_remove = map (FilePath.combine dir) to_remove
179 mapM_ Directory.removeFile abs_to_remove
181 -- | Write the given design file to a file with the given name inside the
183 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
184 writeVHDL dir (name, vhdl) = do
186 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
188 Language.VHDL.FileIO.writeDesignFile vhdl fname
190 -- | Loads the given file and turns it into a core module.
191 loadModule :: FilePath -> String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
192 loadModule libdir filename =
193 defaultErrorHandler defaultDynFlags $ do
194 runGhc (Just libdir) $ do
195 dflags <- getSessionDynFlags
196 setSessionDynFlags dflags
197 --target <- guessTarget "adder.hs" Nothing
198 --liftIO (print (showSDoc (ppr (target))))
199 --liftIO $ printTarget target
200 --setTargets [target]
201 --load LoadAllTargets
202 --core <- GHC.compileToCoreSimplified "Adders.hs"
203 core <- GHC.compileToCoreModule filename
204 env <- GHC.getSession
207 -- | Loads the given file and turns it into a core module.
208 loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv)
209 loadModuleAnn libdir filename =
210 defaultErrorHandler defaultDynFlags $ do
211 runGhc (Just libdir) $ do
212 dflags <- getSessionDynFlags
213 setSessionDynFlags dflags
214 --target <- guessTarget "adder.hs" Nothing
215 --liftIO (print (showSDoc (ppr (target))))
216 --liftIO $ printTarget target
217 --setTargets [target]
218 --load LoadAllTargets
219 --core <- GHC.compileToCoreSimplified "Adders.hs"
220 core <- GHC.compileToCoreModule filename
221 env <- GHC.getSession
222 top_entity <- findTopEntity core
223 init_state <- findInitState core
224 test_input <- findTestInput core
225 return (core, top_entity, init_state, test_input, env)
227 findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
228 findTopEntity core = do
229 let binds = CoreSyn.flattenBinds $ cm_binds core
230 topbinds <- Monad.filterM (hasTopEntityAnnotation . fst) binds
231 let bndrs = case topbinds of [] -> error $ "Couldn't find top entity in current module." ; xs -> fst (unzip topbinds)
234 findInitState :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
235 findInitState core = do
236 let binds = CoreSyn.flattenBinds $ cm_binds core
237 statebinds <- Monad.filterM (hasInitStateAnnotation . fst) binds
238 let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds)
241 findTestInput :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreExpr]
242 findTestInput core = do
243 let binds = CoreSyn.flattenBinds $ cm_binds core
244 testbinds <- Monad.filterM (hasTestInputAnnotation . fst) binds
245 let exprs = case testbinds of [] -> [] ; xs -> snd (unzip testbinds)
248 hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool
249 hasTopEntityAnnotation var = do
250 let deserializer = Serialized.deserializeWithData
251 let target = Annotations.NamedTarget (Var.varName var)
252 (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
253 let top_ents = filter isTopEntity anns
258 hasInitStateAnnotation :: GhcMonad m => Var.Var -> m Bool
259 hasInitStateAnnotation var = do
260 let deserializer = Serialized.deserializeWithData
261 let target = Annotations.NamedTarget (Var.varName var)
262 (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
263 let top_ents = filter isInitState anns
268 hasTestInputAnnotation :: GhcMonad m => Var.Var -> m Bool
269 hasTestInputAnnotation var = do
270 let deserializer = Serialized.deserializeWithData
271 let target = Annotations.NamedTarget (Var.varName var)
272 (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
273 let top_ents = filter isTestInput anns
278 -- | Extracts the named binds from the given module.
279 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
280 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
282 -- | Extract a named bind from the given list of binds
283 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
284 findBind binds lookfor =
285 -- This ignores Recs and compares the name of the bind with lookfor,
286 -- disregarding any namespaces in OccName and extra attributes in Name and
288 find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
290 -- | Flattens the given bind into the given signature and adds it to the
291 -- session. Then (recursively) finds any functions it uses and does the same
294 -- HsFunction -- The signature to flatten into
295 -- -> (CoreBndr, CoreExpr) -- The bind to flatten
296 -- -> TranslatorState ()
298 -- flattenBind hsfunc bind@(var, expr) = do
299 -- -- Flatten the function
300 -- let flatfunc = flattenFunction hsfunc bind
301 -- -- Propagate state variables
302 -- let flatfunc' = propagateState hsfunc flatfunc
303 -- -- Store the flat function in the session
304 -- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
305 -- -- Flatten any functions used
306 -- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
307 -- mapM_ resolvFunc used_hsfuncs
309 -- | Decide which incoming state variables will become state in the
310 -- given function, and which will be propagate to other applied
317 -- propagateState hsfunc flatfunc =
318 -- flatfunc {flat_defs = apps', flat_sigs = sigs'}
320 -- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
321 -- states' = zip olds news
322 -- -- Find all signals used by all sigdefs
323 -- uses = concatMap sigDefUses (flat_defs flatfunc)
324 -- -- Find all signals that are used more than once (is there a
325 -- -- prettier way to do this?)
326 -- multiple_uses = uses List.\\ (List.nub uses)
327 -- -- Find the states whose "old state" signal is used only once
328 -- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
329 -- -- See if these single use states can be propagated
330 -- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
331 -- substate_sigs = concat substate_sigss
332 -- -- Mark any propagated state signals as SigSubState
334 -- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
335 -- (flat_sigs flatfunc)
337 -- | Propagate the state into a single function application.
338 -- propagateState' ::
339 -- [(SignalId, SignalId)]
341 -- -> SigDef -- ^ The SigDef to process.
342 -- -> ([SignalId], SigDef)
343 -- -- ^ Any signal ids that should become substates,
344 -- -- and the resulting application.
346 -- propagateState' states def =
347 -- if (is_FApp def) then
348 -- (our_old ++ our_new, def {appFunc = hsfunc'})
352 -- hsfunc = appFunc def
353 -- args = appArgs def
355 -- our_states = filter our_state states
356 -- -- A state signal belongs in this function if the old state is
357 -- -- passed in, and the new state returned
358 -- our_state (old, new) =
359 -- any (old `Foldable.elem`) args
360 -- && new `Foldable.elem` res
361 -- (our_old, our_new) = unzip our_states
362 -- -- Mark the result
363 -- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
364 -- res' = fmap (mark_state (zip our_new [0..])) zipped_res
366 -- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
367 -- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
368 -- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
370 -- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
371 -- mark_state states (id, use) =
372 -- case lookup id states of
374 -- Just state_id -> State state_id
376 -- | Returns pairs of signals that should be mapped to state in this function.
377 -- getStateSignals ::
378 -- HsFunction -- | The function to look at
379 -- -> FlatFunction -- | The function to look at
380 -- -> [(SignalId, SignalId)]
381 -- -- | TODO The state signals. The first is the state number, the second the
382 -- -- signal to assign the current state to, the last is the signal
383 -- -- that holds the new state.
385 -- getStateSignals hsfunc flatfunc =
387 -- | (old_num, old_id) <- args
388 -- , (new_num, new_id) <- res
389 -- , old_num == new_num]
391 -- sigs = flat_sigs flatfunc
392 -- -- Translate args and res to lists of (statenum, sigid)
393 -- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
394 -- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
396 -- | Find the given function, flatten it and add it to the session. Then
397 -- (recursively) do the same for any functions used.
399 -- HsFunction -- | The function to look for
400 -- -> TranslatorState ()
402 -- resolvFunc hsfunc = do
403 -- flatfuncmap <- getA tsFlatFuncs
404 -- -- Don't do anything if there is already a flat function for this hsfunc or
405 -- -- when it is a builtin function.
406 -- Monad.unless (Map.member hsfunc flatfuncmap) $ do
407 -- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
408 -- -- New function, resolve it
409 -- core <- getA tsCoreModule
410 -- -- Find the named function
411 -- let name = (hsFuncName hsfunc)
412 -- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
414 -- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
415 -- Just b -> flattenBind hsfunc b
417 -- | Translate a top level function declaration to a HsFunction. i.e., which
418 -- interface will be provided by this function. This function essentially
419 -- defines the "calling convention" for hardware models.
421 -- Var.Var -- ^ The function defined
422 -- -> Type -- ^ The function type (including arguments!)
423 -- -> Bool -- ^ Is this a stateful function?
424 -- -> HsFunction -- ^ The resulting HsFunction
426 -- mkHsFunction f ty stateful=
427 -- HsFunction hsname hsargs hsres
429 -- hsname = getOccString f
430 -- (arg_tys, res_ty) = Type.splitFunTys ty
435 -- -- The last argument must be state
436 -- state_ty = last arg_tys
437 -- state = useAsState (mkHsValueMap state_ty)
438 -- -- All but the last argument are inports
439 -- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
440 -- hsargs = inports ++ [state]
441 -- hsres = case splitTupleType res_ty of
442 -- -- Result type must be a two tuple (state, ports)
443 -- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
445 -- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
447 -- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
448 -- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
452 -- -- Just use everything as a port
453 -- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
455 -- | Adds signal names to the given FlatFunction
456 -- nameFlatFunction ::
460 -- nameFlatFunction flatfunc =
461 -- -- Name the signals
463 -- s = flat_sigs flatfunc
464 -- s' = map nameSignal s in
465 -- flatfunc { flat_sigs = s' }
467 -- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
468 -- nameSignal (id, info) =
469 -- let hints = nameHints info in
470 -- let parts = ("sig" : hints) ++ [show id] in
471 -- let name = concat $ List.intersperse "_" parts in
472 -- (id, info {sigName = Just name})
474 -- -- | Splits a tuple type into a list of element types, or Nothing if the type
475 -- -- is not a tuple type.
477 -- Type -- ^ The type to split
478 -- -> Maybe [Type] -- ^ The tuples element types
480 -- splitTupleType ty =
481 -- case Type.splitTyConApp_maybe ty of
482 -- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
487 -- Nothing -> Nothing
489 -- vim: set ts=8 sw=2 sts=2 expandtab: