Bring back listBind(ings) in Utils.hs by reorganising Translator.hs and GhcTools.hs

diff --git a/cλash/CLasH/Translator.hs b/cλash/CLasH/Translator.hs
index 5f9978e19e8f5b61681dc3e65c1799e5e4e38190..7ea489f7d2a439926cb8d0376978841c46b57cc9 100644 (file)
--- a/cλash/CLasH/Translator.hs
+++ b/cλash/CLasH/Translator.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-}
-
-module CLasH.Translator (makeVHDLStrings, makeVHDLAnnotations) where
+module CLasH.Translator 
+  ( makeVHDLStrings
+  , makeVHDLAnnotations
+  ) where
 
 -- Standard Modules
 import qualified Directory
@@ -10,16 +11,10 @@ import qualified System.FilePath as FilePath
 import Text.PrettyPrint.HughesPJ (render)
 
 -- GHC API
-import qualified Annotations
-import CoreSyn
-import DynFlags ( defaultDynFlags )
-import GHC hiding (loadModule, sigName)
+import qualified CoreSyn
+import qualified GHC
 import qualified HscTypes
-import HscTypes ( cm_binds, cm_types )
-import Name
-import qualified Serialized
 import qualified UniqSupply
-import qualified Var
 
 -- VHDL Imports
 import qualified Language.VHDL.AST as AST
@@ -27,9 +22,10 @@ import qualified Language.VHDL.FileIO
 import qualified Language.VHDL.Ppr as Ppr
 
 -- Local Imports
-import CLasH.Translator.Annotations
 import CLasH.Normalize
+import CLasH.Translator.Annotations
 import CLasH.Utils.Core.CoreTools
+import CLasH.Utils.GhcTools
 import CLasH.VHDL
 
 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
@@ -68,9 +64,9 @@ makeVHDLAnnotations libdir filenames stateful = do
 makeVHDL ::
   FilePath      -- ^ The GHC Library Dir
   -> [FilePath] -- ^ The Filenames
-  -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Top Entity Finder
-  -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Init State Finder
-  -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The Test Input Finder
+  -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
+  -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
+  -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
   -> Bool       -- ^ Indicates if it is meant to be stateful
   -> IO ()
 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
@@ -89,12 +85,12 @@ makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful
 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 --   stateless (False).
 moduleToVHDL ::
-  HscTypes.HscEnv           -- ^ The GHC Environment
-  -> [HscTypes.CoreModule]  -- ^ The Core Modules
-  -> [Maybe CoreBndr]       -- ^ The TopEntity
-  -> [Maybe CoreBndr]       -- ^ The InitState
-  -> [Maybe CoreExpr]       -- ^ The TestInput
-  -> Bool                   -- ^ Is it stateful (in case InitState is not specified)
+  HscTypes.HscEnv             -- ^ The GHC Environment
+  -> [HscTypes.CoreModule]    -- ^ The Core Modules
+  -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
+  -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
+  -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
+  -> Bool                     -- ^ Is it stateful (in case InitState is not specified)
   -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL env cores top init test stateful = do
   let topEntity = Maybe.catMaybes top
@@ -105,7 +101,7 @@ moduleToVHDL env cores top init test stateful = do
       let isStateful = not (null initialState) || stateful
       let testInput = Maybe.catMaybes test
       uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
-      let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (cm_binds x)) cores)
+      let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
       let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
       let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
       let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
@@ -137,76 +133,4 @@ writeVHDL dir (name, vhdl) = do
   -- Write the file
   Language.VHDL.FileIO.writeDesignFile vhdl fname
 
--- | 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
-  -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder
-  -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder
-  -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder
-  -> IO ( [HscTypes.CoreModule]
-        , [Maybe CoreBndr]
-        , [Maybe CoreBndr]
-        , [Maybe CoreExpr]
-        , HscTypes.HscEnv
-        ) -- ^ (The loaded modules , The TopEntity , The InitState, The TestInput, The Environment corresponding ot the loaded modules)
-loadModules libdir filenames topEntLoc initSLoc testLoc =
-  defaultErrorHandler defaultDynFlags $ do
-    runGhc (Just libdir) $ do
-      dflags <- getSessionDynFlags
-      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)
-
--- | Find a binder in module according to a certain criteria
-findBind :: 
-  GhcMonad m =>
-  (Var.Var -> m Bool)     -- ^ The criteria to filter the binds on
-  -> HscTypes.CoreModule  -- ^ The module to be inspected
-  -> m (Maybe CoreBndr)   -- ^ The (first) bind to meet the criteria
-findBind annotation core = do
-  let binds = CoreSyn.flattenBinds $ cm_binds core
-  annbinds <- Monad.filterM (annotation . fst) binds
-  let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
-  return bndr
-
--- | Find an expresion in module according to a certain criteria  
-findExpr :: 
-  GhcMonad m =>
-  (Var.Var -> m Bool)     -- ^ The criteria to filter the binds on
-  -> HscTypes.CoreModule  -- ^ The module to be inspected
-  -> m (Maybe CoreExpr)   -- ^ The (first) expr to meet the criteria
-findExpr annotation core = do
-  let binds = CoreSyn.flattenBinds $ cm_binds core
-  annbinds <- Monad.filterM (annotation . fst) binds
-  let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
-  return exprs
-
--- | Determine if a binder has an Annotation meeting a certain criteria
-hasCLasHAnnotation ::
-  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
-  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 False
-    xs -> return True
-
--- | Determine if a binder has a certain name
-hasVarName ::   
-  GhcMonad 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 == (occNameString $ nameOccName $ getName bind)
-
 -- vim: set ts=8 sw=2 sts=2 expandtab:

