X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=262a1b68b1d58b784b6dfde7d2b7d7f464d4d007;hb=f20ebcfe03b2f3493be450761c8b3a26c2e0cd30;hp=f377152c775c9deaf7b8efed06453a63403e7a3b;hpb=c5bde4d7862c7df2b4bad183088f77a43d8b5a2c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index f377152..262a1b6 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,6 +1,8 @@
 module Translator where
 import qualified Directory
 import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
 import GHC hiding (loadModule, sigName)
 import CoreSyn
 import qualified CoreUtils
@@ -26,6 +28,7 @@ import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr )
 import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )
+import qualified UniqSupply
 import List ( find )
 import qualified List
 import qualified Monad
@@ -43,14 +46,12 @@ import Text.PrettyPrint.HughesPJ (render)
 import TranslatorTypes
 import HsValueMap
 import Pretty
+import Normalize
 import Flatten
 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
@@ -81,25 +82,21 @@ listBind filename name = do
 moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL core list = do
   let (names, statefuls) = unzip list
-  --liftIO $ putStr $ prettyShow (cm_binds core)
-  let binds = findBinds core names
-  --putStr $ prettyShow binds
+  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 (vhdl, sess) = State.runState (mkVHDL 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 :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
-    mkVHDL binds statefuls = do
-      -- 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 flatfuncs
 
 -- | Write the given design file to a file with the given name inside the
 --   given dir
@@ -126,7 +123,7 @@ loadModule filename =
       --setTargets [target]
       --load LoadAllTargets
       --core <- GHC.compileToCoreSimplified "Adders.hs"
-      core <- GHC.compileToCoreSimplified filename
+      core <- GHC.compileToCoreModule filename
       return core
 
 -- | Extracts the named binds from the given module.
@@ -141,18 +138,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.
@@ -270,7 +255,7 @@ resolvFunc hsfunc = do
   -- Don't do anything if there is already a flat function for this hsfunc or
   -- when it is a builtin function.
   Monad.unless (Map.member hsfunc flatfuncmap) $ do
-  Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+  -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
   -- New function, resolve it
   core <- getA tsCoreModule
   -- Find the named function