X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FUtils%2FGhcTools.hs;h=022a997eca180bf5040ca7eb349efbf6a0f9fcc4;hb=0573ff02a62a58dc83d6d96263388e8f99b9722f;hp=9c5038cfd42586ba8ccd6c7b1aca998d06a8b7b7;hpb=ec4378a8a765c5a064b5cbed347b40c353c778a0;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
index 9c5038c..022a997 100644
--- "a/c\316\273ash/CLasH/Utils/GhcTools.hs"
+++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs"
@@ -1,15 +1,78 @@
-module GhcTools where
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CLasH.Utils.GhcTools where
+  
 -- Standard modules
+import qualified Monad
 import qualified System.IO.Unsafe
+import qualified Language.Haskell.TH as TH
+import qualified Maybe
 
 -- GHC API
-import qualified GHC
-import qualified GHC.Paths
+import qualified Annotations
+import qualified CoreSyn
+import qualified CoreUtils
 import qualified DynFlags
-import qualified TcRnMonad
-import qualified MonadUtils
 import qualified HscTypes
-import qualified PrelNames
+import qualified GHC
+import qualified Name
+import qualified Serialized
+import qualified Var
+import qualified Outputable
+import Outputable(($+$), (<+>), nest, empty, text, vcat)
+import qualified Class
+
+-- Local Imports
+import CLasH.Utils.Pretty
+import CLasH.Translator.TranslatorTypes
+import CLasH.Translator.Annotations
+import CLasH.Utils
+
+-- How far to indent the values after a Foo: header
+align = 20
+-- How far to indent all lines after the first
+indent = 5
+
+listBindings :: FilePath -> [FilePath] -> IO ()
+listBindings libdir filenames = do
+  (cores,_,_) <- loadModules libdir filenames Nothing
+  let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+  mapM listBinding binds
+  putStr "\n=========================\n"
+  let classes = concatMap (HscTypes.typeEnvClasses . HscTypes.cm_types) cores
+  mapM listClass classes
+  return ()
+
+-- Slightly different version of hang, that always uses vcat instead of
+-- sep, so the first line of d2 preserves its nesting.
+hang' d1 n d2 = vcat [d1, nest n d2]
+
+listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
+listBinding (b, e) = putStr $ Outputable.showSDoc $
+  (text "Binder:") <+> (text $ show b ++ "[" ++ show (Var.varUnique b) ++ "]")
+  $+$ nest indent (
+    hang' (text "Type of Binder:") align (Outputable.ppr $ Var.varType b)
+    $+$ hang' (text "Expression:") align (text $ prettyShow e)
+    $+$ nest align (Outputable.ppr e)
+    $+$ hang' (text "Type of Expression:") align (Outputable.ppr $ CoreUtils.exprType e)
+  )
+  $+$ (text "\n") -- Add an empty line
+
+listClass :: Class.Class -> IO ()
+listClass c = putStr $ Outputable.showSDoc $
+  (text "Class:") <+> (text $ show (Class.className c))
+  $+$ nest indent (
+    hang' (text "Selectors:") align (text $ show (Class.classSelIds c))
+  )
+  $+$ (text "\n") -- Add an empty line
+  
+-- | Show the core structure of the given binds in the given file.
+listBind :: FilePath -> [FilePath] -> String -> IO ()
+listBind libdir filenames name = do
+  (cores,_,_) <- loadModules libdir filenames Nothing
+  bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
+  mapM_ listBinding bindings
+  return ()
 
 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
 -- be no standard function to do exactly this.
@@ -26,19 +89,168 @@ setDynFlag dflag = do
 -- don't have side effects themselves (Or rather, that don't use
 -- unsafePerformIO themselves, since normal side effectful function would
 -- just return an IO monad when they are evaluated).
-unsafeRunGhc :: GHC.Ghc a -> a
-unsafeRunGhc m =
-  System.IO.Unsafe.unsafePerformIO $ 
-      GHC.runGhc (Just GHC.Paths.libdir) $ do
+unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
+unsafeRunGhc libDir m =
+  System.IO.Unsafe.unsafePerformIO $
+      GHC.runGhc (Just libDir) $ do
         dflags <- GHC.getSessionDynFlags
         GHC.setSessionDynFlags dflags
         m
