fc63ac4e9560079185caaa13bba32df694f88d61
[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
23 -- Local Imports
24 import CLasH.Utils.Pretty
25 import CLasH.Translator.TranslatorTypes
26 import CLasH.Translator.Annotations
27 import CLasH.Utils
28
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
34
35 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
36 listBinding (b, e) = do
37   putStr "\nBinder: "
38   putStr $ show b
39   putStr "\nType of Binder: \n"
40   putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
41   putStr "\n\nExpression: \n"
42   putStr $ prettyShow e
43   putStr "\n\n"
44   putStr $ Outputable.showSDoc $ Outputable.ppr e
45   putStr "\n\nType of Expression: \n"
46   putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
47   putStr "\n\n"
48   
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
55   return ()
56
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 ()
60 setDynFlag dflag = do
61   dflags <- GHC.getSessionDynFlags
62   let dflags' = DynFlags.dopt_set dflags dflag
63   GHC.setSessionDynFlags dflags'
64   return ()
65
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
78         m
79   
80 -- | Loads the given files and turns it into a core module
81 loadModules ::
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]
86         , HscTypes.HscEnv
87         , [EntitySpec]
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
95       env <- GHC.getSession
96       specs <- case finder of
97         Nothing -> return []
98         Just f -> concatM $ mapM f cores
99       return (cores, env, specs)
100
101 findBinds ::
102   Monad m =>
103   (Var.Var -> m Bool)
104   -> HscTypes.CoreModule
105   -> m (Maybe [CoreSyn.CoreBndr])
106 findBinds criteria core = do
107   binders <- findBinder criteria core
108   case binders of
109     [] -> return Nothing
110     bndrs -> return $ Just $ map fst bndrs
111
112 findBind ::
113   Monad m =>
114   (Var.Var -> m Bool)
115   -> HscTypes.CoreModule
116   -> m (Maybe CoreSyn.CoreBndr)
117 findBind criteria core = do
118   binders <- findBinds criteria core
119   case binders of
120     Nothing -> return Nothing
121     (Just bndrs) -> return $ Just $ head bndrs
122
123 findExprs ::
124   Monad m =>
125   (Var.Var -> m Bool)
126   -> HscTypes.CoreModule
127   -> m (Maybe [CoreSyn.CoreExpr])
128 findExprs criteria core = do
129   binders <- findBinder criteria core
130   case binders of
131     [] -> return Nothing
132     bndrs -> return $ Just (map snd bndrs)
133
134 findExpr ::
135   Monad m =>
136   (Var.Var -> m Bool)
137   -> HscTypes.CoreModule
138   -> m (Maybe CoreSyn.CoreExpr)
139 findExpr criteria core = do
140   exprs <- findExprs criteria core
141   case exprs of
142     Nothing -> return Nothing
143     (Just exprs) -> return $ Just $ head exprs
144
145 findAnns ::
146   Monad m =>
147   (Var.Var -> m [CLasHAnn])
148   -> HscTypes.CoreModule
149   -> m [CLasHAnn]
150 findAnns criteria core = do
151   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
152   anns <- Monad.mapM (criteria . fst) binds
153   case anns of
154     [] -> return []
155     xs -> return $ concat xs
156
157 -- | Find a binder in module according to a certain criteria
158 findBinder :: 
159   Monad m =>
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
166
167 -- | Determine if a binder has an Annotation meeting a certain criteria
168 isCLasHAnnotation ::
169   GHC.GhcMonad m =>
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
178   return annEnts
179
180 -- | Determine if a binder has an Annotation meeting a certain criteria
181 hasCLasHAnnotation ::
182   GHC.GhcMonad m =>
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
188   case anns of
189     [] -> return False
190     xs -> return True
191
192 -- | Determine if a binder has a certain name
193 hasVarName ::   
194   Monad m =>
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)
199
200
201 findInitStates ::
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
213   return inits
214   where
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
221
222 -- | Make a complete spec out of a three conditions
223 findSpec ::
224   (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
225   -> Finder
226
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)]
234   -- case top of
235   --   Just t -> return [(t, state, test)]
236   --   Nothing -> return error $ "Could not find top entity requested"