X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=1786332678717097892bd84c7b2ac66c0badefba;hb=8a17f35807fb35ee4d2a4c35c75e1cf99066f94d;hp=071e9d296dc5f416b6da9d1bfc2ed93a00e07742;hpb=404a426540aef7f29b8dee73140b8ce897dc470f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 071e9d2..1786332 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,13 +46,14 @@ 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 "Adders.hs" "highordtest2" True
 
 makeVHDL :: String -> String -> Bool -> IO ()
 makeVHDL filename name stateful = do
@@ -58,7 +62,7 @@ makeVHDL filename name stateful = do
   -- Translate to VHDL
   vhdl <- moduleToVHDL core [(name, stateful)]
   -- Write VHDL to file
-  let dir = "../vhdl/vhdl/" ++ name ++ "/"
+  let dir = "./vhdl/" ++ name ++ "/"
   mapM (writeVHDL dir) vhdl
   return ()
 
@@ -66,17 +70,14 @@ makeVHDL filename name stateful = do
 listBind :: String -> String -> IO ()
 listBind filename name = do
   core <- loadModule filename
-  let [bind] = findBinds core [name]
+  let [(b, expr)] = findBinds core [name]
   putStr "\n"
-  putStr $ prettyShow bind
+  putStr $ prettyShow expr
   putStr "\n\n"
-  putStr $ showSDoc $ ppr bind
+  putStr $ showSDoc $ ppr expr
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
   putStr "\n\n"
-  case bind of
-    NonRec b expr -> do 
-      putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
-      putStr "\n\n"
-    otherwise -> return ()
 
 -- | 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
@@ -84,25 +85,31 @@ 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
+  -- 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 (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty)
   mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
   putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
   where
     -- Turns the given bind into VHDL
-    mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
-    mkVHDL binds statefuls = do
+    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 flatfuncs
+      --Monad.zipWithM processBind statefuls binds
+      --modA tsFlatFuncs (Map.map nameFlatFunction)
+      --flatfuncs <- getA tsFlatFuncs
+      return $ VHDL.createDesignFiles binds'
 
 -- | Write the given design file to a file with the given name inside the
 --   given dir
@@ -129,32 +136,28 @@ 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.
-findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
-findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
+findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
+findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
 
 -- | Extract a named bind from the given list of binds
-findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
 findBind binds lookfor =
   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.
-  find (\b -> case b of 
-    Rec l -> False
-    NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  ) binds
+  find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 
 -- | Processes the given bind as a top level bind.
 processBind ::
   Bool                       -- ^ Should this be stateful function?
-  -> CoreBind                -- ^ The bind to process
+  -> (CoreBndr, CoreExpr)    -- ^ The bind to process
   -> TranslatorState ()
 
-processBind _ (Rec _) = error "Recursive binders not supported"
-processBind stateful bind@(NonRec var expr) = do
+processBind stateful bind@(var, expr) = do
   -- Create the function signature
   let ty = CoreUtils.exprType expr
   let hsfunc = mkHsFunction var ty stateful
@@ -165,12 +168,10 @@ processBind stateful bind@(NonRec var expr) = do
 --   with them.
 flattenBind ::
   HsFunction                         -- The signature to flatten into
-  -> CoreBind                        -- The bind to flatten
+  -> (CoreBndr, CoreExpr)            -- The bind to flatten
   -> TranslatorState ()
 
-flattenBind _ (Rec _) = error "Recursive binders not supported"
-
-flattenBind hsfunc bind@(NonRec var expr) = do
+flattenBind hsfunc bind@(var, expr) = do
   -- Flatten the function
   let flatfunc = flattenFunction hsfunc bind
   -- Propagate state variables
@@ -279,12 +280,12 @@ 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
   let name = (hsFuncName hsfunc)
-  let bind = findBind (cm_binds core) name 
+  let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name 
   case bind of
     Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
     Just b  -> flattenBind hsfunc b