+  
+-- | Loads the given files and turns it into a core module
+loadModules ::
+  FilePath      -- ^ The GHC Library directory 
+  -> [String]   -- ^ The files that need to be loaded
+  -> Maybe Finder -- ^ What entities to build?
+  -> IO ( [HscTypes.CoreModule]
+        , HscTypes.HscEnv
+        , [EntitySpec]
+        ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
+loadModules libdir filenames finder =
+  GHC.defaultErrorHandler DynFlags.defaultDynFlags $
+    GHC.runGhc (Just libdir) $ do
+      dflags <- GHC.getSessionDynFlags
+      GHC.setSessionDynFlags dflags
+      cores <- mapM GHC.compileToCoreModule filenames
+      env <- GHC.getSession
+      specs <- case finder of
+        Nothing -> return []
+        Just f -> concatM $ mapM f cores
+      return (cores, env, specs)
+
+findBinds ::
+  Monad m =>
+  (Var.Var -> m Bool)
+  -> HscTypes.CoreModule
+  -> m (Maybe [CoreSyn.CoreBndr])
+findBinds criteria core = do
+  binders <- findBinder criteria core
+  case binders of
+    [] -> return Nothing
+    bndrs -> return $ Just $ map fst bndrs
+
+findBind ::
+  Monad m =>
+  (Var.Var -> m Bool)
+  -> HscTypes.CoreModule
+  -> m (Maybe CoreSyn.CoreBndr)
+findBind criteria core = do
+  binders <- findBinds criteria core
+  case binders of
+    Nothing -> return Nothing
+    (Just bndrs) -> return $ Just $ head bndrs
+
+findExprs ::
+  Monad m =>
+  (Var.Var -> m Bool)
+  -> HscTypes.CoreModule
+  -> m (Maybe [CoreSyn.CoreExpr])
+findExprs criteria core = do
+  binders <- findBinder criteria core
+  case binders of
+    [] -> return Nothing
+    bndrs -> return $ Just (map snd bndrs)
+
+findExpr ::
+  Monad m =>
+  (Var.Var -> m Bool)
+  -> HscTypes.CoreModule
+  -> m (Maybe CoreSyn.CoreExpr)
+findExpr criteria core = do
+  exprs <- findExprs criteria core
+  case exprs of
+    Nothing -> return Nothing
+    (Just exprs) -> return $ Just $ head exprs
+
+findAnns ::
+  Monad m =>
+  (Var.Var -> m [CLasHAnn])
+  -> HscTypes.CoreModule
+  -> m [CLasHAnn]
+findAnns criteria core = do
+  let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
+  anns <- Monad.mapM (criteria . fst) binds
+  case anns of
+    [] -> return []
+    xs -> return $ concat xs
+
+-- | Find a binder in module according to a certain criteria
+findBinder :: 
+  Monad m =>
+  (Var.Var -> m Bool)     -- ^ The criteria to filter the binders on
+  -> HscTypes.CoreModule  -- ^ The module to be inspected
+  -> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
+findBinder criteria core = do
+  let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
+  Monad.filterM (criteria . fst) binds
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+isCLasHAnnotation ::
+  GHC.GhcMonad m =>
+  (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
+  -> Var.Var          -- ^ The Binder
+  -> m [CLasHAnn]           -- ^ Indicates if binder has the Annotation
+isCLasHAnnotation clashAnn var = do
+  let deserializer = Serialized.deserializeWithData
+  let target = Annotations.NamedTarget (Var.varName var)
+  (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+  let annEnts = filter clashAnn anns
+  return annEnts
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+hasCLasHAnnotation ::
+  GHC.GhcMonad m =>
+  (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
+  -> Var.Var          -- ^ The Binder
+  -> m Bool           -- ^ Indicates if binder has the Annotation
+hasCLasHAnnotation clashAnn var = do
+  anns <- isCLasHAnnotation clashAnn var
+  case anns of
+    [] -> return False
+    xs -> return True
+
+-- | Determine if a binder has a certain name
+hasVarName ::   
+  Monad m =>
+  String        -- ^ The name the binder has to have
+  -> Var.Var    -- ^ The Binder
+  -> m Bool     -- ^ Indicate if the binder has the name
+hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
+
+
+findInitStates ::
+  (Var.Var -> GHC.Ghc Bool) -> 
+  (Var.Var -> GHC.Ghc [CLasHAnn]) -> 
+  HscTypes.CoreModule -> 
+  GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
+findInitStates statec annsc mod = do
+  states <- findBinds statec mod
+  anns  <- findAnns annsc mod
+  let funs = Maybe.catMaybes (map extractInits anns)
+  exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
+  let exprs = Maybe.catMaybes exprs'
+  let inits = zipMWith (\a b -> (a,b)) states exprs
+  return inits
+  where
+    extractInits :: CLasHAnn -> Maybe TH.Name
+    extractInits (InitState x)  = Just x
+    extractInits _              = Nothing
+    zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
+    zipMWith _ Nothing   _  = Nothing
+    zipMWith f (Just as) bs = Just $ zipWith f as bs
+
+-- | Make a complete spec out of a three conditions
+findSpec ::
+  (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
+  -> Finder
 
-runTcM :: TcRnMonad.TcM a -> IO a
-runTcM thing_inside = do
-  GHC.runGhc (Just GHC.Paths.libdir) $ do   
-    dflags <- GHC.getSessionDynFlags
-    GHC.setSessionDynFlags dflags
-    env <- GHC.getSession
-    HscTypes.ioMsgMaybe . MonadUtils.liftIO .  TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
-      thing_inside
+findSpec topc statec annsc testc mod = do
+  top <- findBind topc mod
+  state <- findExprs statec mod
+  anns <- findAnns annsc mod
+  test <- findExpr testc mod
+  inits <- findInitStates statec annsc mod
+  return [(top, inits, test)]
+  -- case top of
+  --   Just t -> return [(t, state, test)]
+  --   Nothing -> return error $ "Could not find top entity requested"