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