Remove the now obsolete getOwnStates.

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

diff --git a/Translator.hs b/Translator.hs
index 77790ff2c8b33ff2ec07af7963d2e0e57c88b78b..7ede250ddcc2f0f65c26e74e594623fb1871272f 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,4 +1,5 @@
 module Translator where
+import qualified Directory
 import GHC hiding (loadModule, sigName)
 import CoreSyn
 import qualified CoreUtils
@@ -51,7 +52,8 @@ makeVHDL filename name stateful = do
   -- Translate to VHDL
   vhdl <- moduleToVHDL core [(name, stateful)]
   -- Write VHDL to file
-  mapM (writeVHDL "../vhdl/vhdl/") vhdl
+  let dir = "../vhdl/vhdl/" ++ name ++ "/"
+  mapM (writeVHDL dir) vhdl
   return ()
 
 -- | Show the core structure of the given binds in the given file.
@@ -97,9 +99,14 @@ moduleToVHDL core list = do
 --   will be used as a filename.
 writeVHDL :: String -> AST.DesignFile -> IO ()
 writeVHDL dir vhdl = do
+  -- Create the dir if needed
+  exists <- Directory.doesDirectoryExist dir
+  Monad.unless exists $ Directory.createDirectory dir
+  -- Find the filename
   let AST.DesignFile _ (u:us) = vhdl
   let AST.LUEntity (AST.EntityDec id _) = u
   let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
+  -- Write the file
   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 
 -- | Loads the given file and turns it into a core module.
@@ -157,14 +164,42 @@ flattenBind ::
 flattenBind _ (Rec _) = error "Recursive binders not supported"
 
 flattenBind hsfunc bind@(NonRec var expr) = do
+  -- Add the function to the session
+  addFunc hsfunc
   -- Flatten the function
   let flatfunc = flattenFunction hsfunc bind
-  addFunc hsfunc
-  setFlatFunc hsfunc flatfunc
-  let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc)
+  -- Propagate state variables
+  let flatfunc' = propagateState hsfunc flatfunc
+  -- Store the flat function in the session
+  setFlatFunc hsfunc flatfunc'
+  -- Flatten any functions used
+  let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
   State.mapM resolvFunc used_hsfuncs
   return ()
 
+-- | Decide which incoming state variables will become state in the
+--   given function, and which will be propagate to other applied
+--   functions.
+propagateState ::
+  HsFunction
+  -> FlatFunction
+  -> FlatFunction
+
+propagateState hsfunc flatfunc =
+    flatfunc {flat_defs = apps'} 
+  where
+    apps = filter is_FApp (flat_defs flatfunc)
+    apps' = map (propagateState' ()) apps
+
+-- | Propagate the state into a single function application.
+propagateState' ::
+  ()
+  -> SigDef           -- ^ The function application to process. Must be
+                      --   a FApp constructor.
+  -> SigDef           -- ^ The resulting application.
+
+propagateState' _ d = d
+
 -- | Find the given function, flatten it and add it to the session. Then
 --   (recursively) do the same for any functions used.
 resolvFunc ::