Don't try to inline non-normalizeable top level functions.
[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
9 -- GHC API
10 import qualified Annotations
11 import qualified CoreSyn
12 import qualified CoreUtils
13 import qualified DynFlags
14 import qualified HscTypes
15 import qualified GHC
16 import qualified Name
17 import qualified Serialized
18 import qualified Var
19 import qualified Outputable
20
21 -- Local Imports
22 import CLasH.Utils.Pretty
23 import CLasH.Translator.TranslatorTypes
24 import CLasH.Translator.Annotations
25 import CLasH.Utils
26
27 listBindings :: FilePath -> [FilePath] -> IO [()]
28 listBindings libdir filenames = do
29   (cores,_,_) <- loadModules libdir filenames Nothing
30   let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
31   mapM (listBinding) binds
32
33 listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
34 listBinding (b, e) = do
35   putStr "\nBinder: "
36   putStr $ show b
37   putStr "\nType of Binder: \n"
38   putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
39   putStr "\n\nExpression: \n"
40   putStr $ prettyShow e
41   putStr "\n\n"
42   putStr $ Outputable.showSDoc $ Outputable.ppr e
43   putStr "\n\nType of Expression: \n"
44   putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
45   putStr "\n\n"
46   
47 -- | Show the core structure of the given binds in the given file.
48 listBind :: FilePath -> [FilePath] -> String -> IO ()
49 listBind libdir filenames name = do
50   (cores,_,_) <- loadModules libdir filenames Nothing
51   bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
52   mapM listBinding bindings
53   return ()
54
55 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
56 -- be no standard function to do exactly this.
57 setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
58 setDynFlag dflag = do
59   dflags <- GHC.getSessionDynFlags
60   let dflags' = DynFlags.dopt_set dflags dflag
61   GHC.setSessionDynFlags dflags'
62   return ()
63
64 -- We don't want the IO monad sprinkled around everywhere, so we hide it.
65 -- This should be safe as long as we only do simple things in the GhcMonad
66 -- such as interface lookups and evaluating simple expressions that
67 -- don't have side effects themselves (Or rather, that don't use
68 -- unsafePerformIO themselves, since normal side effectful function would
69 -- just return an IO monad when they are evaluated).
70 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
71 unsafeRunGhc libDir m =
72   System.IO.Unsafe.unsafePerformIO $ do
73       GHC.runGhc (Just libDir) $ do
74         dflags <- GHC.getSessionDynFlags
75         GHC.setSessionDynFlags dflags
76         m
77   
78 -- | Loads the given files and turns it into a core module
79 loadModules ::
80   FilePath      -- ^ The GHC Library directory 
81   -> [String]   -- ^ The files that need to be loaded
82   -> Maybe Finder -- ^ What entities to build?
83   -> IO ( [HscTypes.CoreModule]
84         , HscTypes.HscEnv
85         , [EntitySpec]
86         ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
87 loadModules libdir filenames finder =
88   GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
89     GHC.runGhc (Just libdir) $ do
90       dflags <- GHC.getSessionDynFlags
91       GHC.setSessionDynFlags dflags
92       cores <- mapM GHC.compileToCoreModule filenames
93       env <- GHC.getSession
94       specs <- case finder of
95         Nothing -> return []
96         Just f -> concatM $ mapM f cores
97       return (cores, env, specs)
98
99 findBind ::
100   Monad m =>
101   (Var.Var -> m Bool)
102   -> HscTypes.CoreModule
103   -> m (Maybe CoreSyn.CoreBndr)
104 findBind criteria core = do
105   binders <- findBinder criteria core
106   case binders of
107     [] -> return Nothing
108     bndrs -> return $ Just $ fst $ head bndrs
109
110 findExpr ::
111   Monad m =>
112   (Var.Var -> m Bool)
113   -> HscTypes.CoreModule
114   -> m (Maybe CoreSyn.CoreExpr)
115 findExpr criteria core = do
116   binders <- findBinder criteria core
117   case binders of
118     [] -> return Nothing
119     bndrs -> return $ Just $ snd $ head bndrs
120
121 -- | Find a binder in module according to a certain criteria
122 findBinder :: 
123   Monad m =>
124   (Var.Var -> m Bool)     -- ^ The criteria to filter the binders on
125   -> HscTypes.CoreModule  -- ^ The module to be inspected
126   -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
127 findBinder criteria core = do
128   let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
129   critbinds <- Monad.filterM (criteria . fst) binds
130   return critbinds
131
132 -- | Determine if a binder has an Annotation meeting a certain criteria
133 hasCLasHAnnotation ::
134   GHC.GhcMonad m =>
135   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
136   -> Var.Var          -- ^ The Binder
137   -> m Bool           -- ^ Indicates if binder has the Annotation
138 hasCLasHAnnotation clashAnn var = do
139   let deserializer = Serialized.deserializeWithData
140   let target = Annotations.NamedTarget (Var.varName var)
141   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
142   let annEnts = filter clashAnn anns
143   case annEnts of
144     [] -> return False
145     xs -> return True
146
147 -- | Determine if a binder has a certain name
148 hasVarName ::   
149   Monad m =>
150   String        -- ^ The name the binder has to have
151   -> Var.Var    -- ^ The Binder
152   -> m Bool     -- ^ Indicate if the binder has the name
153 hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
154
155 -- | Make a complete spec out of a three conditions
156 findSpec ::
157   (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool)
158   -> Finder
159
160 findSpec topc statec testc mod = do
161   top <- findBind topc mod
162   state <- findExpr statec mod
163   test <- findExpr testc mod
164   return [(top, state, test)]
165   -- case top of
166   --   Just t -> return [(t, state, test)]
167   --   Nothing -> return error $ "Could not find top entity requested"