import qualified DataCon
import qualified Maybe
import qualified Module
-import qualified Control.Monad.State as State
import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State as State
import Name
import qualified Data.Map as Map
+import Data.Accessor
import Data.Generics
import NameEnv ( lookupNameEnv )
import qualified HscTypes
-- | Translate the binds with the given names from the given core module to
-- VHDL. The Bool in the tuple makes the function stateful (True) or
-- stateless (False).
-moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile]
+moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, 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 statefuls) (VHDLSession core 0 Map.empty)
- mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
+ let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
+ mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
-
where
-- Turns the given bind into VHDL
+ mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
mkVHDL binds statefuls = do
-- Add the builtin functions
- mapM addBuiltIn builtin_funcs
+ --mapM addBuiltIn builtin_funcs
-- Create entities and architectures for them
Monad.zipWithM processBind statefuls binds
- modFuncs nameFlatFunction
- modFuncs VHDL.createEntity
- modFuncs VHDL.createArchitecture
- VHDL.getDesignFiles
-
--- | 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
+ modA tsFlatFuncs (Map.map nameFlatFunction)
+ flatfuncs <- getA tsFlatFuncs
+ return $ VHDL.createDesignFiles flatfuncs
+
+-- | Write the given design file to a file with the given name inside the
+-- given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, 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"
+ let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
-- Write the file
ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
processBind ::
Bool -- ^ Should this be stateful function?
-> CoreBind -- ^ The bind to process
- -> VHDLState ()
+ -> TranslatorState ()
processBind _ (Rec _) = error "Recursive binders not supported"
processBind stateful bind@(NonRec var expr) = do
flattenBind ::
HsFunction -- The signature to flatten into
-> CoreBind -- The bind to flatten
- -> VHDLState ()
+ -> TranslatorState ()
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
-- Propagate state variables
let flatfunc' = propagateState hsfunc flatfunc
-- Store the flat function in the session
- setFlatFunc hsfunc flatfunc'
+ modA tsFlatFuncs (Map.insert hsfunc flatfunc)
-- Flatten any functions used
let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
- State.mapM resolvFunc used_hsfuncs
- return ()
+ mapM_ resolvFunc used_hsfuncs
-- | Decide which incoming state variables will become state in the
-- given function, and which will be propagate to other applied
-- (recursively) do the same for any functions used.
resolvFunc ::
HsFunction -- | The function to look for
- -> VHDLState ()
+ -> TranslatorState ()
resolvFunc hsfunc = do
- -- See if the function is already known
- func <- getFunc hsfunc
- case func of
- -- Already known, do nothing
- Just _ -> do
- return ()
- -- New function, resolve it
- Nothing -> do
- -- Get the current module
- core <- getModule
- -- Find the named function
- let bind = findBind (cm_binds core) name
- case bind of
- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
- Just b -> flattenBind hsfunc b
- where
- name = hsFuncName hsfunc
+ flatfuncmap <- getA tsFlatFuncs
+ -- Don't do anything if there is already a flat function for this hsfunc.
+ Monad.unless (Map.member hsfunc flatfuncmap) $ do
+ -- TODO: Builtin functions
+ -- New function, resolve it
+ core <- getA tsCoreModule
+ -- Find the named function
+ let name = (hsFuncName hsfunc)
+ let bind = findBind (cm_binds core) name
+ case bind of
+ Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+ Just b -> flattenBind hsfunc b
-- | Translate a top level function declaration to a HsFunction. i.e., which
-- interface will be provided by this function. This function essentially
-- | Adds signal names to the given FlatFunction
nameFlatFunction ::
- HsFunction
- -> FuncData
- -> VHDLState ()
-
-nameFlatFunction hsfunc fdata =
- let func = flatFunc fdata in
- case func of
- -- Skip (builtin) functions without a FlatFunction
- Nothing -> do return ()
- -- Name the signals in all other functions
- Just flatfunc ->
- let s = flat_sigs flatfunc in
- let s' = map nameSignal s in
- let flatfunc' = flatfunc { flat_sigs = s' } in
- setFlatFunc hsfunc flatfunc'
+ FlatFunction
+ -> FlatFunction
+
+nameFlatFunction flatfunc =
+ -- Name the signals
+ let
+ s = flat_sigs flatfunc
+ s' = map nameSignal s in
+ flatfunc { flat_sigs = s' }
where
nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
nameSignal (id, info) =
-- | Translate a concise representation of a builtin function to something
-- that can be put into FuncMap directly.
-addBuiltIn :: BuiltIn -> VHDLState ()
+{-
+addBuiltIn :: BuiltIn -> TranslatorState ()
addBuiltIn (BuiltIn name args res) = do
addFunc hsfunc
setEntity hsfunc entity
BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
]
-
+-}
-- vim: set ts=8 sw=2 sts=2 expandtab:
projects / matthijs / master-project / cλash.git / blobdiff