X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FTranslator.hs;h=c35e33826b42c19dc1b8af86826c22f8093abb75;hb=4c63601269c7097e2177c547dc36d4edecc1c648;hp=c1e853aad6ede4f39c5c3cdcfe788f5c0d6b4747;hpb=d30d9fe36698d9d9b5e44099fba9ba090e54064f;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 c1e853a..c35e338 100644
--- "a/c\316\273ash/CLasH/Translator.hs"
+++ "b/c\316\273ash/CLasH/Translator.hs"
@@ -53,27 +53,29 @@ import CLasH.Translator.Annotations
 import CLasH.Utils.Pretty
 import CLasH.Normalize
 import CLasH.VHDL.VHDLTypes
+import CLasH.Utils.Core.CoreTools
 import qualified CLasH.VHDL as VHDL
 
-makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
-makeVHDL libdir filename name stateful = do
-  -- Load the module
-  (core, env) <- loadModule libdir filename
-  -- Translate to VHDL
-  vhdl <- moduleToVHDL env core [(name, stateful)]
-  -- Write VHDL to file
-  let dir = "./vhdl/" ++ name ++ "/"
-  prepareDir dir
-  mapM (writeVHDL dir) vhdl
-  return ()
+-- makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
+-- makeVHDL libdir filename name stateful = do
+--   -- Load the module
+--   (core, env) <- loadModule libdir filename
+--   -- Translate to VHDL
+--   vhdl <- moduleToVHDL env core [(name, stateful)]
+--   -- Write VHDL to file
+--   let dir = "./vhdl/" ++ name ++ "/"
+--   prepareDir dir
+--   mapM (writeVHDL dir) vhdl
+--   return ()
   
 makeVHDLAnn :: FilePath -> String -> IO ()
 makeVHDLAnn libdir filename = do
-  (core, top, init, env) <- loadModuleAnn libdir filename
+  (core, top, init, test, env) <- loadModuleAnn libdir filename
   let top_entity = head top
+  let test_expr = head test
   vhdl <- case init of 
-    [] -> moduleToVHDLAnn env core [top_entity]
-    xs -> moduleToVHDLAnnState env core [(top_entity, (head xs))]
+    [] -> moduleToVHDLAnn env core (top_entity, test_expr)
+    xs -> moduleToVHDLAnnState env core (top_entity, test_expr, (head xs))
   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
   prepareDir dir
   mapM (writeVHDL dir) vhdl
@@ -108,31 +110,31 @@ listBind libdir filename name = do
   putStr $ showSDoc $ ppr expr
   putStr "\n\n"
   putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
-  putStr "\n\n"
+  putStr "\n\n"  
 
 -- | Translate the binds with the given names from the given core module to
 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 --   stateless (False).
-moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL env core list = do
-  let (names, statefuls) = unzip list
-  let binds = map fst $ findBinds core names
-  -- 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'
-  -- Turn bind into VHDL
-  let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
-  let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
-  let vhdl = VHDL.createDesignFiles typestate normalized_bindings
-  mapM (putStr . render . Ppr.ppr . snd) vhdl
-  --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
-  return vhdl
+-- moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+-- moduleToVHDL env core list = do
+--   let (names, statefuls) = unzip list
+--   let binds = map fst $ findBinds core names
+--   -- 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'
+--   -- Turn bind into VHDL
+--   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+--   let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
+--   let vhdl = VHDL.createDesignFiles typestate normalized_bindings binds
+--   mapM (putStr . render . Ppr.ppr . snd) vhdl
+--   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+--   return vhdl
   
-moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> [CoreSyn.CoreBndr] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDLAnn env core binds = do
+moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDLAnn env core (topbind, test) = do
   -- Generate a UniqSupply
   -- Running 
   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
@@ -141,15 +143,15 @@ moduleToVHDLAnn env core binds = do
   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
   -- Turn bind into VHDL
   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
-  let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [False]
-  let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+  let testexprs = reduceCoreListToHsList test
+  let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [False]
+  let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
   mapM (putStr . render . Ppr.ppr . snd) vhdl
   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
   
-moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDLAnnState env core list = do
-  let (binds, init_states) = unzip list
+moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr, CoreSyn.CoreBndr) -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDLAnnState env core (topbind, test, init_state) = do
   -- Generate a UniqSupply
   -- Running 
   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
@@ -158,8 +160,9 @@ moduleToVHDLAnnState env core list = do
   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
   -- Turn bind into VHDL
   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
-  let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [True]
-  let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+  let testexprs = reduceCoreListToHsList test
+  let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [True]
+  let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
   mapM (putStr . render . Ppr.ppr . snd) vhdl
   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
@@ -206,7 +209,7 @@ loadModule libdir filename =
       return (core, env)
       
 -- | Loads the given file and turns it into a core module.
-loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], HscTypes.HscEnv)
+loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv)
 loadModuleAnn libdir filename =
   defaultErrorHandler defaultDynFlags $ do
     runGhc (Just libdir) $ do
@@ -222,7 +225,8 @@ loadModuleAnn libdir filename =
       env <- GHC.getSession
       top_entity <- findTopEntity core
       init_state <- findInitState core
-      return (core, top_entity, init_state, env)
+      test_input <- findTestInput core
+      return (core, top_entity, init_state, test_input, env)
 
 findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
 findTopEntity core = do
@@ -238,6 +242,13 @@ findInitState core = do
   let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds)
   return bndrs
   
+findTestInput :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreExpr]
+findTestInput core = do
+  let binds = CoreSyn.flattenBinds $ cm_binds core
+  testbinds <- Monad.filterM (hasTestInputAnnotation . fst) binds
+  let exprs = case testbinds of [] -> [] ; xs -> snd (unzip testbinds)
+  return exprs
+  
 hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool
 hasTopEntityAnnotation var = do
   let deserializer = Serialized.deserializeWithData
@@ -257,6 +268,16 @@ hasInitStateAnnotation var = do
   case top_ents of
     [] -> return False
     xs -> return True
+    
+hasTestInputAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasTestInputAnnotation var = do
+  let deserializer = Serialized.deserializeWithData
+  let target = Annotations.NamedTarget (Var.varName var)
+  (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+  let top_ents = filter isTestInput anns
+  case top_ents of
+    [] -> return False
+    xs -> return True
 
 -- | Extracts the named binds from the given module.
 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]