X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FUtils%2FGhcTools.hs;fp=c%CE%BBash%2FCLasH%2FUtils%2FGhcTools.hs;h=0000000000000000000000000000000000000000;hb=04f836932ad17dd557af0ba388a12d2b74c1e7d7;hp=f1fe6ba61b2547d494f5709f5bb10f375e4f5d62;hpb=75978cf28a619d14ae27ea2bb4a53246b6a0bcd8;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"
deleted file mode 100644
index f1fe6ba..0000000
--- "a/c\316\273ash/CLasH/Utils/GhcTools.hs"
+++ /dev/null
@@ -1,249 +0,0 @@
-{-# 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"