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 modFuncMap $ Map.map (\fdata -> fdata {flatFunc = fmap nameFlatFunction (flatFunc fdata)})
95 modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdata {funcEntity = VHDL.createEntity hsfunc fdata})
97 modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdata {funcArch = VHDL.createArchitecture funcs hsfunc fdata})
99 return $ VHDL.getDesignFiles (map snd funcs)
101 -- | Write the given design file to a file inside the given dir
102 -- The first library unit in the designfile must be an entity, whose name
103 -- will be used as a filename.
104 writeVHDL :: String -> AST.DesignFile -> IO ()
105 writeVHDL dir vhdl = do
106 -- Create the dir if needed
107 exists <- Directory.doesDirectoryExist dir
108 Monad.unless exists $ Directory.createDirectory dir
110 let AST.DesignFile _ (u:us) = vhdl
111 let AST.LUEntity (AST.EntityDec id _) = u
112 let fname = dir ++ AST.fromVHDLId id ++ ".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.compileToCoreSimplified filename
132 -- | Extracts the named binds from the given module.
133 findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
134 findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
136 -- | Extract a named bind from the given list of binds
137 findBind :: [CoreBind] -> String -> Maybe CoreBind
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 (\b -> case b of
144 NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
147 -- | Processes the given bind as a top level bind.
149 Bool -- ^ Should this be stateful function?
150 -> CoreBind -- ^ The bind to process
153 processBind _ (Rec _) = error "Recursive binders not supported"
154 processBind stateful bind@(NonRec var expr) = do
155 -- Create the function signature
156 let ty = CoreUtils.exprType expr
157 let hsfunc = mkHsFunction var ty stateful
158 flattenBind hsfunc bind
160 -- | Flattens the given bind into the given signature and adds it to the
161 -- session. Then (recursively) finds any functions it uses and does the same
164 HsFunction -- The signature to flatten into
165 -> CoreBind -- The bind to flatten
168 flattenBind _ (Rec _) = error "Recursive binders not supported"
170 flattenBind hsfunc bind@(NonRec var expr) = do
171 -- Add the function to the session
173 -- Flatten the function
174 let flatfunc = flattenFunction hsfunc bind
175 -- Propagate state variables
176 let flatfunc' = propagateState hsfunc flatfunc
177 -- Store the flat function in the session
178 setFlatFunc hsfunc flatfunc'
179 -- Flatten any functions used
180 let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
181 State.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
277 resolvFunc hsfunc = do
278 -- See if the function is already known
279 func <- getFunc hsfunc
281 -- Already known, do nothing
284 -- New function, resolve it
286 -- Get the current module
288 -- Find the named function
289 let bind = findBind (cm_binds core) name
291 Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
292 Just b -> flattenBind hsfunc b
294 name = hsFuncName hsfunc
296 -- | Translate a top level function declaration to a HsFunction. i.e., which
297 -- interface will be provided by this function. This function essentially
298 -- defines the "calling convention" for hardware models.
300 Var.Var -- ^ The function defined
301 -> Type -- ^ The function type (including arguments!)
302 -> Bool -- ^ Is this a stateful function?
303 -> HsFunction -- ^ The resulting HsFunction
305 mkHsFunction f ty stateful=
306 HsFunction hsname hsargs hsres
308 hsname = getOccString f
309 (arg_tys, res_ty) = Type.splitFunTys ty
314 -- The last argument must be state
315 state_ty = last arg_tys
316 state = useAsState (mkHsValueMap state_ty)
317 -- All but the last argument are inports
318 inports = map (useAsPort . mkHsValueMap)(init arg_tys)
319 hsargs = inports ++ [state]
320 hsres = case splitTupleType res_ty of
321 -- Result type must be a two tuple (state, ports)
322 Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
324 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
326 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
327 otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
331 -- Just use everything as a port
332 (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
334 -- | Adds signal names to the given FlatFunction
339 nameFlatFunction flatfunc =
342 s = flat_sigs flatfunc
343 s' = map nameSignal s in
344 flatfunc { flat_sigs = s' }
346 nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
347 nameSignal (id, info) =
348 let hints = nameHints info in
349 let parts = ("sig" : hints) ++ [show id] in
350 let name = concat $ List.intersperse "_" parts in
351 (id, info {sigName = Just name})
353 -- | Splits a tuple type into a list of element types, or Nothing if the type
354 -- is not a tuple type.
356 Type -- ^ The type to split
357 -> Maybe [Type] -- ^ The tuples element types
360 case Type.splitTyConApp_maybe ty of
361 Just (tycon, args) -> if TyCon.isTupleTyCon tycon
368 -- | A consise representation of a (set of) ports on a builtin function
369 type PortMap = HsValueMap (String, AST.TypeMark)
370 -- | A consise representation of a builtin function
371 data BuiltIn = BuiltIn String [PortMap] PortMap
373 -- | Map a port specification of a builtin function to a VHDL Signal to put in
375 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
376 toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
378 -- | Translate a concise representation of a builtin function to something
379 -- that can be put into FuncMap directly.
380 addBuiltIn :: BuiltIn -> VHDLState ()
381 addBuiltIn (BuiltIn name args res) = do
383 setEntity hsfunc entity
385 hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
386 entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing Nothing
390 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
391 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
392 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
393 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
396 -- vim: set ts=8 sw=2 sts=2 expandtab: