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 [bind] = findBinds core [name]
71 putStr $ prettyShow bind
73 putStr $ showSDoc $ ppr bind
77 putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
79 otherwise -> return ()
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 --liftIO $ putStr $ prettyShow (cm_binds core)
88 let binds = findBinds core names
89 --putStr $ prettyShow binds
90 -- Turn bind into VHDL
91 let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
92 mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
93 putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
96 -- Turns the given bind into VHDL
97 mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
98 mkVHDL binds statefuls = do
99 -- Add the builtin functions
100 --mapM addBuiltIn builtin_funcs
101 -- Create entities and architectures for them
102 Monad.zipWithM processBind statefuls binds
103 modA tsFlatFuncs (Map.map nameFlatFunction)
104 flatfuncs <- getA tsFlatFuncs
105 return $ VHDL.createDesignFiles flatfuncs
107 -- | Write the given design file to a file with the given name inside the
109 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
110 writeVHDL dir (name, vhdl) = do
111 -- Create the dir if needed
112 exists <- Directory.doesDirectoryExist dir
113 Monad.unless exists $ Directory.createDirectory dir
115 let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
117 ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
119 -- | Loads the given file and turns it into a core module.
120 loadModule :: String -> IO HscTypes.CoreModule
121 loadModule filename =
122 defaultErrorHandler defaultDynFlags $ do
123 runGhc (Just libdir) $ do
124 dflags <- getSessionDynFlags
125 setSessionDynFlags dflags
126 --target <- guessTarget "adder.hs" Nothing
127 --liftIO (print (showSDoc (ppr (target))))
128 --liftIO $ printTarget target
129 --setTargets [target]
130 --load LoadAllTargets
131 --core <- GHC.compileToCoreSimplified "Adders.hs"
132 core <- GHC.compileToCoreSimplified filename
135 -- | Extracts the named binds from the given module.
136 findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
137 findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
139 -- | Extract a named bind from the given list of binds
140 findBind :: [CoreBind] -> String -> Maybe CoreBind
141 findBind binds lookfor =
142 -- This ignores Recs and compares the name of the bind with lookfor,
143 -- disregarding any namespaces in OccName and extra attributes in Name and
145 find (\b -> case b of
147 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
150 -- | Processes the given bind as a top level bind.
152 Bool -- ^ Should this be stateful function?
153 -> CoreBind -- ^ The bind to process
154 -> TranslatorState ()
156 processBind _ (Rec _) = error "Recursive binders not supported"
157 processBind stateful bind@(NonRec var expr) = do
158 -- Create the function signature
159 let ty = CoreUtils.exprType expr
160 let hsfunc = mkHsFunction var ty stateful
161 flattenBind hsfunc bind
163 -- | Flattens the given bind into the given signature and adds it to the
164 -- session. Then (recursively) finds any functions it uses and does the same
167 HsFunction -- The signature to flatten into
168 -> CoreBind -- The bind to flatten
169 -> TranslatorState ()
171 flattenBind _ (Rec _) = error "Recursive binders not supported"
173 flattenBind hsfunc bind@(NonRec var expr) = do
174 -- Flatten the function
175 let flatfunc = flattenFunction hsfunc bind
176 -- Propagate state variables
177 let flatfunc' = propagateState hsfunc flatfunc
178 -- Store the flat function in the session
179 modA tsFlatFuncs (Map.insert hsfunc flatfunc')
180 -- Flatten any functions used
181 let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
182 mapM_ resolvFunc used_hsfuncs
184 -- | Decide which incoming state variables will become state in the
185 -- given function, and which will be propagate to other applied
192 propagateState hsfunc flatfunc =
193 flatfunc {flat_defs = apps', flat_sigs = sigs'}
195 (olds, news) = unzip $ getStateSignals hsfunc flatfunc
196 states' = zip olds news
197 -- Find all signals used by all sigdefs
198 uses = concatMap sigDefUses (flat_defs flatfunc)
199 -- Find all signals that are used more than once (is there a
200 -- prettier way to do this?)
201 multiple_uses = uses List.\\ (List.nub uses)
202 -- Find the states whose "old state" signal is used only once
203 single_use_states = filter ((`notElem` multiple_uses) . fst) states'
204 -- See if these single use states can be propagated
205 (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
206 substate_sigs = concat substate_sigss
207 -- Mark any propagated state signals as SigSubState
209 (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
212 -- | Propagate the state into a single function application.
214 [(SignalId, SignalId)]
216 -> SigDef -- ^ The SigDef to process.
217 -> ([SignalId], SigDef)
218 -- ^ Any signal ids that should become substates,
219 -- and the resulting application.
221 propagateState' states def =
222 if (is_FApp def) then
223 (our_old ++ our_new, def {appFunc = hsfunc'})
230 our_states = filter our_state states
231 -- A state signal belongs in this function if the old state is
232 -- passed in, and the new state returned
233 our_state (old, new) =
234 any (old `Foldable.elem`) args
235 && new `Foldable.elem` res
236 (our_old, our_new) = unzip our_states
238 zipped_res = zipValueMaps res (hsFuncRes hsfunc)
239 res' = fmap (mark_state (zip our_new [0..])) zipped_res
241 zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
242 args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
243 hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
245 mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
246 mark_state states (id, use) =
247 case lookup id states of
249 Just state_id -> State state_id
251 -- | Returns pairs of signals that should be mapped to state in this function.
253 HsFunction -- | The function to look at
254 -> FlatFunction -- | The function to look at
255 -> [(SignalId, SignalId)]
256 -- | TODO The state signals. The first is the state number, the second the
257 -- signal to assign the current state to, the last is the signal
258 -- that holds the new state.
260 getStateSignals hsfunc flatfunc =
262 | (old_num, old_id) <- args
263 , (new_num, new_id) <- res
264 , old_num == new_num]
266 sigs = flat_sigs flatfunc
267 -- Translate args and res to lists of (statenum, sigid)
268 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
269 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
271 -- | Find the given function, flatten it and add it to the session. Then
272 -- (recursively) do the same for any functions used.
274 HsFunction -- | The function to look for
275 -> TranslatorState ()
277 resolvFunc hsfunc = do
278 flatfuncmap <- getA tsFlatFuncs
279 -- Don't do anything if there is already a flat function for this hsfunc or
280 -- when it is a builtin function.
281 Monad.unless (Map.member hsfunc flatfuncmap) $ do
282 Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
283 -- New function, resolve it
284 core <- getA tsCoreModule
285 -- Find the named function
286 let name = (hsFuncName hsfunc)
287 let bind = findBind (cm_binds core) name
289 Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
290 Just b -> flattenBind hsfunc b
292 -- | Translate a top level function declaration to a HsFunction. i.e., which
293 -- interface will be provided by this function. This function essentially
294 -- defines the "calling convention" for hardware models.
296 Var.Var -- ^ The function defined
297 -> Type -- ^ The function type (including arguments!)
298 -> Bool -- ^ Is this a stateful function?
299 -> HsFunction -- ^ The resulting HsFunction
301 mkHsFunction f ty stateful=
302 HsFunction hsname hsargs hsres
304 hsname = getOccString f
305 (arg_tys, res_ty) = Type.splitFunTys ty
310 -- The last argument must be state
311 state_ty = last arg_tys
312 state = useAsState (mkHsValueMap state_ty)
313 -- All but the last argument are inports
314 inports = map (useAsPort . mkHsValueMap)(init arg_tys)
315 hsargs = inports ++ [state]
316 hsres = case splitTupleType res_ty of
317 -- Result type must be a two tuple (state, ports)
318 Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
320 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
322 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
323 otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
327 -- Just use everything as a port
328 (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
330 -- | Adds signal names to the given FlatFunction
335 nameFlatFunction flatfunc =
338 s = flat_sigs flatfunc
339 s' = map nameSignal s in
340 flatfunc { flat_sigs = s' }
342 nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
343 nameSignal (id, info) =
344 let hints = nameHints info in
345 let parts = ("sig" : hints) ++ [show id] in
346 let name = concat $ List.intersperse "_" parts in
347 (id, info {sigName = Just name})
349 -- | Splits a tuple type into a list of element types, or Nothing if the type
350 -- is not a tuple type.
352 Type -- ^ The type to split
353 -> Maybe [Type] -- ^ The tuples element types
356 case Type.splitTyConApp_maybe ty of
357 Just (tycon, args) -> if TyCon.isTupleTyCon tycon
364 -- vim: set ts=8 sw=2 sts=2 expandtab: