update cabal file to upload to hackage

[matthijs/master-project/cλash.git] / cλash / CLasH / Utils / GhcTools.hs

diff --git a/cλash/CLasH/Utils/GhcTools.hs b/cλash/CLasH/Utils/GhcTools.hs
index 0c8c55980acbffd6ec6be06af544453f2b21f192..f1fe6ba61b2547d494f5709f5bb10f375e4f5d62 100644 (file)
--- a/cλash/CLasH/Utils/GhcTools.hs
+++ b/cλash/CLasH/Utils/GhcTools.hs
@@ -5,19 +5,67 @@ module CLasH.Utils.GhcTools where
 -- Standard modules
 import qualified Monad
 import qualified System.IO.Unsafe
 -- Standard modules
 import qualified Monad
 import qualified System.IO.Unsafe

+import qualified Language.Haskell.TH as TH
+import qualified Maybe

 
 -- GHC API
 import qualified Annotations
 import qualified CoreSyn
 
 -- GHC API
 import qualified Annotations
 import qualified CoreSyn

+import qualified CoreUtils

 import qualified DynFlags
 import qualified HscTypes
 import qualified GHC
 import qualified Name
 import qualified Serialized
 import qualified Var
 import qualified DynFlags
 import qualified HscTypes
 import qualified GHC
 import qualified Name
 import qualified Serialized
 import qualified Var

+import qualified Outputable
+import qualified Class

 
 -- Local Imports
 
 -- Local Imports

+import CLasH.Utils.Pretty
+import CLasH.Translator.TranslatorTypes

 import CLasH.Translator.Annotations
 import CLasH.Translator.Annotations

+import CLasH.Utils
+
+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 ()
+
+listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
+listBinding (b, e) = do
+  putStr "\nBinder: "
+  putStr $ show b ++ "[" ++ show (Var.varUnique b) ++ "]"
+  putStr "\nType of Binder: \n"
+  putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
+  putStr "\n\nExpression: \n"
+  putStr $ prettyShow e
+  putStr "\n\n"
+  putStr $ Outputable.showSDoc $ Outputable.ppr e
+  putStr "\n\nType of Expression: \n"
+  putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
+  putStr "\n\n"
+
+listClass :: Class.Class -> IO ()
+listClass c = do
+  putStr "\nClass: "
+  putStr $ show (Class.className c)
+  putStr "\nSelectors: "
+  putStr $ show (Class.classSelIds c)
+  putStr "\n"
+  
+-- | 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.
 
 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
 -- be no standard function to do exactly this.


@@ -36,7 +84,7 @@ setDynFlag dflag = do
 -- just return an IO monad when they are evaluated).
 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
 unsafeRunGhc libDir m =
 -- just return an IO monad when they are evaluated).
 unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
 unsafeRunGhc libDir m =

-  System.IO.Unsafe.unsafePerformIO $ do
+  System.IO.Unsafe.unsafePerformIO $

       GHC.runGhc (Just libDir) $ do
         dflags <- GHC.getSessionDynFlags
         GHC.setSessionDynFlags dflags
       GHC.runGhc (Just libDir) $ do
         dflags <- GHC.getSessionDynFlags
         GHC.setSessionDynFlags dflags


@@ -46,81 +94,156 @@ unsafeRunGhc libDir m =
 loadModules ::
   FilePath      -- ^ The GHC Library directory 
   -> [String]   -- ^ The files that need to be loaded
 loadModules ::
   FilePath      -- ^ The GHC Library directory 
   -> [String]   -- ^ The files that need to be loaded

-  -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The TopEntity finder
-  -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The InitState finder
-  -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The TestInput finder
+  -> Maybe Finder -- ^ What entities to build?

   -> IO ( [HscTypes.CoreModule]
   -> IO ( [HscTypes.CoreModule]

-        , [Maybe CoreSyn.CoreBndr]
-        , [Maybe CoreSyn.CoreBndr]
-        , [Maybe CoreSyn.CoreExpr]

         , HscTypes.HscEnv
         , HscTypes.HscEnv

-        ) -- ^ ( The loaded modules, the TopEntity, the InitState, the TestInput
-          --   , The Environment corresponding of the loaded modules
-          --   )
-loadModules libdir filenames topEntLoc initSLoc testLoc =
-  GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
+        , [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
     GHC.runGhc (Just libdir) $ do
       dflags <- GHC.getSessionDynFlags
       GHC.setSessionDynFlags dflags
       cores <- mapM GHC.compileToCoreModule filenames
       env <- GHC.getSession

-      top_entity <- mapM topEntLoc cores
-      init_state <- mapM initSLoc cores
-      test_input <- mapM testLoc cores
-      return (cores, top_entity, init_state, test_input, env)
+      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 ::
 
 findBind ::

-  GHC.GhcMonad m =>
+  Monad m =>

   (Var.Var -> m Bool)
   -> HscTypes.CoreModule
   -> m (Maybe CoreSyn.CoreBndr)
 findBind criteria core = do
   (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
   binders <- findBinder criteria core
   case binders of
     [] -> return Nothing

-    bndrs -> return $ Just $ fst $ head bndrs
+    bndrs -> return $ Just (map snd bndrs)

 
 findExpr ::
 
 findExpr ::

-  GHC.GhcMonad m =>
+  Monad m =>

   (Var.Var -> m Bool)
   -> HscTypes.CoreModule
   -> m (Maybe CoreSyn.CoreExpr)
 findExpr criteria core = do
   (Var.Var -> m Bool)
   -> HscTypes.CoreModule
   -> m (Maybe CoreSyn.CoreExpr)
 findExpr criteria core = do

-  binders <- findBinder criteria core
-  case binders of
-    [] -> return Nothing
-    bndrs -> return $ Just $ snd $ head bndrs
+  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 :: 
 
 -- | Find a binder in module according to a certain criteria
 findBinder :: 

-  GHC.GhcMonad m =>
+  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
   (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

-  critbinds <- Monad.filterM (criteria . fst) binds
-  return critbinds
+  Monad.filterM (criteria . fst) binds

 
 -- | Determine if a binder has an Annotation meeting a certain criteria
 
 -- | Determine if a binder has an Annotation meeting a certain criteria

-hasCLasHAnnotation ::
+isCLasHAnnotation ::

   GHC.GhcMonad m =>
   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
   -> Var.Var          -- ^ The Binder
   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
+  -> 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
   let deserializer = Serialized.deserializeWithData
   let target = Annotations.NamedTarget (Var.varName var)
   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
   let annEnts = filter clashAnn anns

-  case annEnts of
+  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 ::   
     [] -> return False
     xs -> return True
 
 -- | Determine if a binder has a certain name
 hasVarName ::   

-  GHC.GhcMonad m =>
+  Monad m =>

   String        -- ^ The name the binder has to have
   -> Var.Var    -- ^ The Binder
   -> m Bool     -- ^ Indicate if the binder has the name
   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)
+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
+
+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"