X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=85f790a6a979baac92c54a632f4798c86f2a8dfb;hb=78b45072fc36c7311bee97f2d9195bbc33b994cf;hp=0f60277671f99b646ec427deb8fd82ce92d53169;hpb=e230d86ae7135a268a72cdffba947a9011001ec2;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 0f60277..85f790a 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,5 +1,6 @@
 module Translator where
 import qualified Directory
+import qualified System.FilePath as FilePath
 import qualified List
 import Debug.Trace
 import qualified Control.Arrow as Arrow
@@ -25,7 +26,7 @@ import NameEnv ( lookupNameEnv )
 import qualified HscTypes
 import HscTypes ( cm_binds, cm_types )
 import MonadUtils ( liftIO )
-import Outputable ( showSDoc, ppr )
+import Outputable ( showSDoc, ppr, showSDocDebug )
 import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )
 import qualified UniqSupply
@@ -52,9 +53,6 @@ import FlattenTypes
 import VHDLTypes
 import qualified VHDL
 
--- main = do
---   makeVHDL "Alu.hs" "exec" True
-
 makeVHDL :: String -> String -> Bool -> IO ()
 makeVHDL filename name stateful = do
   -- Load the module
@@ -63,9 +61,28 @@ makeVHDL filename name stateful = do
   vhdl <- moduleToVHDL core [(name, stateful)]
   -- Write VHDL to file
   let dir = "./vhdl/" ++ name ++ "/"
+  prepareDir dir
   mapM (writeVHDL dir) vhdl
   return ()
 
+listBindings :: String -> IO [()]
+listBindings filename = do
+  core <- loadModule filename
+  let binds = CoreSyn.flattenBinds $ cm_binds core
+  mapM (listBinding) binds
+
+listBinding :: (CoreBndr, CoreExpr) -> IO ()
+listBinding (b, e) = do
+  putStr "\nBinder: "
+  putStr $ show b
+  putStr "\nExpression: \n"
+  putStr $ prettyShow e
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr e
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr $ CoreUtils.exprType e
+  putStr "\n\n"
+  
 -- | Show the core structure of the given binds in the given file.
 listBind :: String -> String -> IO ()
 listBind filename name = do
@@ -85,7 +102,7 @@ listBind filename name = do
 moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL core list = do
   let (names, statefuls) = unzip list
-  let binds = findBinds core names
+  let binds = map fst $ findBinds core names
   -- Generate a UniqSupply
   -- Running 
   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
@@ -93,31 +110,33 @@ moduleToVHDL core list = do
   -- unique supply anywhere.
   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
   -- Turn bind into VHDL
-  let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty)
+  let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+  let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
+  let vhdl = VHDL.createDesignFiles normalized_bindings
   mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
-  putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+  --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
   where
-    -- Turns the given bind into VHDL
-    mkVHDL :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
-    mkVHDL uniqSupply binds statefuls = do
-      let binds'' = map (Arrow.second $ normalize uniqSupply) binds
-      let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds''
-      -- Add the builtin functions
-      --mapM addBuiltIn builtin_funcs
-      -- Create entities and architectures for them
-      --Monad.zipWithM processBind statefuls binds
-      --modA tsFlatFuncs (Map.map nameFlatFunction)
-      --flatfuncs <- getA tsFlatFuncs
-      return $ VHDL.createDesignFiles binds'
+
+-- | 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
+  exists <- Directory.doesDirectoryExist dir
+  Monad.unless exists $ Directory.createDirectory 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
-  -- Create the dir if needed
-  exists <- Directory.doesDirectoryExist dir
-  Monad.unless exists $ Directory.createDirectory dir
   -- Find the filename
   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
   -- Write the file
@@ -151,18 +170,6 @@ findBind binds lookfor =
   -- Var.
   find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 
--- | Processes the given bind as a top level bind.
-processBind ::
-  Bool                       -- ^ Should this be stateful function?
-  -> (CoreBndr, CoreExpr)    -- ^ The bind to process
-  -> TranslatorState ()
-
-processBind stateful bind@(var, expr) = do
-  -- Create the function signature
-  let ty = CoreUtils.exprType expr
-  let hsfunc = mkHsFunction var ty stateful
-  flattenBind hsfunc bind
-
 -- | Flattens the given bind into the given signature and adds it to the
 --   session. Then (recursively) finds any functions it uses and does the same
 --   with them.