1 {-# LANGUAGE ScopedTypeVariables #-}
3 module CLasH.Utils.GhcTools where
7 import qualified System.IO.Unsafe
10 import qualified Annotations
11 import qualified CoreSyn
12 import qualified DynFlags
13 import qualified HscTypes
16 import qualified Serialized
20 import CLasH.Translator.Annotations
22 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
23 -- be no standard function to do exactly this.
24 setDynFlag :: DynFlags.DynFlag -> GHC.Ghc ()
26 dflags <- GHC.getSessionDynFlags
27 let dflags' = DynFlags.dopt_set dflags dflag
28 GHC.setSessionDynFlags dflags'
31 -- We don't want the IO monad sprinkled around everywhere, so we hide it.
32 -- This should be safe as long as we only do simple things in the GhcMonad
33 -- such as interface lookups and evaluating simple expressions that
34 -- don't have side effects themselves (Or rather, that don't use
35 -- unsafePerformIO themselves, since normal side effectful function would
36 -- just return an IO monad when they are evaluated).
37 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
38 unsafeRunGhc libDir m =
39 System.IO.Unsafe.unsafePerformIO $ do
40 GHC.runGhc (Just libDir) $ do
41 dflags <- GHC.getSessionDynFlags
42 GHC.setSessionDynFlags dflags
45 -- | Loads the given files and turns it into a core module
47 FilePath -- ^ The GHC Library directory
48 -> [String] -- ^ The files that need to be loaded
49 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The TopEntity finder
50 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The InitState finder
51 -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The TestInput finder
52 -> IO ( [HscTypes.CoreModule]
53 , [Maybe CoreSyn.CoreBndr]
54 , [Maybe CoreSyn.CoreBndr]
55 , [Maybe CoreSyn.CoreExpr]
57 ) -- ^ ( The loaded modules, the TopEntity, the InitState, the TestInput
58 -- , The Environment corresponding of the loaded modules
60 loadModules libdir filenames topEntLoc initSLoc testLoc =
61 GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
62 GHC.runGhc (Just libdir) $ do
63 dflags <- GHC.getSessionDynFlags
64 GHC.setSessionDynFlags dflags
65 cores <- mapM GHC.compileToCoreModule filenames
67 top_entity <- mapM topEntLoc cores
68 init_state <- mapM initSLoc cores
69 test_input <- mapM testLoc cores
70 return (cores, top_entity, init_state, test_input, env)
75 -> HscTypes.CoreModule
76 -> m (Maybe CoreSyn.CoreBndr)
77 findBind criteria core = do
78 binders <- findBinder criteria core
81 bndrs -> return $ Just $ fst $ head bndrs
86 -> HscTypes.CoreModule
87 -> m (Maybe CoreSyn.CoreExpr)
88 findExpr criteria core = do
89 binders <- findBinder criteria core
92 bndrs -> return $ Just $ snd $ head bndrs
94 -- | Find a binder in module according to a certain criteria
97 (Var.Var -> m Bool) -- ^ The criteria to filter the binders on
98 -> HscTypes.CoreModule -- ^ The module to be inspected
99 -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
100 findBinder criteria core = do
101 let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
102 critbinds <- Monad.filterM (criteria . fst) binds
105 -- | Determine if a binder has an Annotation meeting a certain criteria
106 hasCLasHAnnotation ::
108 (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
109 -> Var.Var -- ^ The Binder
110 -> m Bool -- ^ Indicates if binder has the Annotation
111 hasCLasHAnnotation clashAnn var = do
112 let deserializer = Serialized.deserializeWithData
113 let target = Annotations.NamedTarget (Var.varName var)
114 (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
115 let annEnts = filter clashAnn anns
120 -- | Determine if a binder has a certain name
123 String -- ^ The name the binder has to have
124 -> Var.Var -- ^ The Binder
125 -> m Bool -- ^ Indicate if the binder has the name
126 hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)