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