Rename cλash dir to clash so it behaves well within the ghc build tree

[matthijs/master-project/cλash.git] / clash / CLasH / Translator.hs

diff --git a/clash/CLasH/Translator.hs b/clash/CLasH/Translator.hs
new file mode 100644 (file)
index 0000000..6177dab
--- /dev/null
+++ b/clash/CLasH/Translator.hs
@@ -0,0 +1,142 @@
+module CLasH.Translator 
+  (
+   makeVHDLAnnotations
+  ) where
+
+-- Standard Modules
+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.Monad.Trans.State
+import qualified Data.Map as Map
+import qualified Data.Time.Clock as Clock
+import Debug.Trace
+
+-- GHC API
+import qualified CoreSyn
+import qualified HscTypes
+import qualified UniqSupply
+
+-- VHDL Imports
+import qualified Language.VHDL.AST as AST
+import qualified Language.VHDL.FileIO as FileIO
+import qualified Language.VHDL.Ppr as Ppr
+
+-- Local Imports
+import CLasH.Translator.TranslatorTypes
+import CLasH.Translator.Annotations
+import CLasH.Utils
+import CLasH.Utils.GhcTools
+import CLasH.VHDL
+import CLasH.VHDL.VHDLTools
+import CLasH.VHDL.Testbench
+
+-- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
+--   and Test Inputs found in the Files. 
+makeVHDLAnnotations :: 
+  FilePath      -- ^ The GHC Library Dir
+  -> [FilePath] -- ^ The FileNames
+  -> IO ()
+makeVHDLAnnotations libdir filenames =
+  makeVHDL libdir filenames finder
+    where
+      finder = findSpec (hasCLasHAnnotation isTopEntity)
+                        (hasCLasHAnnotation isInitState)
+                        (isCLasHAnnotation 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
+  -> Finder
+  -> IO ()
+makeVHDL libdir filenames finder = do
+  start <- Clock.getCurrentTime
+  -- Load the modules
+  (cores, env, specs) <- loadModules libdir filenames (Just finder)
+  -- Translate to VHDL
+  vhdl <- moduleToVHDL env cores specs
+  -- Write VHDL to file. Just use the first entity for the name
+  let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
+  let dir = "./vhdl/" ++ (show top_entity) ++ "/"
+  prepareDir dir
+  mapM_ (writeVHDL dir) vhdl
+  end <- Clock.getCurrentTime
+  trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $
+    return ()
+
+-- | Translate the specified entities in the given modules to VHDL.
+moduleToVHDL ::
+  HscTypes.HscEnv             -- ^ The GHC Environment
+  -> [HscTypes.CoreModule]    -- ^ The Core Modules
+  -> [EntitySpec]             -- ^ The entities to generate
+  -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env cores specs = do
+  (vhdl, count) <- runTranslatorSession env $ do
+    let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
+    -- Store the bindings we loaded
+    tsBindings %= Map.fromList all_bindings
+    let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs 
+    tsInitStates %= Map.fromList all_initstates
+    test_binds <- catMaybesM $ Monad.mapM mkTest specs
+    let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
+    vhdl <- case topbinds of
+      []  -> error "Could not find top entity requested"
+      tops -> createDesignFiles (tops ++ test_binds)
+    count <- get tsTransformCounter 
+    return (vhdl, count)
+  mapM_ (putStr . render . Ppr.ppr . snd) vhdl
+  putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
+  return vhdl
+  where
+    mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
+    -- Create a testbench for any entry that has test input
+    mkTest (_, _, Nothing) = return Nothing
+    mkTest (Nothing, _, _) = return Nothing
+    mkTest (Just top, _, Just input) = do
+      bndr <- createTestbench Nothing cores 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 builtin_types [] Map.empty Map.empty env
+  let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
+  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.
+prepareDir :: String -> IO()
+prepareDir dir = do
+  -- Create the dir if needed
+  Directory.createDirectoryIfMissing True dir
+  -- Find all .vhdl files in the directory
+  files <- Directory.getDirectoryContents dir
+  let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
+  -- Prepend the dirname to the filenames
+  let abs_to_remove = map (FilePath.combine dir) to_remove
+  -- Remove the files
+  mapM_ Directory.removeFile abs_to_remove
+
+-- | Write the given design file to a file with the given name inside the
+--   given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, vhdl) = do
+  -- Find the filename
+  let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
+  -- Write the file
+  FileIO.writeDesignFile vhdl fname
+
+-- vim: set ts=8 sw=2 sts=2 expandtab: