X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FTranslator.hs;h=a9bb9fa4cfed041f1ba5b69d6b82fe4b75857689;hb=0223b461a043e42d3fc5442904b73ce0bd537472;hp=e22164644f74e4ab4bd0579b017f1ac59d2c6011;hpb=145d53c11af82f2e2c2df41a56e0b05f45f91952;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index e221646..a9bb9fa 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -1,125 +1,144 @@ -{-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-} - -module CLasH.Translator (makeVHDLStrings, makeVHDLAnnotations) where +module CLasH.Translator + ( + makeVHDLAnnotations + ) where -- Standard Modules -import qualified Directory +import qualified System.Directory as Directory 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.Monad.Trans.State +import qualified Data.Map as Map +import qualified Data.Time.Clock as Clock +import Debug.Trace -- GHC API -import qualified Annotations -import CoreSyn -import DynFlags ( defaultDynFlags ) -import GHC hiding (loadModule, sigName) +import qualified CoreSyn import qualified HscTypes -import HscTypes ( cm_binds, cm_types ) -import Name -import qualified Serialized import qualified UniqSupply -import qualified Var -- VHDL Imports import qualified Language.VHDL.AST as AST -import qualified Language.VHDL.FileIO +import qualified Language.VHDL.FileIO as FileIO import qualified Language.VHDL.Ppr as Ppr -- Local Imports +import CLasH.Translator.TranslatorTypes import CLasH.Translator.Annotations -import CLasH.Normalize -import CLasH.Utils.Core.CoreTools +import CLasH.Utils +import CLasH.Utils.GhcTools import CLasH.VHDL +import CLasH.VHDL.VHDLTools +import CLasH.VHDL.Testbench -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial -- State and Test Inputs. -makeVHDLStrings :: - FilePath -- ^ The GHC Library Dir - -> [FilePath] -- ^ The FileNames - -> 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 - where - findTopEntity = findBind (hasVarName topentity) - findInitState = findBind (hasVarName initstate) - findTestInput = findExpr (hasVarName testinput) +-- makeVHDLStrings :: +-- FilePath -- ^ The GHC Library Dir +-- -> [FilePath] -- ^ The FileNames +-- -> String -- ^ The TopEntity +-- -> String -- ^ The InitState +-- -> String -- ^ The TestInput +-- -> IO () +-- makeVHDLStrings libdir filenames topentity initstate testinput = do +-- makeVHDL libdir filenames finder +-- where +-- finder = findSpec (hasVarName topentity) +-- (hasVarName initstate) +-- (isCLasHAnnotation isInitState) +-- (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 = + makeVHDL libdir filenames finder where - findTopEntity = findBind (hasCLasHAnnotation isTopEntity) - findInitState = findBind (hasCLasHAnnotation isInitState) - findTestInput = findExpr (hasCLasHAnnotation isTestInput) + finder = findSpec (hasCLasHAnnotation isTopEntity) + (hasCLasHAnnotation isInitState) + (isCLasHAnnotation 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 (Maybe CoreBndr)) -- ^ The Top Entity Finder - -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Init State Finder - -> (HscTypes.CoreModule -> Ghc (Maybe 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 + start <- Clock.getCurrentTime -- 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 () + mapM_ (writeVHDL dir) vhdl + end <- Clock.getCurrentTime + trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $ + 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 CoreBndr] -- ^ The TopEntity - -> [Maybe CoreBndr] -- ^ The InitState - -> [Maybe CoreExpr] -- ^ The TestInput - -> Bool -- ^ Is it stateful (in case InitState is not specified) + HscTypes.HscEnv -- ^ The GHC Environment + -> [HscTypes.CoreModule] -- ^ The Core Modules + -> [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 (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, count) <- runTranslatorSession env $ do + let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores + -- Store the bindings we loaded + tsBindings %= Map.fromList all_bindings + let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs + tsInitStates %= Map.fromList all_initstates + test_binds <- catMaybesM $ Monad.mapM mkTest specs + let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs + vhdl <- case topbinds of + [] -> error "Could not find top entity requested" + tops -> createDesignFiles (tops ++ test_binds) + count <- get tsTransformCounter + return (vhdl, count) + mapM_ (putStr . render . Ppr.ppr . snd) vhdl + putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n" + 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 builtin_types [] Map.empty Map.empty env + let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0 + 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. prepareDir :: String -> IO() prepareDir dir = do -- Create the dir if needed - exists <- Directory.doesDirectoryExist dir - Monad.unless exists $ Directory.createDirectory dir + Directory.createDirectoryIfMissing True dir -- Find all .vhdl files in the directory files <- Directory.getDirectoryContents dir let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files @@ -135,78 +154,6 @@ writeVHDL dir (name, vhdl) = do -- Find the filename let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl" -- Write the file - Language.VHDL.FileIO.writeDesignFile vhdl fname - --- | Loads the given files and turns it into a core module -loadModules :: - FilePath -- ^ The GHC Library directory - -> [String] -- ^ The files that need to be loaded - -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder - -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder - -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder - -> IO ( [HscTypes.CoreModule] -- ^ The loaded modules - , [Maybe CoreBndr] -- ^ The TopEntity - , [Maybe CoreBndr] -- ^ The InitState - , [Maybe CoreExpr] -- ^ The TestInput - , HscTypes.HscEnv -- ^ The Environment corresponding ot the loaded modules - ) -loadModules libdir filenames topEntLoc initSLoc testLoc = - defaultErrorHandler defaultDynFlags $ do - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - cores <- mapM GHC.compileToCoreModule filenames - env <- GHC.getSession - top_entity <- mapM topEntLoc cores - init_state <- mapM initSLoc cores - test_input <- mapM testLoc cores - return (cores, top_entity, init_state, test_input, env) - --- | Find a binder in module according to a certain criteria -findBind :: - GhcMonad m => -- ^ Expected to be run in some kind of GHC Monad - (Var.Var -> m Bool) -- ^ The criteria to filter the binds on - -> HscTypes.CoreModule -- ^ The module to be inspected - -> m (Maybe CoreBndr) -- ^ The (first) bind to meet the criteria -findBind annotation core = do - let binds = CoreSyn.flattenBinds $ cm_binds core - annbinds <- Monad.filterM (annotation . fst) binds - let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds) - return bndr - --- | Find an expresion in module according to a certain criteria -findExpr :: - GhcMonad m => -- ^ Expected to be run in some kind off GHC Monad - (Var.Var -> m Bool) -- ^ The criteria to filter the binds on - -> HscTypes.CoreModule -- ^ The module to be inspected - -> m (Maybe CoreExpr) -- ^ The (first) expr to meet the criteria -findExpr annotation core = do - let binds = CoreSyn.flattenBinds $ cm_binds core - annbinds <- Monad.filterM (annotation . fst) binds - let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds) - return exprs - --- | Determine if a binder has an Annotation meeting a certain criteria -hasCLasHAnnotation :: - GhcMonad m => -- ^ Expected to be run in some kind of GHC Monad - (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet - -> Var.Var -- ^ The Binder - -> m Bool -- ^ Indicates if binder has the Annotation -hasCLasHAnnotation clashAnn var = do - let deserializer = Serialized.deserializeWithData - let target = Annotations.NamedTarget (Var.varName var) - (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target - let annEnts = filter clashAnn anns - case annEnts of - [] -> return False - xs -> return True - --- | Determine if a binder has a certain name -hasVarName :: - GhcMonad m => -- ^ Exprected to be run in some kind of GHC Monad - String -- ^ The name the binder has to have - -> Var.Var -- ^ The Binder - -> m Bool -- ^ Indicate if the binder has the name -hasVarName lookfor bind = return $ lookfor == (occNameString $ nameOccName $ getName bind) + FileIO.writeDesignFile vhdl fname -- vim: set ts=8 sw=2 sts=2 expandtab: