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