1 {-# LANGUAGE ScopedTypeVariables #-}
3 module CLasH.Utils.GhcTools where
7 import qualified System.IO.Unsafe
8 import qualified Language.Haskell.TH as TH
12 import qualified Annotations
13 import qualified CoreSyn
14 import qualified CoreUtils
15 import qualified DynFlags
16 import qualified HscTypes
19 import qualified Serialized
21 import qualified Outputable
22 import Outputable(($+$), (<+>), nest, empty, text, vcat)
23 import qualified Class
26 import CLasH.Utils.Pretty
27 import CLasH.Translator.TranslatorTypes
28 import CLasH.Translator.Annotations
31 -- How far to indent the values after a Foo: header
33 -- How far to indent all lines after the first
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
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]
50 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
51 listBinding (b, e) = putStr $ Outputable.showSDoc $
52 (text "Binder:") <+> (text $ show b ++ "[" ++ show (Var.varUnique b) ++ "]")
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)
59 $+$ (text "\n") -- Add an empty line
61 listClass :: Class.Class -> IO ()
62 listClass c = putStr $ Outputable.showSDoc $
63 (text "Class:") <+> (text $ show (Class.className c))
65 hang' (text "Selectors:") align (text $ show (Class.classSelIds c))
67 $+$ (text "\n") -- Add an empty line
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
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 ()
81 dflags <- GHC.getSessionDynFlags
82 let dflags' = DynFlags.dopt_set dflags dflag
83 GHC.setSessionDynFlags dflags'
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
100 -- | Loads the given files and turns it into a core module
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]
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
118 Just f -> concatM $ mapM f cores
119 return (cores, env, specs)
124 -> HscTypes.CoreModule
125 -> m (Maybe [CoreSyn.CoreBndr])
126 findBinds criteria core = do
127 binders <- findBinder criteria core
130 bndrs -> return $ Just $ map fst bndrs
135 -> HscTypes.CoreModule
136 -> m (Maybe CoreSyn.CoreBndr)
137 findBind criteria core = do
138 binders <- findBinds criteria core
140 Nothing -> return Nothing
141 (Just bndrs) -> return $ Just $ head bndrs
146 -> HscTypes.CoreModule
147 -> m (Maybe [CoreSyn.CoreExpr])
148 findExprs criteria core = do
149 binders <- findBinder criteria core
152 bndrs -> return $ Just (map snd bndrs)
157 -> HscTypes.CoreModule
158 -> m (Maybe CoreSyn.CoreExpr)
159 findExpr criteria core = do
160 exprs <- findExprs criteria core
162 Nothing -> return Nothing
163 (Just exprs) -> return $ Just $ head exprs
167 (Var.Var -> m [CLasHAnn])
168 -> HscTypes.CoreModule
170 findAnns criteria core = do
171 let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
172 anns <- Monad.mapM (criteria . fst) binds
175 xs -> return $ concat xs
177 -- | Find a binder in module according to a certain criteria
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
187 -- | Determine if a binder has an Annotation meeting a certain criteria
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
200 -- | Determine if a binder has an Annotation meeting a certain criteria
201 hasCLasHAnnotation ::
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
212 -- | Determine if a binder has a certain name
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)
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
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
242 -- | Make a complete spec out of a three conditions
244 (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
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)]
255 -- Just t -> return [(t, state, test)]
256 -- Nothing -> return error $ "Could not find top entity requested"