cλash/CLasH/Utils/GhcTools.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 module CLasH.Utils.GhcTools where
   4
   5 -- Standard modules
   6 import qualified Monad
   7 import qualified System.IO.Unsafe
   8
   9 -- GHC API
  10 import qualified Annotations
  11 import qualified CoreSyn
  12 import qualified CoreUtils
  13 import qualified DynFlags
  14 import qualified HscTypes
  15 import qualified GHC
  16 import qualified Name
  17 import qualified Serialized
  18 import qualified Var
  19 import qualified Outputable
  20
  21 -- Local Imports
  22 import CLasH.Utils.Pretty
  23 import CLasH.Translator.TranslatorTypes
  24 import CLasH.Translator.Annotations
  25 import CLasH.Utils
  26
  27 listBindings :: FilePath -> [FilePath] -> IO [()]
  28 listBindings libdir filenames = do
  29   (cores,_,_) <- loadModules libdir filenames Nothing
  30   let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
  31   mapM (listBinding) binds
  32
  33 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
  34 listBinding (b, e) = do
  35   putStr "\nBinder: "
  36   putStr $ show b
  37   putStr "\nType of Binder: \n"
  38   putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
  39   putStr "\n\nExpression: \n"
  40   putStr $ prettyShow e
  41   putStr "\n\n"
  42   putStr $ Outputable.showSDoc $ Outputable.ppr e
  43   putStr "\n\nType of Expression: \n"
  44   putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
  45   putStr "\n\n"
  46
  47 -- | Show the core structure of the given binds in the given file.
  48 listBind :: FilePath -> [FilePath] -> String -> IO ()
  49 listBind libdir filenames name = do
  50   (cores,_,_) <- loadModules libdir filenames Nothing
  51   bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
  52   mapM listBinding bindings
  53   return ()
  54
  55 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
  56 -- be no standard function to do exactly this.
  57 setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
  58 setDynFlag dflag = do
  59   dflags <- GHC.getSessionDynFlags
  60   let dflags' = DynFlags.dopt_set dflags dflag
  61   GHC.setSessionDynFlags dflags'
  62   return ()
  63
  64 -- We don't want the IO monad sprinkled around everywhere, so we hide it.
  65 -- This should be safe as long as we only do simple things in the GhcMonad
  66 -- such as interface lookups and evaluating simple expressions that
  67 -- don't have side effects themselves (Or rather, that don't use
  68 -- unsafePerformIO themselves, since normal side effectful function would
  69 -- just return an IO monad when they are evaluated).
  70 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
  71 unsafeRunGhc libDir m =
  72   System.IO.Unsafe.unsafePerformIO $ do
  73       GHC.runGhc (Just libDir) $ do
  74         dflags <- GHC.getSessionDynFlags
  75         GHC.setSessionDynFlags dflags
  76         m
  77
  78 -- | Loads the given files and turns it into a core module
  79 loadModules ::
  80   FilePath      -- ^ The GHC Library directory
  81   -> [String]   -- ^ The files that need to be loaded
  82   -> Maybe Finder -- ^ What entities to build?
  83   -> IO ( [HscTypes.CoreModule]
  84         , HscTypes.HscEnv
  85         , [EntitySpec]
  86         ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
  87 loadModules libdir filenames finder =
  88   GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
  89     GHC.runGhc (Just libdir) $ do
  90       dflags <- GHC.getSessionDynFlags
  91       GHC.setSessionDynFlags dflags
  92       cores <- mapM GHC.compileToCoreModule filenames
  93       env <- GHC.getSession
  94       specs <- case finder of
  95         Nothing -> return []
  96         Just f -> concatM $ mapM f cores
  97       return (cores, env, specs)
  98
  99 findBind ::
 100   Monad m =>
 101   (Var.Var -> m Bool)
 102   -> HscTypes.CoreModule
 103   -> m (Maybe CoreSyn.CoreBndr)
 104 findBind criteria core = do
 105   binders <- findBinder criteria core
 106   case binders of
 107     [] -> return Nothing
 108     bndrs -> return $ Just $ fst $ head bndrs
 109
 110 findExpr ::
 111   Monad m =>
 112   (Var.Var -> m Bool)
 113   -> HscTypes.CoreModule
 114   -> m (Maybe CoreSyn.CoreExpr)
 115 findExpr criteria core = do
 116   binders <- findBinder criteria core
 117   case binders of
 118     [] -> return Nothing
 119     bndrs -> return $ Just $ snd $ head bndrs
 120
 121 -- | Find a binder in module according to a certain criteria
 122 findBinder ::
 123   Monad m =>
 124   (Var.Var -> m Bool)     -- ^ The criteria to filter the binders on
 125   -> HscTypes.CoreModule  -- ^ The module to be inspected
 126   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
 127 findBinder criteria core = do
 128   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
 129   critbinds <- Monad.filterM (criteria . fst) binds
 130   return critbinds
 131
 132 -- | Determine if a binder has an Annotation meeting a certain criteria
 133 hasCLasHAnnotation ::
 134   GHC.GhcMonad m =>
 135   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 136   -> Var.Var          -- ^ The Binder
 137   -> m Bool           -- ^ Indicates if binder has the Annotation
 138 hasCLasHAnnotation clashAnn var = do
 139   let deserializer = Serialized.deserializeWithData
 140   let target = Annotations.NamedTarget (Var.varName var)
 141   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
 142   let annEnts = filter clashAnn anns
 143   case annEnts of
 144     [] -> return False
 145     xs -> return True
 146
 147 -- | Determine if a binder has a certain name
 148 hasVarName ::
 149   Monad m =>
 150   String        -- ^ The name the binder has to have
 151   -> Var.Var    -- ^ The Binder
 152   -> m Bool     -- ^ Indicate if the binder has the name
 153 hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
 154
 155 -- | Make a complete spec out of a three conditions
 156 findSpec ::
 157   (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool)
 158   -> Finder
 159
 160 findSpec topc statec testc mod = do
 161   top <- findBind topc mod
 162   state <- findExpr statec mod
 163   test <- findExpr testc mod
 164   return [(top, state, test)]
 165   -- case top of
 166   --   Just t -> return [(t, state, test)]
 167   --   Nothing -> return error $ "Could not find top entity requested"