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 import qualified Language.Haskell.TH as TH
   9 import qualified Maybe
  10
  11 -- GHC API
  12 import qualified Annotations
  13 import qualified CoreSyn
  14 import qualified CoreUtils
  15 import qualified DynFlags
  16 import qualified HscTypes
  17 import qualified GHC
  18 import qualified Name
  19 import qualified Serialized
  20 import qualified Var
  21 import qualified Outputable
  22 import qualified Class
  23
  24 -- Local Imports
  25 import CLasH.Utils.Pretty
  26 import CLasH.Translator.TranslatorTypes
  27 import CLasH.Translator.Annotations
  28 import CLasH.Utils
  29
  30 listBindings :: FilePath -> [FilePath] -> IO [()]
  31 listBindings libdir filenames = do
  32   (cores,_,_) <- loadModules libdir filenames Nothing
  33   let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
  34   mapM listBinding binds
  35   putStr "\n=========================\n"
  36   let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
  37   mapM listClass classes
  38
  39 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
  40 listBinding (b, e) = do
  41   putStr "\nBinder: "
  42   putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]"
  43   putStr "\nType of Binder: \n"
  44   putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
  45   putStr "\n\nExpression: \n"
  46   putStr $ prettyShow e
  47   putStr "\n\n"
  48   putStr $ Outputable.showSDoc $ Outputable.ppr e
  49   putStr "\n\nType of Expression: \n"
  50   putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
  51   putStr "\n\n"
  52
  53 listClass :: Class.Class -> IO ()
  54 listClass c = do
  55   putStr "\nClass: "
  56   putStr $ show (Class.className c)
  57   putStr "\nSelectors: "
  58   putStr $ show (Class.classSelIds c)
  59   putStr "\n"
  60
  61 -- | Show the core structure of the given binds in the given file.
  62 listBind :: FilePath -> [FilePath] -> String -> IO ()
  63 listBind libdir filenames name = do
  64   (cores,_,_) <- loadModules libdir filenames Nothing
  65   bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
  66   mapM_ listBinding bindings
  67   return ()
  68
  69 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
  70 -- be no standard function to do exactly this.
  71 setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
  72 setDynFlag dflag = do
  73   dflags <- GHC.getSessionDynFlags
  74   let dflags' = DynFlags.dopt_set dflags dflag
  75   GHC.setSessionDynFlags dflags'
  76   return ()
  77
  78 -- We don't want the IO monad sprinkled around everywhere, so we hide it.
  79 -- This should be safe as long as we only do simple things in the GhcMonad
  80 -- such as interface lookups and evaluating simple expressions that
  81 -- don't have side effects themselves (Or rather, that don't use
  82 -- unsafePerformIO themselves, since normal side effectful function would
  83 -- just return an IO monad when they are evaluated).
  84 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
  85 unsafeRunGhc libDir m =
  86   System.IO.Unsafe.unsafePerformIO $
  87       GHC.runGhc (Just libDir) $ do
  88         dflags <- GHC.getSessionDynFlags
  89         GHC.setSessionDynFlags dflags
  90         m
  91
  92 -- | Loads the given files and turns it into a core module
  93 loadModules ::
  94   FilePath      -- ^ The GHC Library directory
  95   -> [String]   -- ^ The files that need to be loaded
  96   -> Maybe Finder -- ^ What entities to build?
  97   -> IO ( [HscTypes.CoreModule]
  98         , HscTypes.HscEnv
  99         , [EntitySpec]
 100         ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
 101 loadModules libdir filenames finder =
 102   GHC.defaultErrorHandler DynFlags.defaultDynFlags $
 103     GHC.runGhc (Just libdir) $ do
 104       dflags <- GHC.getSessionDynFlags
 105       GHC.setSessionDynFlags dflags
 106       cores <- mapM GHC.compileToCoreModule filenames
 107       env <- GHC.getSession
 108       specs <- case finder of
 109         Nothing -> return []
 110         Just f -> concatM $ mapM f cores
 111       return (cores, env, specs)
 112
 113 findBinds ::
 114   Monad m =>
 115   (Var.Var -> m Bool)
 116   -> HscTypes.CoreModule
 117   -> m (Maybe [CoreSyn.CoreBndr])
 118 findBinds criteria core = do
 119   binders <- findBinder criteria core
 120   case binders of
 121     [] -> return Nothing
 122     bndrs -> return $ Just $ map fst bndrs
 123
 124 findBind ::
 125   Monad m =>
 126   (Var.Var -> m Bool)
 127   -> HscTypes.CoreModule
 128   -> m (Maybe CoreSyn.CoreBndr)
 129 findBind criteria core = do
 130   binders <- findBinds criteria core
 131   case binders of
 132     Nothing -> return Nothing
 133     (Just bndrs) -> return $ Just $ head bndrs
 134
 135 findExprs ::
 136   Monad m =>
 137   (Var.Var -> m Bool)
 138   -> HscTypes.CoreModule
 139   -> m (Maybe [CoreSyn.CoreExpr])
 140 findExprs criteria core = do
 141   binders <- findBinder criteria core
 142   case binders of
 143     [] -> return Nothing
 144     bndrs -> return $ Just (map snd bndrs)
 145
 146 findExpr ::
 147   Monad m =>
 148   (Var.Var -> m Bool)
 149   -> HscTypes.CoreModule
 150   -> m (Maybe CoreSyn.CoreExpr)
 151 findExpr criteria core = do
 152   exprs <- findExprs criteria core
 153   case exprs of
 154     Nothing -> return Nothing
 155     (Just exprs) -> return $ Just $ head exprs
 156
 157 findAnns ::
 158   Monad m =>
 159   (Var.Var -> m [CLasHAnn])
 160   -> HscTypes.CoreModule
 161   -> m [CLasHAnn]
 162 findAnns criteria core = do
 163   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
 164   anns <- Monad.mapM (criteria . fst) binds
 165   case anns of
 166     [] -> return []
 167     xs -> return $ concat xs
 168
 169 -- | Find a binder in module according to a certain criteria
 170 findBinder ::
 171   Monad m =>
 172   (Var.Var -> m Bool)     -- ^ The criteria to filter the binders on
 173   -> HscTypes.CoreModule  -- ^ The module to be inspected
 174   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
 175 findBinder criteria core = do
 176   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
 177   Monad.filterM (criteria . fst) binds
 178
 179 -- | Determine if a binder has an Annotation meeting a certain criteria
 180 isCLasHAnnotation ::
 181   GHC.GhcMonad m =>
 182   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 183   -> Var.Var          -- ^ The Binder
 184   -> m [CLasHAnn]           -- ^ Indicates if binder has the Annotation
 185 isCLasHAnnotation clashAnn var = do
 186   let deserializer = Serialized.deserializeWithData
 187   let target = Annotations.NamedTarget (Var.varName var)
 188   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
 189   let annEnts = filter clashAnn anns
 190   return annEnts
 191
 192 -- | Determine if a binder has an Annotation meeting a certain criteria
 193 hasCLasHAnnotation ::
 194   GHC.GhcMonad m =>
 195   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 196   -> Var.Var          -- ^ The Binder
 197   -> m Bool           -- ^ Indicates if binder has the Annotation
 198 hasCLasHAnnotation clashAnn var = do
 199   anns <- isCLasHAnnotation clashAnn var
 200   case anns of
 201     [] -> return False
 202     xs -> return True
 203
 204 -- | Determine if a binder has a certain name
 205 hasVarName ::
 206   Monad m =>
 207   String        -- ^ The name the binder has to have
 208   -> Var.Var    -- ^ The Binder
 209   -> m Bool     -- ^ Indicate if the binder has the name
 210 hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
 211
 212
 213 findInitStates ::
 214   (Var.Var -> GHC.Ghc Bool) ->
 215   (Var.Var -> GHC.Ghc [CLasHAnn]) ->
 216   HscTypes.CoreModule ->
 217   GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
 218 findInitStates statec annsc mod = do
 219   states <- findBinds statec mod
 220   anns  <- findAnns annsc mod
 221   let funs = Maybe.catMaybes (map extractInits anns)
 222   exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
 223   let exprs = Maybe.catMaybes exprs'
 224   let inits = zipMWith (\a b -> (a,b)) states exprs
 225   return inits
 226   where
 227     extractInits :: CLasHAnn -> Maybe TH.Name
 228     extractInits (InitState x)  = Just x
 229     extractInits _              = Nothing
 230     zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
 231     zipMWith _ Nothing   _  = Nothing
 232     zipMWith f (Just as) bs = Just $ zipWith f as bs
 233
 234 -- | Make a complete spec out of a three conditions
 235 findSpec ::
 236   (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
 237   -> Finder
 238
 239 findSpec topc statec annsc testc mod = do
 240   top <- findBind topc mod
 241   state <- findExprs statec mod
 242   anns <- findAnns annsc mod
 243   test <- findExpr testc mod
 244   inits <- findInitStates statec annsc mod
 245   return [(top, inits, test)]
 246   -- case top of
 247   --   Just t -> return [(t, state, test)]
 248   --   Nothing -> return error $ "Could not find top entity requested"