1 module Translator where
2 import qualified Directory
4 import GHC hiding (loadModule, sigName)
6 import qualified CoreUtils
10 import qualified DataCon
11 import qualified HscMain
12 import qualified SrcLoc
13 import qualified FastString
14 import qualified Maybe
15 import qualified Module
16 import qualified Data.Foldable as Foldable
17 import qualified Control.Monad.Trans.State as State
19 import qualified Data.Map as Map
22 import NameEnv ( lookupNameEnv )
23 import qualified HscTypes
24 import HscTypes ( cm_binds, cm_types )
25 import MonadUtils ( liftIO )
26 import Outputable ( showSDoc, ppr )
27 import GHC.Paths ( libdir )
28 import DynFlags ( defaultDynFlags )
31 import qualified Monad
33 -- The following modules come from the ForSyDe project. They are really
34 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
35 -- ForSyDe to get access to these modules.
36 import qualified ForSyDe.Backend.VHDL.AST as AST
37 import qualified ForSyDe.Backend.VHDL.Ppr
38 import qualified ForSyDe.Backend.VHDL.FileIO
39 import qualified ForSyDe.Backend.Ppr
40 -- This is needed for rendering the pretty printed VHDL
41 import Text.PrettyPrint.HughesPJ (render)
43 import TranslatorTypes
52 makeVHDL "Alu.hs" "exec" True
54 makeVHDL :: String -> String -> Bool -> IO ()
55 makeVHDL filename name stateful = do
57 core <- loadModule filename
59 vhdl <- moduleToVHDL core [(name, stateful)]
61 let dir = "../vhdl/vhdl/" ++ name ++ "/"
62 mapM (writeVHDL dir) vhdl
65 -- | Show the core structure of the given binds in the given file.
66 listBind :: String -> String -> IO ()
67 listBind filename name = do
68 core <- loadModule filename
69 let [(b, expr)] = findBinds core [name]
71 putStr $ prettyShow expr
73 putStr $ showSDoc $ ppr expr
75 putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
78 -- | Translate the binds with the given names from the given core module to
79 -- VHDL. The Bool in the tuple makes the function stateful (True) or
81 moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
82 moduleToVHDL core list = do
83 let (names, statefuls) = unzip list
84 --liftIO $ putStr $ prettyShow (cm_binds core)
85 let binds = findBinds core names
86 --putStr $ prettyShow binds
87 -- Turn bind into VHDL
88 let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
89 mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
90 putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
93 -- Turns the given bind into VHDL
94 mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
95 mkVHDL binds statefuls = do
96 -- Add the builtin functions
97 --mapM addBuiltIn builtin_funcs
98 -- Create entities and architectures for them
99 --Monad.zipWithM processBind statefuls binds
100 --modA tsFlatFuncs (Map.map nameFlatFunction)
101 --flatfuncs <- getA tsFlatFuncs
102 return $ VHDL.createDesignFiles binds
104 -- | Write the given design file to a file with the given name inside the
106 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
107 writeVHDL dir (name, vhdl) = do
108 -- Create the dir if needed
109 exists <- Directory.doesDirectoryExist dir
110 Monad.unless exists $ Directory.createDirectory dir
112 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
114 ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
116 -- | Loads the given file and turns it into a core module.
117 loadModule :: String -> IO HscTypes.CoreModule
118 loadModule filename =
119 defaultErrorHandler defaultDynFlags $ do
120 runGhc (Just libdir) $ do
121 dflags <- getSessionDynFlags
122 setSessionDynFlags dflags
123 --target <- guessTarget "adder.hs" Nothing
124 --liftIO (print (showSDoc (ppr (target))))
125 --liftIO $ printTarget target
126 --setTargets [target]
127 --load LoadAllTargets
128 --core <- GHC.compileToCoreSimplified "Adders.hs"
129 core <- GHC.compileToCoreModule filename
132 -- | Extracts the named binds from the given module.
133 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
134 findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
136 -- | Extract a named bind from the given list of binds
137 findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
138 findBind binds lookfor =
139 -- This ignores Recs and compares the name of the bind with lookfor,
140 -- disregarding any namespaces in OccName and extra attributes in Name and
142 find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
144 -- | Processes the given bind as a top level bind.
146 Bool -- ^ Should this be stateful function?
147 -> (CoreBndr, CoreExpr) -- ^ The bind to process
148 -> TranslatorState ()
150 processBind stateful bind@(var, expr) = do
151 -- Create the function signature
152 let ty = CoreUtils.exprType expr
153 let hsfunc = mkHsFunction var ty stateful
154 flattenBind hsfunc bind
156 -- | Flattens the given bind into the given signature and adds it to the
157 -- session. Then (recursively) finds any functions it uses and does the same
160 HsFunction -- The signature to flatten into
161 -> (CoreBndr, CoreExpr) -- The bind to flatten
162 -> TranslatorState ()
164 flattenBind hsfunc bind@(var, expr) = do
165 -- Flatten the function
166 let flatfunc = flattenFunction hsfunc bind
167 -- Propagate state variables
168 let flatfunc' = propagateState hsfunc flatfunc
169 -- Store the flat function in the session
170 modA tsFlatFuncs (Map.insert hsfunc flatfunc')
171 -- Flatten any functions used
172 let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
173 mapM_ resolvFunc used_hsfuncs
175 -- | Decide which incoming state variables will become state in the
176 -- given function, and which will be propagate to other applied
183 propagateState hsfunc flatfunc =
184 flatfunc {flat_defs = apps', flat_sigs = sigs'}
186 (olds, news) = unzip $ getStateSignals hsfunc flatfunc
187 states' = zip olds news
188 -- Find all signals used by all sigdefs
189 uses = concatMap sigDefUses (flat_defs flatfunc)
190 -- Find all signals that are used more than once (is there a
191 -- prettier way to do this?)
192 multiple_uses = uses List.\\ (List.nub uses)
193 -- Find the states whose "old state" signal is used only once
194 single_use_states = filter ((`notElem` multiple_uses) . fst) states'
195 -- See if these single use states can be propagated
196 (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
197 substate_sigs = concat substate_sigss
198 -- Mark any propagated state signals as SigSubState
200 (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
203 -- | Propagate the state into a single function application.
205 [(SignalId, SignalId)]
207 -> SigDef -- ^ The SigDef to process.
208 -> ([SignalId], SigDef)
209 -- ^ Any signal ids that should become substates,
210 -- and the resulting application.
212 propagateState' states def =
213 if (is_FApp def) then
214 (our_old ++ our_new, def {appFunc = hsfunc'})
221 our_states = filter our_state states
222 -- A state signal belongs in this function if the old state is
223 -- passed in, and the new state returned
224 our_state (old, new) =
225 any (old `Foldable.elem`) args
226 && new `Foldable.elem` res
227 (our_old, our_new) = unzip our_states
229 zipped_res = zipValueMaps res (hsFuncRes hsfunc)
230 res' = fmap (mark_state (zip our_new [0..])) zipped_res
232 zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
233 args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
234 hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
236 mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
237 mark_state states (id, use) =
238 case lookup id states of
240 Just state_id -> State state_id
242 -- | Returns pairs of signals that should be mapped to state in this function.
244 HsFunction -- | The function to look at
245 -> FlatFunction -- | The function to look at
246 -> [(SignalId, SignalId)]
247 -- | TODO The state signals. The first is the state number, the second the
248 -- signal to assign the current state to, the last is the signal
249 -- that holds the new state.
251 getStateSignals hsfunc flatfunc =
253 | (old_num, old_id) <- args
254 , (new_num, new_id) <- res
255 , old_num == new_num]
257 sigs = flat_sigs flatfunc
258 -- Translate args and res to lists of (statenum, sigid)
259 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
260 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
262 -- | Find the given function, flatten it and add it to the session. Then
263 -- (recursively) do the same for any functions used.
265 HsFunction -- | The function to look for
266 -> TranslatorState ()
268 resolvFunc hsfunc = do
269 flatfuncmap <- getA tsFlatFuncs
270 -- Don't do anything if there is already a flat function for this hsfunc or
271 -- when it is a builtin function.
272 Monad.unless (Map.member hsfunc flatfuncmap) $ do
273 -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
274 -- New function, resolve it
275 core <- getA tsCoreModule
276 -- Find the named function
277 let name = (hsFuncName hsfunc)
278 let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
280 Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
281 Just b -> flattenBind hsfunc b
283 -- | Translate a top level function declaration to a HsFunction. i.e., which
284 -- interface will be provided by this function. This function essentially
285 -- defines the "calling convention" for hardware models.
287 Var.Var -- ^ The function defined
288 -> Type -- ^ The function type (including arguments!)
289 -> Bool -- ^ Is this a stateful function?
290 -> HsFunction -- ^ The resulting HsFunction
292 mkHsFunction f ty stateful=
293 HsFunction hsname hsargs hsres
295 hsname = getOccString f
296 (arg_tys, res_ty) = Type.splitFunTys ty
301 -- The last argument must be state
302 state_ty = last arg_tys
303 state = useAsState (mkHsValueMap state_ty)
304 -- All but the last argument are inports
305 inports = map (useAsPort . mkHsValueMap)(init arg_tys)
306 hsargs = inports ++ [state]
307 hsres = case splitTupleType res_ty of
308 -- Result type must be a two tuple (state, ports)
309 Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
311 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
313 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
314 otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
318 -- Just use everything as a port
319 (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
321 -- | Adds signal names to the given FlatFunction
326 nameFlatFunction flatfunc =
329 s = flat_sigs flatfunc
330 s' = map nameSignal s in
331 flatfunc { flat_sigs = s' }
333 nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
334 nameSignal (id, info) =
335 let hints = nameHints info in
336 let parts = ("sig" : hints) ++ [show id] in
337 let name = concat $ List.intersperse "_" parts in
338 (id, info {sigName = Just name})
340 -- | Splits a tuple type into a list of element types, or Nothing if the type
341 -- is not a tuple type.
343 Type -- ^ The type to split
344 -> Maybe [Type] -- ^ The tuples element types
347 case Type.splitTyConApp_maybe ty of
348 Just (tycon, args) -> if TyCon.isTupleTyCon tycon
355 -- vim: set ts=8 sw=2 sts=2 expandtab: