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