X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FTranslator.hs;h=c4daf04d0dedb9963e79b1d860b24644321c5d05;hb=adf357ab8731531dfea0a21254cfc613031e083a;hp=8f2c7dc98d2b05e7bc7bd2ea6baa71a95cb7ac9f;hpb=44524c8947d2f331e5c488652cb7d9774aacf8d4;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs"
index 8f2c7dc..c4daf04 100644
--- "a/c\316\273ash/CLasH/Translator.hs"
+++ "b/c\316\273ash/CLasH/Translator.hs"
@@ -8,7 +8,10 @@ import qualified System.Directory as Directory
 import qualified Maybe
 import qualified Monad
 import qualified System.FilePath as FilePath
+import qualified Control.Monad.Trans.State as State
 import Text.PrettyPrint.HughesPJ (render)
+import Data.Accessor
+import qualified Data.Map as Map
 
 -- GHC API
 import qualified CoreSyn
@@ -23,10 +26,13 @@ import qualified Language.VHDL.Ppr as Ppr
 
 -- Local Imports
 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
+import CLasH.VHDL.Testbench
 
 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
 --   State and Test Inputs.
@@ -39,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. 
@@ -53,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
@@ -87,27 +91,40 @@ 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 top init test stateful = do
-  let topEntity = Maybe.catMaybes top
-  case topEntity of
-    [] -> error "Top Entity Not Found"
-    [topEnt] -> do
-      let initialState = Maybe.catMaybes init
-      let isStateful = not (null initialState) || stateful
-      let testInput = Maybe.catMaybes test
-      uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
-      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
-      mapM (putStr . render . Ppr.ppr . snd) vhdl
-      return vhdl
-    xs -> error "More than one topentity found"
+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 <- 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.
+runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
+runTranslatorSession env session = do
+  -- Generate a UniqSupply
+  -- Running 
+  --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+  -- on the compiler dir of ghc suggests that 'z' is not used to generate
+  -- a unique supply anywhere.
+  uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+  let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
+  let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty Map.empty Map.empty
+  return $ State.evalState session init_state
 
 -- | Prepares the directory for writing VHDL files. This means creating the
 --   dir if it does not exist and removing all existing .vhdl files from it.