import qualified Maybe
import qualified Monad
import qualified System.FilePath as FilePath
+import qualified Control.Monad.Trans.State as State
import Text.PrettyPrint.HughesPJ (render)
+import Data.Accessor
+import qualified Data.Map as Map
-- GHC API
import qualified CoreSyn
-- Local Imports
import CLasH.Normalize
+import CLasH.Translator.TranslatorTypes
import CLasH.Translator.Annotations
+import CLasH.Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.GhcTools
import CLasH.VHDL
+import CLasH.VHDL.Testbench
-- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
-- State and Test Inputs.
-> String -- ^ The TopEntity
-> String -- ^ The InitState
-> String -- ^ The TestInput
- -> Bool -- ^ Is it stateful? (in case InitState is empty)
-> IO ()
-makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
- makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+makeVHDLStrings libdir filenames topentity initstate testinput = do
+ makeVHDL libdir filenames finder
where
- findTopEntity = findBind (hasVarName topentity)
- findInitState = findBind (hasVarName initstate)
- findTestInput = findExpr (hasVarName testinput)
+ finder = findSpec (hasVarName topentity)
+ (hasVarName initstate)
+ (hasVarName testinput)
-- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
-- and Test Inputs found in the Files.
makeVHDLAnnotations ::
FilePath -- ^ The GHC Library Dir
-> [FilePath] -- ^ The FileNames
- -> Bool -- ^ Is it stateful? (in case InitState is not specified)
-> IO ()
-makeVHDLAnnotations libdir filenames stateful = do
- makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+makeVHDLAnnotations libdir filenames = do
+ makeVHDL libdir filenames finder
where
- findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
- findInitState = findBind (hasCLasHAnnotation isInitState)
- findTestInput = findExpr (hasCLasHAnnotation isTestInput)
+ finder = findSpec (hasCLasHAnnotation isTopEntity)
+ (hasCLasHAnnotation isInitState)
+ (hasCLasHAnnotation isTestInput)
-- | Turn Haskell to VHDL, using the given finder functions to find the Top
-- Entity, Initial State and Test Inputs in the Haskell Files.
makeVHDL ::
FilePath -- ^ The GHC Library Dir
-> [FilePath] -- ^ The Filenames
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
- -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
- -> Bool -- ^ Indicates if it is meant to be stateful
+ -> Finder
-> IO ()
-makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
+makeVHDL libdir filenames finder = do
-- Load the modules
- (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
+ (cores, env, specs) <- loadModules libdir filenames (Just finder)
-- Translate to VHDL
- vhdl <- moduleToVHDL env cores top init test stateful
- -- Write VHDL to file
- let top_entity = Maybe.fromJust $ head top
+ vhdl <- moduleToVHDL env cores specs
+ -- Write VHDL to file. Just use the first entity for the name
+ let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
let dir = "./vhdl/" ++ (show top_entity) ++ "/"
prepareDir dir
mapM (writeVHDL dir) vhdl
return ()
--- | 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).
+-- | Translate the specified entities in the given modules to VHDL.
moduleToVHDL ::
HscTypes.HscEnv -- ^ The GHC Environment
-> [HscTypes.CoreModule] -- ^ The Core Modules
- -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
- -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
- -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
- -> Bool -- ^ Is it stateful (in case InitState is not specified)
+ -> [EntitySpec] -- ^ The entities to generate
-> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env cores top init test stateful = do
- let topEntity = Maybe.catMaybes top
- case topEntity of
- [] -> error "Top Entity Not Found"
- [topEnt] -> do
- let initialState = Maybe.catMaybes init
- let isStateful = not (null initialState) || stateful
- let testInput = Maybe.catMaybes test
- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
- let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
- let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
- let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
- let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
- mapM (putStr . render . Ppr.ppr . snd) vhdl
- return vhdl
- xs -> error "More than one topentity found"
+moduleToVHDL env cores specs = do
+ vhdl <- runTranslatorSession env $ do
+ let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
+ -- Store the bindings we loaded
+ tsBindings %= Map.fromList all_bindings
+ test_binds <- catMaybesM $ Monad.mapM mkTest specs
+ let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
+ case topbinds of
+ [] -> error $ "Could not find top entity requested"
+ tops -> createDesignFiles (tops ++ test_binds)
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ return vhdl
+ where
+ mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
+ -- Create a testbench for any entry that has test input
+ mkTest (_, _, Nothing) = return Nothing
+ mkTest (Nothing, _, _) = return Nothing
+ mkTest (Just top, _, Just input) = do
+ bndr <- createTestbench Nothing cores input top
+ return $ Just bndr
+
+-- Run the given translator session. Generates a new UniqSupply for that
+-- session.
+runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
+runTranslatorSession env session = do
+ -- Generate a UniqSupply
+ -- Running
+ -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ -- on the compiler dir of ghc suggests that 'z' is not used to generate
+ -- a unique supply anywhere.
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
+ let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty Map.empty Map.empty
+ return $ State.evalState session init_state
-- | Prepares the directory for writing VHDL files. This means creating the
-- dir if it does not exist and removing all existing .vhdl files from it.
projects / matthijs / master-project / cλash.git / blobdiff