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
24 import CLasH.Utils.Pretty
25 import CLasH.Translator.TranslatorTypes
26 import CLasH.Translator.Annotations
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
35 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
36 listBinding (b, e) = do
39 putStr "\nType of Binder: \n"
40 putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
41 putStr "\n\nExpression: \n"
44 putStr $ Outputable.showSDoc $ Outputable.ppr e
45 putStr "\n\nType of Expression: \n"
46 putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
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
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 ()
61 dflags <- GHC.getSessionDynFlags
62 let dflags' = DynFlags.dopt_set dflags dflag
63 GHC.setSessionDynFlags dflags'
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
80 -- | Loads the given files and turns it into a core module
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]
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
96 specs <- case finder of
98 Just f -> concatM $ mapM f cores
99 return (cores, env, specs)
104 -> HscTypes.CoreModule
105 -> m (Maybe [CoreSyn.CoreBndr])
106 findBinds criteria core = do
107 binders <- findBinder criteria core
110 bndrs -> return $ Just $ map fst bndrs
115 -> HscTypes.CoreModule
116 -> m (Maybe CoreSyn.CoreBndr)
117 findBind criteria core = do
118 binders <- findBinds criteria core
120 Nothing -> return Nothing
121 (Just bndrs) -> return $ Just $ head bndrs
126 -> HscTypes.CoreModule
127 -> m (Maybe [CoreSyn.CoreExpr])
128 findExprs criteria core = do
129 binders <- findBinder criteria core
132 bndrs -> return $ Just (map snd bndrs)
137 -> HscTypes.CoreModule
138 -> m (Maybe CoreSyn.CoreExpr)
139 findExpr criteria core = do
140 exprs <- findExprs criteria core
142 Nothing -> return Nothing
143 (Just exprs) -> return $ Just $ head exprs
147 (Var.Var -> m [CLasHAnn])
148 -> HscTypes.CoreModule
150 findAnns criteria core = do
151 let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
152 anns <- Monad.mapM (criteria . fst) binds
155 xs -> return $ concat xs
157 -- | Find a binder in module according to a certain criteria
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
167 -- | Determine if a binder has an Annotation meeting a certain criteria
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
180 -- | Determine if a binder has an Annotation meeting a certain criteria
181 hasCLasHAnnotation ::
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
192 -- | Determine if a binder has a certain name
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)
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
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
222 -- | Make a complete spec out of a three conditions
224 (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
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)]
235 -- Just t -> return [(t, state, test)]
236 -- Nothing -> return error $ "Could not find top entity requested"