From: Matthijs Kooijman Date: Wed, 5 Aug 2009 15:04:48 +0000 (+0200) Subject: Restructure the "finder" functions. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=adf357ab8731531dfea0a21254cfc613031e083a;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Restructure the "finder" functions. Previously, there were three different functions for the top entity, initial state and test input. Now, there is just a single one, which guarantees that these things are properly linked together. This should no also support generating multiple entities at the same time (though there is no top level interface for this yet). This change also makes the testbench generation optional. A bunch of functions were moved from Utils to GhcTools, to prevent a dependency loop. --- diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index fb02355..c4daf04 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -28,6 +28,7 @@ import qualified Language.VHDL.Ppr as Ppr 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 @@ -44,11 +45,11 @@ makeVHDLStrings :: -> 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 + makeVHDL libdir filenames finder stateful 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. @@ -58,29 +59,27 @@ makeVHDLAnnotations :: -> Bool -- ^ Is it stateful? (in case InitState is not specified) -> IO () makeVHDLAnnotations libdir filenames stateful = do - makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful + makeVHDL libdir filenames finder stateful 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 + -> Finder -> Bool -- ^ Indicates if it is meant to be stateful -> IO () -makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do +makeVHDL libdir filenames finder stateful = 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 stateful + -- Write VHDL to file. Just use the first entity for the name + let top_entity = (\(t, _, _) -> t) $ head specs let dir = "./vhdl/" ++ (show top_entity) ++ "/" prepareDir dir mapM (writeVHDL dir) vhdl @@ -92,23 +91,26 @@ makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful 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 + -> [EntitySpec] -- ^ The entities to generate -> Bool -- ^ Is it stateful (in case InitState is not specified) -> IO [(AST.VHDLId, AST.DesignFile)] -moduleToVHDL env cores topbinds' init test stateful = do - let topbinds = Maybe.catMaybes topbinds' - let initialState = Maybe.catMaybes init - let testInput = Maybe.catMaybes test +moduleToVHDL env cores specs stateful = 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 <- Monad.zipWithM (createTestbench Nothing) testInput topbinds + test_binds <- catMaybesM $ Monad.mapM mkTest specs + let topbinds = map (\(top, _, _) -> top) specs createDesignFiles (topbinds ++ 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 (top, _, Just input) = do + bndr <- createTestbench Nothing input top + return $ Just bndr -- Run the given translator session. Generates a new UniqSupply for that -- session. diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index de7ee52..257c543 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -12,6 +12,7 @@ import qualified Data.Accessor.Template import Data.Accessor -- GHC API +import qualified GHC import qualified CoreSyn import qualified Type import qualified HscTypes @@ -23,6 +24,20 @@ import qualified Language.VHDL.AST as AST -- Local imports import CLasH.VHDL.VHDLTypes +-- | A specification of an entity we can generate VHDL for. Consists of the +-- binder of the top level entity, an optional initial state and an optional +-- test input. +type EntitySpec = (CoreSyn.CoreBndr, Maybe CoreSyn.CoreExpr, Maybe CoreSyn.CoreExpr) + +-- | A function that knows which parts of a module to compile +type Finder = + HscTypes.CoreModule -- ^ The module to look at + -> GHC.Ghc [EntitySpec] + +----------------------------------------------------------------------------- +-- The TranslatorSession +----------------------------------------------------------------------------- + -- A orderable equivalent of CoreSyn's Type for use as a map key newtype OrdType = OrdType { getType :: Type.Type } instance Eq OrdType where diff --git "a/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" index 731de27..484fe15 100644 --- "a/c\316\273ash/CLasH/Utils.hs" +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -8,47 +8,9 @@ import qualified Control.Monad as Monad import qualified Control.Monad.Trans.State as State -- GHC API -import qualified CoreSyn -import qualified CoreUtils -import qualified HscTypes -import qualified Outputable -import qualified Var -- Local Imports -import CLasH.Utils.GhcTools -import CLasH.Utils.Pretty -listBindings :: FilePath -> [FilePath] -> IO [()] -listBindings libdir filenames = do - (cores,_,_,_,_) <- loadModules libdir filenames bogusFinder bogusFinder bogusFinder - let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores - mapM (listBinding) binds - where - bogusFinder = (\x -> return $ Nothing) - -listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () -listBinding (b, e) = do - putStr "\nBinder: " - putStr $ show b - putStr "\nType of Binder: \n" - putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b - putStr "\n\nExpression: \n" - putStr $ prettyShow e - putStr "\n\n" - putStr $ Outputable.showSDoc $ Outputable.ppr e - putStr "\n\nType of Expression: \n" - putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e - putStr "\n\n" - --- | Show the core structure of the given binds in the given file. -listBind :: FilePath -> [FilePath] -> String -> IO () -listBind libdir filenames name = do - (_,corebind,_,coreexpr,_) <- loadModules libdir filenames bindFinder bindFinder exprFinder - listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr) - where - bindFinder = findBind (hasVarName name) - exprFinder = findExpr (hasVarName name) - -- Make a caching version of a stateful computatation. makeCached :: (Monad m, Ord k) => k -- ^ The key to use for the cache diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 0c8c559..5a041cc 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -9,15 +9,48 @@ import qualified System.IO.Unsafe -- GHC API import qualified Annotations import qualified CoreSyn +import qualified CoreUtils import qualified DynFlags import qualified HscTypes import qualified GHC import qualified Name import qualified Serialized import qualified Var +import qualified Outputable -- Local Imports +import CLasH.Utils.Pretty +import CLasH.Translator.TranslatorTypes import CLasH.Translator.Annotations +import CLasH.Utils + +listBindings :: FilePath -> [FilePath] -> IO [()] +listBindings libdir filenames = do + (cores,_,_) <- loadModules libdir filenames Nothing + let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores + mapM (listBinding) binds + +listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO () +listBinding (b, e) = do + putStr "\nBinder: " + putStr $ show b + putStr "\nType of Binder: \n" + putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b + putStr "\n\nExpression: \n" + putStr $ prettyShow e + putStr "\n\n" + putStr $ Outputable.showSDoc $ Outputable.ppr e + putStr "\n\nType of Expression: \n" + putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e + putStr "\n\n" + +-- | Show the core structure of the given binds in the given file. +listBind :: FilePath -> [FilePath] -> String -> IO () +listBind libdir filenames name = do + (cores,_,_) <- loadModules libdir filenames Nothing + bindings <- concatM $ mapM (findBinder (hasVarName name)) cores + mapM listBinding bindings + return () -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to -- be no standard function to do exactly this. @@ -46,31 +79,25 @@ unsafeRunGhc libDir m = loadModules :: FilePath -- ^ The GHC Library directory -> [String] -- ^ The files that need to be loaded - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The TopEntity finder - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The InitState finder - -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The TestInput finder + -> Maybe Finder -- ^ What entities to build? -> IO ( [HscTypes.CoreModule] - , [Maybe CoreSyn.CoreBndr] - , [Maybe CoreSyn.CoreBndr] - , [Maybe CoreSyn.CoreExpr] , HscTypes.HscEnv - ) -- ^ ( The loaded modules, the TopEntity, the InitState, the TestInput - -- , The Environment corresponding of the loaded modules - -- ) -loadModules libdir filenames topEntLoc initSLoc testLoc = + , [EntitySpec] + ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build) +loadModules libdir filenames finder = GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do GHC.runGhc (Just libdir) $ do dflags <- GHC.getSessionDynFlags GHC.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) + specs <- case finder of + Nothing -> return [] + Just f -> concatM $ mapM f cores + return (cores, env, specs) findBind :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -> HscTypes.CoreModule -> m (Maybe CoreSyn.CoreBndr) @@ -81,7 +108,7 @@ findBind criteria core = do bndrs -> return $ Just $ fst $ head bndrs findExpr :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -> HscTypes.CoreModule -> m (Maybe CoreSyn.CoreExpr) @@ -93,7 +120,7 @@ findExpr criteria core = do -- | Find a binder in module according to a certain criteria findBinder :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -- ^ The criteria to filter the binders on -> HscTypes.CoreModule -- ^ The module to be inspected -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria @@ -119,8 +146,21 @@ hasCLasHAnnotation clashAnn var = do -- | Determine if a binder has a certain name hasVarName :: - GHC.GhcMonad m => + Monad m => 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 == (Name.occNameString $ Name.nameOccName $ Name.getName bind) + +-- | Make a complete spec out of a three conditions +findSpec :: + (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) + -> Finder + +findSpec topc statec testc mod = do + top <- findBind topc mod + state <- findExpr statec mod + test <- findExpr testc mod + case top of + Just t -> return [(t, state, test)] + Nothing -> error $ "Could not find top entity requested"