Make listBindings return IO () instead of IO [()].
[matthijs/master-project/cλash.git] / 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"