diff --git a/cλash/CLasH/Utils.hs b/cλash/CLasH/Utils.hs
new file mode 100644 (file)
index 0000000..c539c79
--- /dev/null
+++ b/cλash/CLasH/Utils.hs
@@ -0,0 +1,49 @@
+module CLasH.Utils
+  ( listBindings
+  , listBind
+  ) where
+
+-- Standard Imports
+import qualified Maybe
+
+-- GHC API
+import qualified CoreSyn
+import qualified CoreUtils
+import qualified HscTypes
+import qualified Outputable
+import qualified Var
+
+-- Local Imports
+import CLasH.Utils.GhcTools
+import CLasH.Utils.Pretty
+  
+listBindings :: FilePath -> [FilePath] -> IO [()]
+listBindings libdir filenames = do
+  (cores,_,_,_,_) <- loadModules libdir filenames bogusFinder bogusFinder bogusFinder
+  let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+  mapM (listBinding) binds
+    where
+      bogusFinder = (\x -> return $ Nothing)
+
+listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
+listBinding (b, e) = do
+  putStr "\nBinder: "
+  putStr $ show 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"
+  
+-- | Show the core structure of the given binds in the given file.
+listBind :: FilePath -> [FilePath] -> String -> IO ()
+listBind libdir filenames name = do
+  (_,corebind,_,coreexpr,_) <- loadModules libdir filenames bindFinder bindFinder exprFinder
+  listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr)
+    where
+      bindFinder  = findBind (hasVarName name)
+      exprFinder  = findExpr (hasVarName name)
\ No newline at end of file

diff --git a/cλash/CLasH/Utils/GhcTools.hs b/cλash/CLasH/Utils/GhcTools.hs
index 3f032d901203325fb52cac1dd3ebef6541a8ccec..0c8c55980acbffd6ec6be06af544453f2b21f192 100644 (file)
--- a/cλash/CLasH/Utils/GhcTools.hs
+++ b/cλash/CLasH/Utils/GhcTools.hs
@@ -1,14 +1,23 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module CLasH.Utils.GhcTools where
+  
 -- Standard modules
+import qualified Monad
 import qualified System.IO.Unsafe
 
 -- GHC API
-import qualified GHC
+import qualified Annotations
+import qualified CoreSyn
 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
+
+-- Local Imports
+import CLasH.Translator.Annotations
 
 -- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
 -- be no standard function to do exactly this.
@@ -32,12 +41,86 @@ unsafeRunGhc libDir m =
         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
+  -> (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
+  -> IO ( [HscTypes.CoreModule]
+        , [Maybe CoreSyn.CoreBndr]
+        , [Maybe CoreSyn.CoreBndr]
+        , [Maybe CoreSyn.CoreExpr]
+        , 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
+    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)
+
+findBind ::
+  GHC.GhcMonad m =>
+  (Var.Var -> m Bool)
+  -> HscTypes.CoreModule
+  -> m (Maybe CoreSyn.CoreBndr)
+findBind criteria core = do
+  binders <- findBinder criteria core
+  case binders of
+    [] -> return Nothing
+    bndrs -> return $ Just $ fst $ head bndrs
+
+findExpr ::
+  GHC.GhcMonad m =>
+  (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
+
+-- | Find a binder in module according to a certain criteria
+findBinder :: 
+  GHC.GhcMonad 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
+  critbinds <- Monad.filterM (criteria . fst) binds
+  return critbinds
+
+-- | 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
+  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 False
+    xs -> return True
 
--- 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
+-- | Determine if a binder has a certain name
+hasVarName ::   
+  GHC.GhcMonad 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)

diff --git a/cλash/clash.cabal b/cλash/clash.cabal
index 529772c1543cf69f865a021ed95ef5d5f17e539e..fb44457a57412eb5ff90f8034096f6c7b54684d6 100644 (file)
--- a/cλash/clash.cabal
+++ b/cλash/clash.cabal
@@ -22,8 +22,9 @@ Library
                     filepath, template-haskell, data-accessor-template,
                     prettyclass
                     
-  exposed-modules:  CLasH.Translator,
+  exposed-modules:  CLasH.Translator
                     CLasH.Translator.Annotations
+                    CLasH.Utils
                     
   other-modules:    CLasH.Translator.TranslatorTypes
                     CLasH.Normalize