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 )
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 -- | Show the core structure of the given binds in the given file.
69 listBind :: String -> String -> IO ()
70 listBind filename name = do
71 core <- loadModule filename
72 let [(b, expr)] = findBinds core [name]
74 putStr $ prettyShow expr
76 putStr $ showSDoc $ ppr expr
78 putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
81 -- | Translate the binds with the given names from the given core module to
82 -- VHDL. The Bool in the tuple makes the function stateful (True) or
84 moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
85 moduleToVHDL core list = do
86 let (names, statefuls) = unzip list
87 let binds = map fst $ findBinds core names
88 -- Generate a UniqSupply
90 -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
91 -- on the compiler dir of ghc suggests that 'z' is not used to generate a
92 -- unique supply anywhere.
93 uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
94 -- Turn bind into VHDL
95 let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
96 let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
97 let vhdl = VHDL.createDesignFiles normalized_bindings
98 mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
99 --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
103 -- | Prepares the directory for writing VHDL files. This means creating the
104 -- dir if it does not exist and removing all existing .vhdl files from it.
105 prepareDir :: String -> IO()
107 -- Create the dir if needed
108 exists <- Directory.doesDirectoryExist dir
109 Monad.unless exists $ Directory.createDirectory dir
110 -- Find all .vhdl files in the directory
111 files <- Directory.getDirectoryContents dir
112 let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
113 -- Prepend the dirname to the filenames
114 let abs_to_remove = map (FilePath.combine dir) to_remove
116 mapM_ Directory.removeFile abs_to_remove
118 -- | Write the given design file to a file with the given name inside the
120 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
121 writeVHDL dir (name, vhdl) = do
123 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
125 ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
127 -- | Loads the given file and turns it into a core module.
128 loadModule :: String -> IO HscTypes.CoreModule
129 loadModule filename =
130 defaultErrorHandler defaultDynFlags $ do
131 runGhc (Just libdir) $ do
132 dflags <- getSessionDynFlags
133 setSessionDynFlags dflags
134 --target <- guessTarget "adder.hs" Nothing
135 --liftIO (print (showSDoc (ppr (target))))
136 --liftIO $ printTarget target
137 --setTargets [target]
138 --load LoadAllTargets
139 --core <- GHC.compileToCoreSimplified "Adders.hs"
140 core <- GHC.compileToCoreModule filename
143 -- | Extracts the named binds from the given module.
144 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
145 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
147 -- | Extract a named bind from the given list of binds
148 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
149 findBind binds lookfor =
150 -- This ignores Recs and compares the name of the bind with lookfor,
151 -- disregarding any namespaces in OccName and extra attributes in Name and
153 find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
155 -- | Flattens the given bind into the given signature and adds it to the
156 -- session. Then (recursively) finds any functions it uses and does the same
159 HsFunction -- The signature to flatten into
160 -> (CoreBndr, CoreExpr) -- The bind to flatten
161 -> TranslatorState ()
163 flattenBind hsfunc bind@(var, expr) = do
164 -- Flatten the function
165 let flatfunc = flattenFunction hsfunc bind
166 -- Propagate state variables
167 let flatfunc' = propagateState hsfunc flatfunc
168 -- Store the flat function in the session
169 modA tsFlatFuncs (Map.insert hsfunc flatfunc')
170 -- Flatten any functions used
171 let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
172 mapM_ resolvFunc used_hsfuncs
174 -- | Decide which incoming state variables will become state in the
175 -- given function, and which will be propagate to other applied
182 propagateState hsfunc flatfunc =
183 flatfunc {flat_defs = apps', flat_sigs = sigs'}
185 (olds, news) = unzip $ getStateSignals hsfunc flatfunc
186 states' = zip olds news
187 -- Find all signals used by all sigdefs
188 uses = concatMap sigDefUses (flat_defs flatfunc)
189 -- Find all signals that are used more than once (is there a
190 -- prettier way to do this?)
191 multiple_uses = uses List.\\ (List.nub uses)
192 -- Find the states whose "old state" signal is used only once
193 single_use_states = filter ((`notElem` multiple_uses) . fst) states'
194 -- See if these single use states can be propagated
195 (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
196 substate_sigs = concat substate_sigss
197 -- Mark any propagated state signals as SigSubState
199 (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
202 -- | Propagate the state into a single function application.
204 [(SignalId, SignalId)]
206 -> SigDef -- ^ The SigDef to process.
207 -> ([SignalId], SigDef)
208 -- ^ Any signal ids that should become substates,
209 -- and the resulting application.
211 propagateState' states def =
212 if (is_FApp def) then
213 (our_old ++ our_new, def {appFunc = hsfunc'})
220 our_states = filter our_state states
221 -- A state signal belongs in this function if the old state is
222 -- passed in, and the new state returned
223 our_state (old, new) =
224 any (old `Foldable.elem`) args
225 && new `Foldable.elem` res
226 (our_old, our_new) = unzip our_states
228 zipped_res = zipValueMaps res (hsFuncRes hsfunc)
229 res' = fmap (mark_state (zip our_new [0..])) zipped_res
231 zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
232 args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
233 hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
235 mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
236 mark_state states (id, use) =
237 case lookup id states of
239 Just state_id -> State state_id
241 -- | Returns pairs of signals that should be mapped to state in this function.
243 HsFunction -- | The function to look at
244 -> FlatFunction -- | The function to look at
245 -> [(SignalId, SignalId)]
246 -- | TODO The state signals. The first is the state number, the second the
247 -- signal to assign the current state to, the last is the signal
248 -- that holds the new state.
250 getStateSignals hsfunc flatfunc =
252 | (old_num, old_id) <- args
253 , (new_num, new_id) <- res
254 , old_num == new_num]
256 sigs = flat_sigs flatfunc
257 -- Translate args and res to lists of (statenum, sigid)
258 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
259 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
261 -- | Find the given function, flatten it and add it to the session. Then
262 -- (recursively) do the same for any functions used.
264 HsFunction -- | The function to look for
265 -> TranslatorState ()
267 resolvFunc hsfunc = do
268 flatfuncmap <- getA tsFlatFuncs
269 -- Don't do anything if there is already a flat function for this hsfunc or
270 -- when it is a builtin function.
271 Monad.unless (Map.member hsfunc flatfuncmap) $ do
272 -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
273 -- New function, resolve it
274 core <- getA tsCoreModule
275 -- Find the named function
276 let name = (hsFuncName hsfunc)
277 let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
279 Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
280 Just b -> flattenBind hsfunc b
282 -- | Translate a top level function declaration to a HsFunction. i.e., which
283 -- interface will be provided by this function. This function essentially
284 -- defines the "calling convention" for hardware models.
286 Var.Var -- ^ The function defined
287 -> Type -- ^ The function type (including arguments!)
288 -> Bool -- ^ Is this a stateful function?
289 -> HsFunction -- ^ The resulting HsFunction
291 mkHsFunction f ty stateful=
292 HsFunction hsname hsargs hsres
294 hsname = getOccString f
295 (arg_tys, res_ty) = Type.splitFunTys ty
300 -- The last argument must be state
301 state_ty = last arg_tys
302 state = useAsState (mkHsValueMap state_ty)
303 -- All but the last argument are inports
304 inports = map (useAsPort . mkHsValueMap)(init arg_tys)
305 hsargs = inports ++ [state]
306 hsres = case splitTupleType res_ty of
307 -- Result type must be a two tuple (state, ports)
308 Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
310 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
312 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
313 otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
317 -- Just use everything as a port
318 (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
320 -- | Adds signal names to the given FlatFunction
325 nameFlatFunction flatfunc =
328 s = flat_sigs flatfunc
329 s' = map nameSignal s in
330 flatfunc { flat_sigs = s' }
332 nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
333 nameSignal (id, info) =
334 let hints = nameHints info in
335 let parts = ("sig" : hints) ++ [show id] in
336 let name = concat $ List.intersperse "_" parts in
337 (id, info {sigName = Just name})
339 -- | Splits a tuple type into a list of element types, or Nothing if the type
340 -- is not a tuple type.
342 Type -- ^ The type to split
343 -> Maybe [Type] -- ^ The tuples element types
346 case Type.splitTyConApp_maybe ty of
347 Just (tycon, args) -> if TyCon.isTupleTyCon tycon
354 -- vim: set ts=8 sw=2 sts=2 expandtab: