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
56 makeVHDL :: String -> String -> Bool -> IO ()
57 makeVHDL filename name stateful = do
59 core <- loadModule filename
61 vhdl <- moduleToVHDL core [(name, stateful)]
63 let dir = "./vhdl/" ++ name ++ "/"
65 mapM (writeVHDL dir) vhdl
68 listBindings :: String -> IO [()]
69 listBindings filename = do
70 core <- 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 <- 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.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
103 moduleToVHDL 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 = normalizeModule uniqSupply all_bindings binds statefuls
115 let vhdl = VHDL.createDesignFiles 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
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
161 -- | Extracts the named binds from the given module.
162 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
163 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
165 -- | Extract a named bind from the given list of binds
166 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
167 findBind binds lookfor =
168 -- This ignores Recs and compares the name of the bind with lookfor,
169 -- disregarding any namespaces in OccName and extra attributes in Name and
171 find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
173 -- | Flattens the given bind into the given signature and adds it to the
174 -- session. Then (recursively) finds any functions it uses and does the same
177 HsFunction -- The signature to flatten into
178 -> (CoreBndr, CoreExpr) -- The bind to flatten
179 -> TranslatorState ()
181 flattenBind hsfunc bind@(var, expr) = do
182 -- Flatten the function
183 let flatfunc = flattenFunction hsfunc bind
184 -- Propagate state variables
185 let flatfunc' = propagateState hsfunc flatfunc
186 -- Store the flat function in the session
187 modA tsFlatFuncs (Map.insert hsfunc flatfunc')
188 -- Flatten any functions used
189 let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
190 mapM_ resolvFunc used_hsfuncs
192 -- | Decide which incoming state variables will become state in the
193 -- given function, and which will be propagate to other applied
200 propagateState hsfunc flatfunc =
201 flatfunc {flat_defs = apps', flat_sigs = sigs'}
203 (olds, news) = unzip $ getStateSignals hsfunc flatfunc
204 states' = zip olds news
205 -- Find all signals used by all sigdefs
206 uses = concatMap sigDefUses (flat_defs flatfunc)
207 -- Find all signals that are used more than once (is there a
208 -- prettier way to do this?)
209 multiple_uses = uses List.\\ (List.nub uses)
210 -- Find the states whose "old state" signal is used only once
211 single_use_states = filter ((`notElem` multiple_uses) . fst) states'
212 -- See if these single use states can be propagated
213 (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
214 substate_sigs = concat substate_sigss
215 -- Mark any propagated state signals as SigSubState
217 (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
220 -- | Propagate the state into a single function application.
222 [(SignalId, SignalId)]
224 -> SigDef -- ^ The SigDef to process.
225 -> ([SignalId], SigDef)
226 -- ^ Any signal ids that should become substates,
227 -- and the resulting application.
229 propagateState' states def =
230 if (is_FApp def) then
231 (our_old ++ our_new, def {appFunc = hsfunc'})
238 our_states = filter our_state states
239 -- A state signal belongs in this function if the old state is
240 -- passed in, and the new state returned
241 our_state (old, new) =
242 any (old `Foldable.elem`) args
243 && new `Foldable.elem` res
244 (our_old, our_new) = unzip our_states
246 zipped_res = zipValueMaps res (hsFuncRes hsfunc)
247 res' = fmap (mark_state (zip our_new [0..])) zipped_res
249 zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
250 args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
251 hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
253 mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
254 mark_state states (id, use) =
255 case lookup id states of
257 Just state_id -> State state_id
259 -- | Returns pairs of signals that should be mapped to state in this function.
261 HsFunction -- | The function to look at
262 -> FlatFunction -- | The function to look at
263 -> [(SignalId, SignalId)]
264 -- | TODO The state signals. The first is the state number, the second the
265 -- signal to assign the current state to, the last is the signal
266 -- that holds the new state.
268 getStateSignals hsfunc flatfunc =
270 | (old_num, old_id) <- args
271 , (new_num, new_id) <- res
272 , old_num == new_num]
274 sigs = flat_sigs flatfunc
275 -- Translate args and res to lists of (statenum, sigid)
276 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
277 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
279 -- | Find the given function, flatten it and add it to the session. Then
280 -- (recursively) do the same for any functions used.
282 HsFunction -- | The function to look for
283 -> TranslatorState ()
285 resolvFunc hsfunc = do
286 flatfuncmap <- getA tsFlatFuncs
287 -- Don't do anything if there is already a flat function for this hsfunc or
288 -- when it is a builtin function.
289 Monad.unless (Map.member hsfunc flatfuncmap) $ do
290 -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
291 -- New function, resolve it
292 core <- getA tsCoreModule
293 -- Find the named function
294 let name = (hsFuncName hsfunc)
295 let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
297 Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
298 Just b -> flattenBind hsfunc b
300 -- | Translate a top level function declaration to a HsFunction. i.e., which
301 -- interface will be provided by this function. This function essentially
302 -- defines the "calling convention" for hardware models.
304 Var.Var -- ^ The function defined
305 -> Type -- ^ The function type (including arguments!)
306 -> Bool -- ^ Is this a stateful function?
307 -> HsFunction -- ^ The resulting HsFunction
309 mkHsFunction f ty stateful=
310 HsFunction hsname hsargs hsres
312 hsname = getOccString f
313 (arg_tys, res_ty) = Type.splitFunTys ty
318 -- The last argument must be state
319 state_ty = last arg_tys
320 state = useAsState (mkHsValueMap state_ty)
321 -- All but the last argument are inports
322 inports = map (useAsPort . mkHsValueMap)(init arg_tys)
323 hsargs = inports ++ [state]
324 hsres = case splitTupleType res_ty of
325 -- Result type must be a two tuple (state, ports)
326 Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
328 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
330 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
331 otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
335 -- Just use everything as a port
336 (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
338 -- | Adds signal names to the given FlatFunction
343 nameFlatFunction flatfunc =
346 s = flat_sigs flatfunc
347 s' = map nameSignal s in
348 flatfunc { flat_sigs = s' }
350 nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
351 nameSignal (id, info) =
352 let hints = nameHints info in
353 let parts = ("sig" : hints) ++ [show id] in
354 let name = concat $ List.intersperse "_" parts in
355 (id, info {sigName = Just name})
357 -- | Splits a tuple type into a list of element types, or Nothing if the type
358 -- is not a tuple type.
360 Type -- ^ The type to split
361 -> Maybe [Type] -- ^ The tuples element types
364 case Type.splitTyConApp_maybe ty of
365 Just (tycon, args) -> if TyCon.isTupleTyCon tycon
372 -- vim: set ts=8 sw=2 sts=2 expandtab: