Restructure the "finder" functions.

Previously, there were three different functions for the top entity,
initial state and test input. Now, there is just a single one, which
guarantees that these things are properly linked together. This should no
also support generating multiple entities at the same time (though there
is no top level interface for this yet).

This change also makes the testbench generation optional. A bunch of
functions were moved from Utils to GhcTools, to prevent a dependency loop.

diff --git a/cλash/CLasH/Translator.hs b/cλash/CLasH/Translator.hs
index fb02355b96156383a2112742b841bc50aa53ed57..c4daf04d0dedb9963e79b1d860b24644321c5d05 100644 (file)
--- a/cλash/CLasH/Translator.hs
+++ b/cλash/CLasH/Translator.hs
@@ -28,6 +28,7 @@ import qualified Language.VHDL.Ppr as Ppr
 import CLasH.Normalize
 import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
+import CLasH.Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.GhcTools
 import CLasH.VHDL
@@ -44,11 +45,11 @@ makeVHDLStrings ::
   -> Bool       -- ^ Is it stateful? (in case InitState is empty)
   -> IO ()
 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
-  makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+  makeVHDL libdir filenames finder stateful
     where
-      findTopEntity = findBind (hasVarName topentity)
-      findInitState = findBind (hasVarName initstate)
-      findTestInput = findExpr (hasVarName testinput)
+      finder = findSpec (hasVarName topentity)
+                        (hasVarName initstate)
+                        (hasVarName testinput)
 
 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
 --   and Test Inputs found in the Files. 
@@ -58,29 +59,27 @@ makeVHDLAnnotations ::
   -> Bool       -- ^ Is it stateful? (in case InitState is not specified)
   -> IO ()
 makeVHDLAnnotations libdir filenames stateful = do
-  makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+  makeVHDL libdir filenames finder stateful
     where
-      findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
-      findInitState = findBind (hasCLasHAnnotation isInitState)
-      findTestInput = findExpr (hasCLasHAnnotation isTestInput)
+      finder = findSpec (hasCLasHAnnotation isTopEntity)
+                        (hasCLasHAnnotation isInitState)
+                        (hasCLasHAnnotation isTestInput)
 
 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
 --   Entity, Initial State and Test Inputs in the Haskell Files.
 makeVHDL ::
   FilePath      -- ^ The GHC Library Dir
   -> [FilePath] -- ^ The Filenames
