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 DynFlags
  13 import qualified HscTypes
  14 import qualified GHC
  15 import qualified Name
  16 import qualified Serialized
  17 import qualified Var
  18
  19 -- Local Imports
  20 import CLasH.Translator.Annotations
  21
  22 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
  23 -- be no standard function to do exactly this.
  24 setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
  25 setDynFlag dflag = do
  26   dflags <- GHC.getSessionDynFlags
  27   let dflags' = DynFlags.dopt_set dflags dflag
  28   GHC.setSessionDynFlags dflags'
  29   return ()
  30
  31 -- We don't want the IO monad sprinkled around everywhere, so we hide it.
  32 -- This should be safe as long as we only do simple things in the GhcMonad
  33 -- such as interface lookups and evaluating simple expressions that
  34 -- don't have side effects themselves (Or rather, that don't use
  35 -- unsafePerformIO themselves, since normal side effectful function would
  36 -- just return an IO monad when they are evaluated).
  37 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
  38 unsafeRunGhc libDir m =
  39   System.IO.Unsafe.unsafePerformIO $ do
  40       GHC.runGhc (Just libDir) $ do
  41         dflags <- GHC.getSessionDynFlags
  42         GHC.setSessionDynFlags dflags
  43         m
  44
  45 -- | Loads the given files and turns it into a core module
  46 loadModules ::
  47   FilePath      -- ^ The GHC Library directory
  48   -> [String]   -- ^ The files that need to be loaded
  49   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The TopEntity finder
  50   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The InitState finder
  51   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The TestInput finder
  52   -> IO ( [HscTypes.CoreModule]
  53         , [Maybe CoreSyn.CoreBndr]
  54         , [Maybe CoreSyn.CoreBndr]
  55         , [Maybe CoreSyn.CoreExpr]
  56         , HscTypes.HscEnv
  57         ) -- ^ ( The loaded modules, the TopEntity, the InitState, the TestInput
  58           --   , The Environment corresponding of the loaded modules
  59           --   )
  60 loadModules libdir filenames topEntLoc initSLoc testLoc =
  61   GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
  62     GHC.runGhc (Just libdir) $ do
  63       dflags <- GHC.getSessionDynFlags
  64       GHC.setSessionDynFlags dflags
  65       cores <- mapM GHC.compileToCoreModule filenames
  66       env <- GHC.getSession
  67       top_entity <- mapM topEntLoc cores
  68       init_state <- mapM initSLoc cores
  69       test_input <- mapM testLoc cores
  70       return (cores, top_entity, init_state, test_input, env)
  71
  72 findBind ::
  73   GHC.GhcMonad m =>
  74   (Var.Var -> m Bool)
  75   -> HscTypes.CoreModule
  76   -> m (Maybe CoreSyn.CoreBndr)
  77 findBind criteria core = do
  78   binders <- findBinder criteria core
  79   case binders of
  80     [] -> return Nothing
  81     bndrs -> return $ Just $ fst $ head bndrs
  82
  83 findExpr ::
  84   GHC.GhcMonad m =>
  85   (Var.Var -> m Bool)
  86   -> HscTypes.CoreModule
  87   -> m (Maybe CoreSyn.CoreExpr)
  88 findExpr criteria core = do
  89   binders <- findBinder criteria core
  90   case binders of
  91     [] -> return Nothing
  92     bndrs -> return $ Just $ snd $ head bndrs
  93
  94 -- | Find a binder in module according to a certain criteria
  95 findBinder ::
  96   GHC.GhcMonad m =>
  97   (Var.Var -> m Bool)     -- ^ The criteria to filter the binders on
  98   -> HscTypes.CoreModule  -- ^ The module to be inspected
  99   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
 100 findBinder criteria core = do
 101   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
 102   critbinds <- Monad.filterM (criteria . fst) binds
 103   return critbinds
 104
 105 -- | Determine if a binder has an Annotation meeting a certain criteria
 106 hasCLasHAnnotation ::
 107   GHC.GhcMonad m =>
 108   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 109   -> Var.Var          -- ^ The Binder
 110   -> m Bool           -- ^ Indicates if binder has the Annotation
 111 hasCLasHAnnotation clashAnn var = do
 112   let deserializer = Serialized.deserializeWithData
 113   let target = Annotations.NamedTarget (Var.varName var)
 114   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
 115   let annEnts = filter clashAnn anns
 116   case annEnts of
 117     [] -> return False
 118     xs -> return True
 119
 120 -- | Determine if a binder has a certain name
 121 hasVarName ::
 122   GHC.GhcMonad m =>
 123   String        -- ^ The name the binder has to have
 124   -> Var.Var    -- ^ The Binder
 125   -> m Bool     -- ^ Indicate if the binder has the name
 126 hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)