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 = concatMap (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 $
  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 $
  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   Monad.filterM (criteria . fst) binds
 166
 167 -- | Determine if a binder has an Annotation meeting a certain criteria
 168 isCLasHAnnotation ::
 169   GHC.GhcMonad m =>
 170   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 171   -> Var.Var          -- ^ The Binder
 172   -> m [CLasHAnn]           -- ^ Indicates if binder has the Annotation
 173 isCLasHAnnotation clashAnn var = do
 174   let deserializer = Serialized.deserializeWithData
 175   let target = Annotations.NamedTarget (Var.varName var)
 176   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
 177   let annEnts = filter clashAnn anns
 178   return annEnts
 179
 180 -- | Determine if a binder has an Annotation meeting a certain criteria
 181 hasCLasHAnnotation ::
 182   GHC.GhcMonad m =>
 183   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 184   -> Var.Var          -- ^ The Binder
 185   -> m Bool           -- ^ Indicates if binder has the Annotation
 186 hasCLasHAnnotation clashAnn var = do
 187   anns <- isCLasHAnnotation clashAnn var
 188   case anns of
 189     [] -> return False
 190     xs -> return True
 191
 192 -- | Determine if a binder has a certain name
 193 hasVarName ::
 194   Monad m =>
 195   String        -- ^ The name the binder has to have
 196   -> Var.Var    -- ^ The Binder
 197   -> m Bool     -- ^ Indicate if the binder has the name
 198 hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
 199
 200
 201 findInitStates ::
 202   (Var.Var -> GHC.Ghc Bool) ->
 203   (Var.Var -> GHC.Ghc [CLasHAnn]) ->
 204   HscTypes.CoreModule ->
 205   GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
 206 findInitStates statec annsc mod = do
 207   states <- findBinds statec mod
 208   anns  <- findAnns annsc mod
 209   let funs = Maybe.catMaybes (map extractInits anns)
 210   exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
 211   let exprs = Maybe.catMaybes exprs'
 212   let inits = zipMWith (\a b -> (a,b)) states exprs
 213   return inits
 214   where
 215     extractInits :: CLasHAnn -> Maybe TH.Name
 216     extractInits (InitState x)  = Just x
 217     extractInits _              = Nothing
 218     zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
 219     zipMWith _ Nothing   _  = Nothing
 220     zipMWith f (Just as) bs = Just $ zipWith f as bs
 221
 222 -- | Make a complete spec out of a three conditions
 223 findSpec ::
 224   (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
 225   -> Finder
 226
 227 findSpec topc statec annsc testc mod = do
 228   top <- findBind topc mod
 229   state <- findExprs statec mod
 230   anns <- findAnns annsc mod
 231   test <- findExpr testc mod
 232   inits <- findInitStates statec annsc mod
 233   return [(top, inits, test)]
 234   -- case top of
 235   --   Just t -> return [(t, state, test)]
 236   --   Nothing -> return error $ "Could not find top entity requested"