-  -> (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
+  -> Finder
   -> Bool       -- ^ Indicates if it is meant to be stateful
   -> IO ()
-makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
+makeVHDL libdir filenames finder stateful = do
   -- Load the modules
-  (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
+  (cores, env, specs) <- loadModules libdir filenames (Just finder)
   -- Translate to VHDL
-  vhdl <- moduleToVHDL env cores top init test stateful
-  -- Write VHDL to file
-  let top_entity = Maybe.fromJust $ head top
+  vhdl <- moduleToVHDL env cores specs stateful
+  -- Write VHDL to file. Just use the first entity for the name
+  let top_entity = (\(t, _, _) -> t) $ head specs
   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
   prepareDir dir
   mapM (writeVHDL dir) vhdl
@@ -92,23 +91,26 @@ makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful
 moduleToVHDL ::
   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
+  -> [EntitySpec]             -- ^ The entities to generate
   -> Bool                     -- ^ Is it stateful (in case InitState is not specified)
   -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env cores topbinds' init test stateful = do
-  let topbinds = Maybe.catMaybes topbinds'
-  let initialState = Maybe.catMaybes init
-  let testInput = Maybe.catMaybes test
+moduleToVHDL env cores specs stateful = do
   vhdl <- runTranslatorSession env $ do
     let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
     -- Store the bindings we loaded
     tsBindings %= Map.fromList all_bindings 
-    test_binds <- Monad.zipWithM (createTestbench Nothing) testInput topbinds
+    test_binds <- catMaybesM $ Monad.mapM mkTest specs
+    let topbinds = map (\(top, _, _) -> top) specs
     createDesignFiles (topbinds ++ test_binds)
   mapM (putStr . render . Ppr.ppr . snd) vhdl
   return vhdl
+  where
+    mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
+    -- Create a testbench for any entry that has test input
+    mkTest (_, _, Nothing) = return Nothing
+    mkTest (top, _, Just input) = do
+      bndr <- createTestbench Nothing input top
+      return $ Just bndr
 
 -- Run the given translator session. Generates a new UniqSupply for that
 -- session.

diff --git a/cλash/CLasH/Translator/TranslatorTypes.hs b/cλash/CLasH/Translator/TranslatorTypes.hs
index de7ee52055b23835174e29571c8172df04705283..257c543e2f9f799980f8035ab89bb7ac4b009050 100644 (file)
--- a/cλash/CLasH/Translator/TranslatorTypes.hs
+++ b/cλash/CLasH/Translator/TranslatorTypes.hs
@@ -12,6 +12,7 @@ import qualified Data.Accessor.Template
 import Data.Accessor
 
 -- GHC API
+import qualified GHC
 import qualified CoreSyn
 import qualified Type
 import qualified HscTypes
@@ -23,6 +24,20 @@ import qualified Language.VHDL.AST as AST
 -- Local imports
 import CLasH.VHDL.VHDLTypes
 
+-- | A specification of an entity we can generate VHDL for. Consists of the
+--   binder of the top level entity, an optional initial state and an optional
+--   test input.
+type EntitySpec = (CoreSyn.CoreBndr, Maybe CoreSyn.CoreExpr, Maybe CoreSyn.CoreExpr)
+
+-- | A function that knows which parts of a module to compile
+type Finder =
+  HscTypes.CoreModule -- ^ The module to look at
+  -> GHC.Ghc [EntitySpec]
+
+-----------------------------------------------------------------------------
+-- The TranslatorSession
+-----------------------------------------------------------------------------
+
 -- A orderable equivalent of CoreSyn's Type for use as a map key
 newtype OrdType = OrdType { getType :: Type.Type }
 instance Eq OrdType where

diff --git a/cλash/CLasH/Utils.hs b/cλash/CLasH/Utils.hs
index 731de270b56ccb9764d589bc18102dea6d90705e..484fe15ae2e33d43e3dd4b9bfee6fa4ee30117b1 100644 (file)
--- a/cλash/CLasH/Utils.hs
+++ b/cλash/CLasH/Utils.hs
@@ -8,47 +8,9 @@ import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 
 -- 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)
-
 -- Make a caching version of a stateful computatation.
 makeCached :: (Monad m, Ord k) =>
   k -- ^ The key to use for the cache

diff --git a/cλash/CLasH/Utils/GhcTools.hs b/cλash/CLasH/Utils/GhcTools.hs
index 0c8c55980acbffd6ec6be06af544453f2b21f192..5a041cc021173b79fbcb1ccd3cee14dee6808d8e 100644 (file)
--- a/cλash/CLasH/Utils/GhcTools.hs
+++ b/cλash/CLasH/Utils/GhcTools.hs
@@ -9,15 +9,48 @@ import qualified System.IO.Unsafe
 -- 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 Outputable
 
 -- Local Imports
+import CLasH.Utils.Pretty
+import CLasH.Translator.TranslatorTypes
 import CLasH.Translator.Annotations
+import CLasH.Utils
+
+listBindings :: FilePath -> [FilePath] -> IO [()]
+listBindings libdir filenames = do
+  (cores,_,_) <- loadModules libdir filenames Nothing
+  let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+  mapM (listBinding) binds
+
+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
+  (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.
@@ -46,31 +79,25 @@ unsafeRunGhc libDir m =
 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]
-        , [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 =
+        , [EntitySpec]
+        ) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
+loadModules libdir filenames finder =
   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)
+      specs <- case finder of
+        Nothing -> return []
+        Just f -> concatM $ mapM f cores
+      return (cores, env, specs)
 
 findBind ::
-  GHC.GhcMonad m =>
+  Monad m =>
   (Var.Var -> m Bool)
   -> HscTypes.CoreModule
   -> m (Maybe CoreSyn.CoreBndr)
@@ -81,7 +108,7 @@ findBind criteria core = do
     bndrs -> return $ Just $ fst $ head bndrs
 
 findExpr ::
-  GHC.GhcMonad m =>
+  Monad m =>
   (Var.Var -> m Bool)
   -> HscTypes.CoreModule
   -> m (Maybe CoreSyn.CoreExpr)
@@ -93,7 +120,7 @@ findExpr criteria core = do
 
 -- | 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
@@ -119,8 +146,21 @@ hasCLasHAnnotation clashAnn var = do
 
 -- | 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
 hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
+
+-- | Make a complete spec out of a three conditions
+findSpec ::
+  (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool)
+  -> Finder
+
+findSpec topc statec testc mod = do
+  top <- findBind topc mod
+  state <- findExpr statec mod
+  test <- findExpr testc mod
+  case top of
+    Just t -> return [(t, state, test)]
+    Nothing -> error $ "Could not find top entity requested"