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