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