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 Maybe
12 import qualified Module
13 import qualified Control.Monad.State as State
14 import qualified Data.Foldable as Foldable
16 import qualified Data.Map as Map
18 import NameEnv ( lookupNameEnv )
19 import qualified HscTypes
20 import HscTypes ( cm_binds, cm_types )
21 import MonadUtils ( liftIO )
22 import Outputable ( showSDoc, ppr )
23 import GHC.Paths ( libdir )
24 import DynFlags ( defaultDynFlags )
27 import qualified Monad
29 -- The following modules come from the ForSyDe project. They are really
30 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
31 -- ForSyDe to get access to these modules.
32 import qualified ForSyDe.Backend.VHDL.AST as AST
33 import qualified ForSyDe.Backend.VHDL.Ppr
34 import qualified ForSyDe.Backend.VHDL.FileIO
35 import qualified ForSyDe.Backend.Ppr
36 -- This is needed for rendering the pretty printed VHDL
37 import Text.PrettyPrint.HughesPJ (render)
39 import TranslatorTypes
48 makeVHDL "Alu.hs" "register_bank" True
50 makeVHDL :: String -> String -> Bool -> IO ()
51 makeVHDL filename name stateful = do
53 core <- loadModule filename
55 vhdl <- moduleToVHDL core [(name, stateful)]
57 let dir = "../vhdl/vhdl/" ++ name ++ "/"
58 mapM (writeVHDL dir) vhdl
61 -- | Show the core structure of the given binds in the given file.
62 listBind :: String -> String -> IO ()
63 listBind filename name = do
64 core <- loadModule filename
65 let binds = findBinds core [name]
67 putStr $ prettyShow binds
69 putStr $ showSDoc $ ppr binds
72 -- | Translate the binds with the given names from the given core module to
73 -- VHDL. The Bool in the tuple makes the function stateful (True) or
75 moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile]
76 moduleToVHDL core list = do
77 let (names, statefuls) = unzip list
78 --liftIO $ putStr $ prettyShow (cm_binds core)
79 let binds = findBinds core names
80 --putStr $ prettyShow binds
81 -- Turn bind into VHDL
82 let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty)
83 mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
84 putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
88 -- Turns the given bind into VHDL
89 mkVHDL binds statefuls = do
90 -- Add the builtin functions
91 mapM addBuiltIn builtin_funcs
92 -- Create entities and architectures for them
93 Monad.zipWithM processBind statefuls binds
94 modFuncs nameFlatFunction
95 modFuncs VHDL.createEntity
96 modFuncs VHDL.createArchitecture
99 -- | Write the given design file to a file inside the given dir
100 -- The first library unit in the designfile must be an entity, whose name
101 -- will be used as a filename.
102 writeVHDL :: String -> AST.DesignFile -> IO ()
103 writeVHDL dir vhdl = do
104 -- Create the dir if needed
105 exists <- Directory.doesDirectoryExist dir
106 Monad.unless exists $ Directory.createDirectory dir
108 let AST.DesignFile _ (u:us) = vhdl
109 let AST.LUEntity (AST.EntityDec id _) = u
110 let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
112 ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
114 -- | Loads the given file and turns it into a core module.
115 loadModule :: String -> IO HscTypes.CoreModule
116 loadModule filename =
117 defaultErrorHandler defaultDynFlags $ do
118 runGhc (Just libdir) $ do
119 dflags <- getSessionDynFlags
120 setSessionDynFlags dflags
121 --target <- guessTarget "adder.hs" Nothing
122 --liftIO (print (showSDoc (ppr (target))))
123 --liftIO $ printTarget target
124 --setTargets [target]
125 --load LoadAllTargets
126 --core <- GHC.compileToCoreSimplified "Adders.hs"
127 core <- GHC.compileToCoreSimplified filename
130 -- | Extracts the named binds from the given module.
131 findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
132 findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
134 -- | Extract a named bind from the given list of binds
135 findBind :: [CoreBind] -> String -> Maybe CoreBind
136 findBind binds lookfor =
137 -- This ignores Recs and compares the name of the bind with lookfor,
138 -- disregarding any namespaces in OccName and extra attributes in Name and
140 find (\b -> case b of
142 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
145 -- | Processes the given bind as a top level bind.
147 Bool -- ^ Should this be stateful function?
148 -> CoreBind -- ^ The bind to process
151 processBind _ (Rec _) = error "Recursive binders not supported"
152 processBind stateful bind@(NonRec var expr) = do
153 -- Create the function signature
154 let ty = CoreUtils.exprType expr
155 let hsfunc = mkHsFunction var ty stateful
156 flattenBind hsfunc bind
158 -- | Flattens the given bind into the given signature and adds it to the
159 -- session. Then (recursively) finds any functions it uses and does the same
162 HsFunction -- The signature to flatten into
163 -> CoreBind -- The bind to flatten
166 flattenBind _ (Rec _) = error "Recursive binders not supported"
168 flattenBind hsfunc bind@(NonRec var expr) = do
169 -- Add the function to the session
171 -- Flatten the function
172 let flatfunc = flattenFunction hsfunc bind
173 -- Propagate state variables
174 let flatfunc' = propagateState hsfunc flatfunc
175 -- Store the flat function in the session
176 setFlatFunc hsfunc flatfunc'
177 -- Flatten any functions used
178 let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
179 State.mapM resolvFunc used_hsfuncs
182 -- | Decide which incoming state variables will become state in the
183 -- given function, and which will be propagate to other applied
190 propagateState hsfunc flatfunc =
191 flatfunc {flat_defs = apps', flat_sigs = sigs'}
193 (olds, news) = unzip $ getStateSignals hsfunc flatfunc
194 states' = zip olds news
195 -- Find all signals used by all sigdefs
196 uses = concatMap sigDefUses (flat_defs flatfunc)
197 -- Find all signals that are used more than once (is there a
198 -- prettier way to do this?)
199 multiple_uses = uses List.\\ (List.nub uses)
200 -- Find the states whose "old state" signal is used only once
201 single_use_states = filter ((`notElem` multiple_uses) . fst) states'
202 -- See if these single use states can be propagated
203 (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
204 substate_sigs = concat substate_sigss
205 -- Mark any propagated state signals as SigSubState
207 (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
210 -- | Propagate the state into a single function application.
212 [(SignalId, SignalId)]
214 -> SigDef -- ^ The SigDef to process.
215 -> ([SignalId], SigDef)
216 -- ^ Any signal ids that should become substates,
217 -- and the resulting application.
219 propagateState' states def =
220 if (is_FApp def) then
221 (our_old ++ our_new, def {appFunc = hsfunc'})
228 our_states = filter our_state states
229 -- A state signal belongs in this function if the old state is
230 -- passed in, and the new state returned
231 our_state (old, new) =
232 any (old `Foldable.elem`) args
233 && new `Foldable.elem` res
234 (our_old, our_new) = unzip our_states
236 zipped_res = zipValueMaps res (hsFuncRes hsfunc)
237 res' = fmap (mark_state (zip our_new [0..])) zipped_res
239 zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
240 args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
241 hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
243 mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
244 mark_state states (id, use) =
245 case lookup id states of
247 Just state_id -> State state_id
249 -- | Returns pairs of signals that should be mapped to state in this function.
251 HsFunction -- | The function to look at
252 -> FlatFunction -- | The function to look at
253 -> [(SignalId, SignalId)]
254 -- | TODO The state signals. The first is the state number, the second the
255 -- signal to assign the current state to, the last is the signal
256 -- that holds the new state.
258 getStateSignals hsfunc flatfunc =
260 | (old_num, old_id) <- args
261 , (new_num, new_id) <- res
262 , old_num == new_num]
264 sigs = flat_sigs flatfunc
265 -- Translate args and res to lists of (statenum, sigid)
266 args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
267 res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
269 -- | Find the given function, flatten it and add it to the session. Then
270 -- (recursively) do the same for any functions used.
272 HsFunction -- | The function to look for
275 resolvFunc hsfunc = do
276 -- See if the function is already known
277 func <- getFunc hsfunc
279 -- Already known, do nothing
282 -- New function, resolve it
284 -- Get the current module
286 -- Find the named function
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 name = hsFuncName hsfunc
294 -- | Translate a top level function declaration to a HsFunction. i.e., which
295 -- interface will be provided by this function. This function essentially
296 -- defines the "calling convention" for hardware models.
298 Var.Var -- ^ The function defined
299 -> Type -- ^ The function type (including arguments!)
300 -> Bool -- ^ Is this a stateful function?
301 -> HsFunction -- ^ The resulting HsFunction
303 mkHsFunction f ty stateful=
304 HsFunction hsname hsargs hsres
306 hsname = getOccString f
307 (arg_tys, res_ty) = Type.splitFunTys ty
312 -- The last argument must be state
313 state_ty = last arg_tys
314 state = useAsState (mkHsValueMap state_ty)
315 -- All but the last argument are inports
316 inports = map (useAsPort . mkHsValueMap)(init arg_tys)
317 hsargs = inports ++ [state]
318 hsres = case splitTupleType res_ty of
319 -- Result type must be a two tuple (state, ports)
320 Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
322 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
324 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
325 otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
329 -- Just use everything as a port
330 (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
332 -- | Adds signal names to the given FlatFunction
338 nameFlatFunction hsfunc fdata =
339 let func = flatFunc fdata in
341 -- Skip (builtin) functions without a FlatFunction
342 Nothing -> do return ()
343 -- Name the signals in all other functions
345 let s = flat_sigs flatfunc in
346 let s' = map nameSignal s in
347 let flatfunc' = flatfunc { flat_sigs = s' } in
348 setFlatFunc hsfunc flatfunc'
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 -- | A consise representation of a (set of) ports on a builtin function
373 type PortMap = HsValueMap (String, AST.TypeMark)
374 -- | A consise representation of a builtin function
375 data BuiltIn = BuiltIn String [PortMap] PortMap
377 -- | Map a port specification of a builtin function to a VHDL Signal to put in
379 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
380 toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
382 -- | Translate a concise representation of a builtin function to something
383 -- that can be put into FuncMap directly.
384 addBuiltIn :: BuiltIn -> VHDLState ()
385 addBuiltIn (BuiltIn name args res) = do
387 setEntity hsfunc entity
389 hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
390 entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
394 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
395 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
396 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
397 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
400 -- vim: set ts=8 sw=2 sts=2 expandtab: