From: Christiaan Baaij Date: Sat, 1 Aug 2009 18:41:19 +0000 (+0200) Subject: Bring back listBind(ings) in Utils.hs by reorganising Translator.hs and GhcTools.hs X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=20bfd1175196d07cb1da80813d6eb958560e62bd;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Bring back listBind(ings) in Utils.hs by reorganising Translator.hs and GhcTools.hs --- diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index 5f9978e..7ea489f 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -1,6 +1,7 @@ -{-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-} - -module CLasH.Translator (makeVHDLStrings, makeVHDLAnnotations) where +module CLasH.Translator + ( makeVHDLStrings + , makeVHDLAnnotations + ) where -- Standard Modules import qualified Directory @@ -10,16 +11,10 @@ import qualified System.FilePath as FilePath import Text.PrettyPrint.HughesPJ (render) -- GHC API -import qualified Annotations -import CoreSyn -import DynFlags ( defaultDynFlags ) -import GHC hiding (loadModule, sigName) +import qualified CoreSyn +import qualified GHC 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 @@ -27,9 +22,10 @@ import qualified Language.VHDL.FileIO import qualified Language.VHDL.Ppr as Ppr -- Local Imports -import CLasH.Translator.Annotations import CLasH.Normalize +import CLasH.Translator.Annotations import CLasH.Utils.Core.CoreTools +import CLasH.Utils.GhcTools import CLasH.VHDL -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial @@ -68,9 +64,9 @@ makeVHDLAnnotations libdir filenames stateful = do 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 + -> (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 -> IO () makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do @@ -89,12 +85,12 @@ makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful -- VHDL. The Bool in the tuple makes the function stateful (True) or -- stateless (False). 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 + -> [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) -> IO [(AST.VHDLId, AST.DesignFile)] moduleToVHDL env cores top init test stateful = do let topEntity = Maybe.catMaybes top @@ -105,7 +101,7 @@ moduleToVHDL env cores top init test stateful = do 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 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 @@ -137,76 +133,4 @@ writeVHDL dir (name, vhdl) = do -- 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] - , [Maybe CoreBndr] - , [Maybe CoreBndr] - , [Maybe CoreExpr] - , HscTypes.HscEnv - ) -- ^ (The loaded modules , The TopEntity , The InitState, The TestInput, 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 => - (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 => - (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 => - (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 => - 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) - -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git "a/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" new file mode 100644 index 0000000..c539c79 --- /dev/null +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -0,0 +1,49 @@ +module CLasH.Utils + ( listBindings + , listBind + ) where + +-- Standard Imports +import qualified Maybe + +-- 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) \ No newline at end of file diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 3f032d9..0c8c559 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -1,14 +1,23 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module CLasH.Utils.GhcTools where + -- Standard modules +import qualified Monad import qualified System.IO.Unsafe -- GHC API -import qualified GHC +import qualified Annotations +import qualified CoreSyn import qualified DynFlags -import qualified TcRnMonad -import qualified MonadUtils import qualified HscTypes -import qualified PrelNames +import qualified GHC +import qualified Name +import qualified Serialized +import qualified Var + +-- Local Imports +import CLasH.Translator.Annotations -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to -- be no standard function to do exactly this. @@ -32,12 +41,86 @@ unsafeRunGhc libDir m = dflags <- GHC.getSessionDynFlags GHC.setSessionDynFlags dflags m + +-- | 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.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 + -> 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 = + 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) + +findBind :: + GHC.GhcMonad m => + (Var.Var -> m Bool) + -> HscTypes.CoreModule + -> m (Maybe CoreSyn.CoreBndr) +findBind criteria core = do + binders <- findBinder criteria core + case binders of + [] -> return Nothing + bndrs -> return $ Just $ fst $ head bndrs + +findExpr :: + GHC.GhcMonad m => + (Var.Var -> m Bool) + -> HscTypes.CoreModule + -> m (Maybe CoreSyn.CoreExpr) +findExpr criteria core = do + binders <- findBinder criteria core + case binders of + [] -> return Nothing + bndrs -> return $ Just $ snd $ head bndrs + +-- | Find a binder in module according to a certain criteria +findBinder :: + GHC.GhcMonad 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 +findBinder criteria core = do + let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core + critbinds <- Monad.filterM (criteria . fst) binds + return critbinds + +-- | Determine if a binder has an Annotation meeting a certain criteria +hasCLasHAnnotation :: + GHC.GhcMonad m => + (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 --- runTcM :: TcRnMonad.TcM a -> IO a --- runTcM thing_inside = do --- GHC.runGhc (Just GHC.Paths.libdir) $ do --- dflags <- GHC.getSessionDynFlags --- GHC.setSessionDynFlags dflags --- env <- GHC.getSession --- HscTypes.ioMsgMaybe . MonadUtils.liftIO . TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do --- thing_inside +-- | Determine if a binder has a certain name +hasVarName :: + GHC.GhcMonad 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) diff --git "a/c\316\273ash/clash.cabal" "b/c\316\273ash/clash.cabal" index 529772c..fb44457 100644 --- "a/c\316\273ash/clash.cabal" +++ "b/c\316\273ash/clash.cabal" @@ -22,8 +22,9 @@ Library filepath, template-haskell, data-accessor-template, prettyclass - exposed-modules: CLasH.Translator, + exposed-modules: CLasH.Translator CLasH.Translator.Annotations + CLasH.Utils other-modules: CLasH.Translator.TranslatorTypes CLasH.Normalize