module Translator where
-import GHC hiding (loadModule)
+import qualified Directory
+import qualified List
+import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
import qualified Var
import qualified Maybe
import qualified Module
import qualified Control.Monad.State as State
+import qualified Data.Foldable as Foldable
import Name
import qualified Data.Map as Map
import Data.Generics
import qualified VHDL
main = do
- makeVHDL "Alu.hs" "salu"
+ makeVHDL "Alu.hs" "register_bank" True
-makeVHDL :: String -> String -> IO ()
-makeVHDL filename name = do
+makeVHDL :: String -> String -> Bool -> IO ()
+makeVHDL filename name stateful = do
-- Load the module
core <- loadModule filename
-- Translate to VHDL
- vhdl <- moduleToVHDL core [name]
+ vhdl <- moduleToVHDL core [(name, stateful)]
-- Write VHDL to file
- writeVHDL vhdl "../vhdl/vhdl/output.vhdl"
+ let dir = "../vhdl/vhdl/" ++ name ++ "/"
+ mapM (writeVHDL dir) vhdl
+ return ()
-- | Show the core structure of the given binds in the given file.
listBind :: String -> String -> IO ()
putStr "\n"
putStr $ prettyShow binds
putStr "\n\n"
+ putStr $ showSDoc $ ppr binds
+ putStr "\n\n"
-- | Translate the binds with the given names from the given core module to
--- VHDL
-moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO AST.DesignFile
-moduleToVHDL core names = do
+-- VHDL. The Bool in the tuple makes the function stateful (True) or
+-- stateless (False).
+moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile]
+moduleToVHDL core list = do
+ let (names, statefuls) = unzip list
--liftIO $ putStr $ prettyShow (cm_binds core)
let binds = findBinds core names
--putStr $ prettyShow binds
-- Turn bind into VHDL
- let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
- putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
+ let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty)
+ mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
where
-- Turns the given bind into VHDL
- mkVHDL binds = do
+ mkVHDL binds statefuls = do
-- Add the builtin functions
mapM addBuiltIn builtin_funcs
-- Create entities and architectures for them
- mapM processBind binds
+ Monad.zipWithM processBind statefuls binds
modFuncs nameFlatFunction
modFuncs VHDL.createEntity
modFuncs VHDL.createArchitecture
- VHDL.getDesignFile
+ VHDL.getDesignFiles
--- | Write the given design file to the given file
-writeVHDL :: AST.DesignFile -> String -> IO ()
-writeVHDL = ForSyDe.Backend.VHDL.FileIO.writeDesignFile
+-- | Write the given design file to a file inside the given dir
+-- The first library unit in the designfile must be an entity, whose name
+-- will be used as a filename.
+writeVHDL :: String -> AST.DesignFile -> IO ()
+writeVHDL dir vhdl = do
+ -- Create the dir if needed
+ exists <- Directory.doesDirectoryExist dir
+ Monad.unless exists $ Directory.createDirectory dir
+ -- Find the filename
+ let AST.DesignFile _ (u:us) = vhdl
+ let AST.LUEntity (AST.EntityDec id _) = u
+ let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
+ -- Write the file
+ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
-- | Loads the given file and turns it into a core module.
loadModule :: String -> IO HscTypes.CoreModule
-- | Processes the given bind as a top level bind.
processBind ::
- CoreBind -- The bind to process
+ Bool -- ^ Should this be stateful function?
+ -> CoreBind -- ^ The bind to process
-> VHDLState ()
-processBind (Rec _) = error "Recursive binders not supported"
-processBind bind@(NonRec var expr) = do
+processBind _ (Rec _) = error "Recursive binders not supported"
+processBind stateful bind@(NonRec var expr) = do
-- Create the function signature
let ty = CoreUtils.exprType expr
- let hsfunc = mkHsFunction var ty
+ let hsfunc = mkHsFunction var ty stateful
flattenBind hsfunc bind
-- | Flattens the given bind into the given signature and adds it to the
flattenBind _ (Rec _) = error "Recursive binders not supported"
flattenBind hsfunc bind@(NonRec var expr) = do
+ -- Add the function to the session
+ addFunc hsfunc
-- Flatten the function
let flatfunc = flattenFunction hsfunc bind
- addFunc hsfunc
- setFlatFunc hsfunc flatfunc
- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc)
+ -- Propagate state variables
+ let flatfunc' = propagateState hsfunc flatfunc
+ -- Store the flat function in the session
+ setFlatFunc hsfunc flatfunc'
+ -- Flatten any functions used
+ let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
State.mapM resolvFunc used_hsfuncs
return ()
+-- | Decide which incoming state variables will become state in the
+-- given function, and which will be propagate to other applied
+-- functions.
+propagateState ::
+ HsFunction
+ -> FlatFunction
+ -> FlatFunction
+
+propagateState hsfunc flatfunc =
+ flatfunc {flat_defs = apps', flat_sigs = sigs'}
+ where
+ apps = filter is_FApp (flat_defs flatfunc)
+ (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+ states' = zip olds news
+ -- Find all signals used by all sigdefs
+ uses = concatMap sigDefUses (flat_defs flatfunc)
+ -- Find all signals that are used more than once (is there a
+ -- prettier way to do this?)
+ multiple_uses = uses List.\\ (List.nub uses)
+ -- Find the states whose "old state" signal is used only once
+ single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+ -- See if these single use states can be propagated
+ (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) apps
+ substate_sigs = concat substate_sigss
+ -- Mark any propagated state signals as SigSubState
+ sigs' = map
+ (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+ (flat_sigs flatfunc)
+
+-- | Propagate the state into a single function application.
+propagateState' ::
+ [(SignalId, SignalId)]
+ -- ^ TODO
+ -> SigDef -- ^ The function application to process. Must be
+ -- a FApp constructor.
+ -> ([SignalId], SigDef)
+ -- ^ Any signal ids that should become substates,
+ -- and the resulting application.
+
+propagateState' states app =
+ (our_old ++ our_new, app {appFunc = hsfunc'})
+ where
+ hsfunc = appFunc app
+ args = appArgs app
+ res = appRes app
+ our_states = filter our_state states
+ -- A state signal belongs in this function if the old state is
+ -- passed in, and the new state returned
+ our_state (old, new) =
+ any (old `Foldable.elem`) args
+ && new `Foldable.elem` res
+ (our_old, our_new) = unzip our_states
+ -- Mark the result
+ zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+ res' = fmap (mark_state (zip our_new [0..])) zipped_res
+ -- Mark the args
+ zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+ args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+ hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+
+ mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+ mark_state states (id, use) =
+ case lookup id states of
+ Nothing -> use
+ Just state_id -> State state_id
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+getStateSignals ::
+ HsFunction -- | The function to look at
+ -> FlatFunction -- | The function to look at
+ -> [(SignalId, SignalId)]
+ -- | TODO The state signals. The first is the state number, the second the
+ -- signal to assign the current state to, the last is the signal
+ -- that holds the new state.
+
+getStateSignals hsfunc flatfunc =
+ [(old_id, new_id)
+ | (old_num, old_id) <- args
+ , (new_num, new_id) <- res
+ , old_num == new_num]
+ where
+ sigs = flat_sigs flatfunc
+ -- Translate args and res to lists of (statenum, sigid)
+ args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+ res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+
-- | Find the given function, flatten it and add it to the session. Then
-- (recursively) do the same for any functions used.
resolvFunc ::
mkHsFunction ::
Var.Var -- ^ The function defined
-> Type -- ^ The function type (including arguments!)
+ -> Bool -- ^ Is this a stateful function?
-> HsFunction -- ^ The resulting HsFunction
-mkHsFunction f ty =
+mkHsFunction f ty stateful=
HsFunction hsname hsargs hsres
where
hsname = getOccString f
(arg_tys, res_ty) = Type.splitFunTys ty
- -- The last argument must be state
- state_ty = last arg_tys
- state = useAsState (mkHsValueMap state_ty)
- -- All but the last argument are inports
- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
- hsargs = inports ++ [state]
- hsres = case splitTupleType res_ty of
- -- Result type must be a two tuple (state, ports)
- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
- then
- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
- else
- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+ (hsargs, hsres) =
+ if stateful
+ then
+ let
+ -- The last argument must be state
+ state_ty = last arg_tys
+ state = useAsState (mkHsValueMap state_ty)
+ -- All but the last argument are inports
+ inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+ hsargs = inports ++ [state]
+ hsres = case splitTupleType res_ty of
+ -- Result type must be a two tuple (state, ports)
+ Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+ then
+ Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+ else
+ error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+ otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+ in
+ (hsargs, hsres)
+ else
+ -- Just use everything as a port
+ (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
-- | Adds signal names to the given FlatFunction
nameFlatFunction ::
-- Name the signals in all other functions
Just flatfunc ->
let s = flat_sigs flatfunc in
- let s' = map (\(id, (SignalInfo Nothing use ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) use ty)) s in
+ let s' = map nameSignal s in
let flatfunc' = flatfunc { flat_sigs = s' } in
setFlatFunc hsfunc flatfunc'
+ where
+ nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+ nameSignal (id, info) =
+ let hints = nameHints info in
+ let parts = ("sig" : hints) ++ [show id] in
+ let name = concat $ List.intersperse "_" parts in
+ (id, info {sigName = Just name})
-- | Splits a tuple type into a list of element types, or Nothing if the type
-- is not a tuple type.
projects / matthijs / master-project / cλash.git / blobdiff