module Translator where
-import GHC hiding (loadModule)
+import qualified Directory
+import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
import qualified Var
import qualified VHDL
main = do
+ makeVHDL "Alu.hs" "register_bank" True
+
+makeVHDL :: String -> String -> Bool -> IO ()
+makeVHDL filename name stateful = do
-- Load the module
- core <- loadModule "Alu.hs"
+ core <- loadModule filename
-- Translate to VHDL
- vhdl <- moduleToVHDL core ["salu"]
+ 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
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