module Translator where
+import qualified Directory
import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
import qualified VHDL
main = do
- makeVHDL "Alu.hs" "register_bank"
+ 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
- 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.
let binds = findBinds core [name]
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)
+ 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
-- 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.
-- | 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'}
+ where
+ apps = filter is_FApp (flat_defs flatfunc)
+ apps' = map (propagateState' ()) apps
+
+-- | Propagate the state into a single function application.
+propagateState' ::
+ ()
+ -> SigDef -- ^ The function application to process. Must be
+ -- a FApp constructor.
+ -> SigDef -- ^ The resulting application.
+
+propagateState' _ d = d
+
-- | 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 ::
projects / matthijs / master-project / cλash.git / blobdiff