X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FTranslator.hs;h=c35e33826b42c19dc1b8af86826c22f8093abb75;hb=04de89474351850ea9dca0350fa383f1b2aff8ea;hp=7203296191061270cbc2c23ce3c1423cfc721ba0;hpb=b2967df7f237e5b4db15d069895ca01c31712d9e;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 7203296..c35e338 100644
--- "a/c\316\273ash/CLasH/Translator.hs"
+++ "b/c\316\273ash/CLasH/Translator.hs"
@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module CLasH.Translator where
 
 import qualified Directory
@@ -19,6 +21,7 @@ import qualified Maybe
 import qualified Module
 import qualified Data.Foldable as Foldable
 import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad as Monad
 import Name
 import qualified Data.Map as Map
 import Data.Accessor
@@ -28,12 +31,13 @@ import qualified HscTypes
 import HscTypes ( cm_binds, cm_types )
 import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr, showSDocDebug )
-import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )
 import qualified UniqSupply
 import List ( find )
 import qualified List
 import qualified Monad
+import qualified Annotations
+import qualified Serialized
 
 -- The following modules come from the ForSyDe project. They are really
 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
@@ -45,26 +49,41 @@ import qualified Language.VHDL.Ppr as Ppr
 import Text.PrettyPrint.HughesPJ (render)
 
 import CLasH.Translator.TranslatorTypes
+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 :: String -> String -> Bool -> IO ()
-makeVHDL filename name stateful = do
-  -- Load the module
-  (core, env) <- loadModule filename
-  -- Translate to VHDL
-  vhdl <- moduleToVHDL env core [(name, stateful)]
-  -- Write VHDL to file
-  let dir = "./vhdl/" ++ name ++ "/"
+-- 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, test, env) <- loadModuleAnn libdir filename
+  let top_entity = head top
+  let test_expr = head test
+  vhdl <- case init of 
+    [] -> 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
   return ()
 
-listBindings :: String -> IO [()]
-listBindings filename = do
-  (core, env) <- loadModule filename
+listBindings :: FilePath -> String -> IO [()]
+listBindings libdir filename = do
+  (core, env) <- loadModule libdir filename
   let binds = CoreSyn.flattenBinds $ cm_binds core
   mapM (listBinding) binds
 
@@ -81,9 +100,9 @@ listBinding (b, e) = do
   putStr "\n\n"
   
 -- | Show the core structure of the given binds in the given file.
-listBind :: String -> String -> IO ()
-listBind filename name = do
-  (core, env) <- loadModule filename
+listBind :: FilePath -> String -> String -> IO ()
+listBind libdir filename name = do
+  (core, env) <- loadModule libdir filename
   let [(b, expr)] = findBinds core [name]
   putStr "\n"
   putStr $ prettyShow expr
@@ -91,15 +110,31 @@ listBind 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
+-- 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, CoreSyn.CoreExpr) -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDLAnn env core (topbind, test) = do
   -- Generate a UniqSupply
   -- Running 
   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
@@ -108,12 +143,29 @@ moduleToVHDL 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 statefuls
-  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.CoreExpr, CoreSyn.CoreBndr) -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDLAnnState env core (topbind, test, init_state) = 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'
+  -- Turn bind into VHDL
+  let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+  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
-  where
 
 -- | 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.
@@ -140,8 +192,8 @@ writeVHDL dir (name, vhdl) = do
   Language.VHDL.FileIO.writeDesignFile vhdl fname
 
 -- | Loads the given file and turns it into a core module.
-loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
-loadModule filename =
+loadModule :: FilePath -> String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
+loadModule libdir filename =
   defaultErrorHandler defaultDynFlags $ do
     runGhc (Just libdir) $ do
       dflags <- getSessionDynFlags
@@ -155,6 +207,77 @@ loadModule filename =
       core <- GHC.compileToCoreModule filename
       env <- GHC.getSession
       return (core, env)
+      
+-- | Loads the given file and turns it into a core module.
+loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv)
+loadModuleAnn libdir filename =
+  defaultErrorHandler defaultDynFlags $ do
+    runGhc (Just libdir) $ do
+      dflags <- getSessionDynFlags
+      setSessionDynFlags dflags
+      --target <- guessTarget "adder.hs" Nothing
+      --liftIO (print (showSDoc (ppr (target))))
+      --liftIO $ printTarget target
+      --setTargets [target]
+      --load LoadAllTargets
+      --core <- GHC.compileToCoreSimplified "Adders.hs"
+      core <- GHC.compileToCoreModule filename
+      env <- GHC.getSession
+      top_entity <- findTopEntity core
+      init_state <- findInitState core
+      test_input <- findTestInput core
+      return (core, top_entity, init_state, test_input, env)
+
+findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
+findTopEntity core = do
+  let binds = CoreSyn.flattenBinds $ cm_binds core
+  topbinds <- Monad.filterM (hasTopEntityAnnotation . fst) binds
+  let bndrs = case topbinds of [] -> error $ "Couldn't find top entity in current module." ; xs -> fst (unzip topbinds)
+  return bndrs
+  
+findInitState :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
+findInitState core = do
+  let binds = CoreSyn.flattenBinds $ cm_binds core
+  statebinds <- Monad.filterM (hasInitStateAnnotation . fst) binds
+  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
+  let target = Annotations.NamedTarget (Var.varName var)
+  (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+  let top_ents = filter isTopEntity anns
+  case top_ents of
+    [] -> return False
+    xs -> return True
+    
+hasInitStateAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasInitStateAnnotation var = do
+  let deserializer = Serialized.deserializeWithData
+  let target = Annotations.NamedTarget (Var.varName var)
+  (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+  let top_ents = filter isInitState anns
+  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)]