X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FUtils%2FGhcTools.hs;h=373e9cf6827f3db91f0877ef73370ec7757ff912;hb=a54863feb7304aa6a843efc15d29f017c45407f4;hp=0c8c55980acbffd6ec6be06af544453f2b21f192;hpb=20bfd1175196d07cb1da80813d6eb958560e62bd;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 0c8c559..373e9cf 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -5,19 +5,54 @@ module CLasH.Utils.GhcTools where -- Standard modules import qualified Monad import qualified System.IO.Unsafe +import qualified Language.Haskell.TH as TH +import qualified Maybe -- 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,54 +81,82 @@ 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) + +findBinds :: + Monad m => + (Var.Var -> m Bool) + -> HscTypes.CoreModule + -> m (Maybe [CoreSyn.CoreBndr]) +findBinds criteria core = do + binders <- findBinder criteria core + case binders of + [] -> return Nothing + bndrs -> return $ Just $ map fst bndrs findBind :: - GHC.GhcMonad m => + Monad m => (Var.Var -> m Bool) -> HscTypes.CoreModule -> m (Maybe CoreSyn.CoreBndr) findBind criteria core = do + binders <- findBinds criteria core + case binders of + Nothing -> return Nothing + (Just bndrs) -> return $ Just $ head bndrs + +findExprs :: + Monad m => + (Var.Var -> m Bool) + -> HscTypes.CoreModule + -> m (Maybe [CoreSyn.CoreExpr]) +findExprs criteria core = do binders <- findBinder criteria core case binders of [] -> return Nothing - bndrs -> return $ Just $ fst $ head bndrs + bndrs -> return $ Just $ (map snd bndrs) findExpr :: - GHC.GhcMonad m => + Monad 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 + exprs <- findExprs criteria core + case exprs of + Nothing -> return Nothing + (Just exprs) -> return $ Just $ head exprs + +findAnns :: + Monad m => + (Var.Var -> m [CLasHAnn]) + -> HscTypes.CoreModule + -> m [CLasHAnn] +findAnns criteria core = do + let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core + anns <- Monad.mapM (criteria . fst) binds + case anns of + [] -> return [] + xs -> return $ concat xs -- | 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 @@ -103,24 +166,72 @@ findBinder criteria core = do return critbinds -- | Determine if a binder has an Annotation meeting a certain criteria -hasCLasHAnnotation :: +isCLasHAnnotation :: 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 + -> m [CLasHAnn] -- ^ Indicates if binder has the Annotation +isCLasHAnnotation 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 annEnts + +-- | 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 + anns <- isCLasHAnnotation clashAnn var + case anns of [] -> return False xs -> return True -- | 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) + + +findInitStates :: + (Var.Var -> GHC.Ghc Bool) -> + (Var.Var -> GHC.Ghc [CLasHAnn]) -> + HscTypes.CoreModule -> + GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)]) +findInitStates statec annsc mod = do + states <- findBinds statec mod + anns <- findAnns annsc mod + let funs = Maybe.catMaybes (map extractInits anns) + exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs + let exprs = Maybe.catMaybes exprs' + let inits = zipMWith (\a b -> (a,b)) states exprs + return inits + where + extractInits :: CLasHAnn -> Maybe TH.Name + extractInits (InitState x) = Just x + extractInits _ = Nothing + zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c]) + zipMwith _ Nothing _ = Nothing + zipMWith f (Just as) bs = Just $ zipWith f as bs + +-- | Make a complete spec out of a three conditions +findSpec :: + (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool) + -> Finder + +findSpec topc statec annsc testc mod = do + top <- findBind topc mod + state <- findExprs statec mod + anns <- findAnns annsc mod + test <- findExpr testc mod + inits <- findInitStates statec annsc mod + return [(top, inits, test)] + -- case top of + -- Just t -> return [(t, state, test)] + -- Nothing -> return error $ "Could not find top entity requested"