module Translator where
+import qualified Directory
+import qualified List
import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
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
-- Translate to VHDL
vhdl <- moduleToVHDL core [(name, stateful)]
-- Write VHDL to file
- mapM (writeVHDL "../vhdl/vhdl/") vhdl
+ let dir = "../vhdl/vhdl/" ++ name ++ "/"
+ mapM (writeVHDL dir) vhdl
return ()
-- | Show the core structure of the given binds in the given file.
-- 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.
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
+ (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) (flat_defs flatfunc)
+ 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 SigDef to process.
+ -> ([SignalId], SigDef)
+ -- ^ Any signal ids that should become substates,
+ -- and the resulting application.
+
+propagateState' states def =
+ if (is_FApp def) then
+ (our_old ++ our_new, def {appFunc = hsfunc'})
+ else
+ ([], def)
+ where
+ hsfunc = appFunc def
+ args = appArgs def
+ res = appRes def
+ 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 ::
setEntity hsfunc entity
where
hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
- entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
+ entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing Nothing
builtin_funcs =
[
projects / matthijs / master-project / cλash.git / blobdiff