+++ /dev/null
-{-# LANGUAGE ScopedTypeVariables #-}
-
-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
-import qualified Class
-
--- 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 = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
- mapM listBinding binds
- putStr "\n=========================\n"
- let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
- mapM listClass classes
- return ()
-
-listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
-listBinding (b, e) = do
- putStr "\nBinder: "
- putStr $ show b ++ "[" ++ show (Var.varUnique 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"
-
-listClass :: Class.Class -> IO ()
-listClass c = do
- putStr "\nClass: "
- putStr $ show (Class.className c)
- putStr "\nSelectors: "
- putStr $ show (Class.classSelIds c)
- putStr "\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.
-setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
-setDynFlag dflag = do
- dflags <- GHC.getSessionDynFlags
- let dflags' = DynFlags.dopt_set dflags dflag
- GHC.setSessionDynFlags dflags'
- return ()
-
--- We don't want the IO monad sprinkled around everywhere, so we hide it.
--- This should be safe as long as we only do simple things in the GhcMonad
--- such as interface lookups and evaluating simple expressions that
--- don't have side effects themselves (Or rather, that don't use
--- unsafePerformIO themselves, since normal side effectful function would
--- just return an IO monad when they are evaluated).
-unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
-unsafeRunGhc libDir m =
- System.IO.Unsafe.unsafePerformIO $
- GHC.runGhc (Just libDir) $ do
- 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
- -> Maybe Finder -- ^ What entities to build?
- -> IO ( [HscTypes.CoreModule]
- , HscTypes.HscEnv
- , [EntitySpec]
- ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
-loadModules libdir filenames finder =
- GHC.defaultErrorHandler DynFlags.defaultDynFlags $
- GHC.runGhc (Just libdir) $ do
- dflags <- GHC.getSessionDynFlags
- GHC.setSessionDynFlags dflags
- cores <- mapM GHC.compileToCoreModule filenames
- env <- GHC.getSession
- 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 ::
- 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 (map snd bndrs)
-
-findExpr ::
- Monad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe CoreSyn.CoreExpr)
-findExpr criteria core = do
- 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 ::
- 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
-findBinder criteria core = do
- let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
- Monad.filterM (criteria . fst) binds
-
--- | Determine if a binder has an Annotation meeting a certain criteria
-isCLasHAnnotation ::
- GHC.GhcMonad m =>
- (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
- -> Var.Var -- ^ The Binder
- -> 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
- 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 ::
- 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"
projects / matthijs / master-project / cλash.git / blobdiff