X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=383c477282e04fa3429c153520cf13064eca1d0d;hb=0de275199ba2f3a98339eefb7784e061a451c5f7;hp=77790ff2c8b33ff2ec07af7963d2e0e57c88b78b;hpb=23f93793c5f5f44f1443493c171a0b98295a1651;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 77790ff..383c477 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,4 +1,6 @@
 module Translator where
+import qualified Directory
+import qualified List
 import GHC hiding (loadModule, sigName)
 import CoreSyn
 import qualified CoreUtils
@@ -9,6 +11,7 @@ import qualified DataCon
 import qualified Maybe
 import qualified Module
 import qualified Control.Monad.State as State
+import qualified Data.Foldable as Foldable
 import Name
 import qualified Data.Map as Map
 import Data.Generics
@@ -51,7 +54,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 +101,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 +166,106 @@ 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', flat_sigs = sigs'} 
+  where
+    (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+    states' = zip olds news
+    -- Find all signals used by all sigdefs
+    uses = concatMap sigDefUses (flat_defs flatfunc)
+    -- Find all signals that are used more than once (is there a
+    -- prettier way to do this?)
+    multiple_uses = uses List.\\ (List.nub uses)
+    -- Find the states whose "old state" signal is used only once
+    single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+    -- See if these single use states can be propagated
+    (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
+    substate_sigs = concat substate_sigss
+    -- Mark any propagated state signals as SigSubState
+    sigs' = map 
+      (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+      (flat_sigs flatfunc)
+
+-- | Propagate the state into a single function application.
+propagateState' ::
+  [(SignalId, SignalId)]
+                      -- ^ TODO
+  -> SigDef           -- ^ The SigDef to process.
+  -> ([SignalId], SigDef) 
+                      -- ^ Any signal ids that should become substates,
+                      --   and the resulting application.
+
+propagateState' states def =
+    if (is_FApp def) then
+      (our_old ++ our_new, def {appFunc = hsfunc'})
+    else
+      ([], def)
+  where
+    hsfunc = appFunc def
+    args = appArgs def
+    res = appRes def
+    our_states = filter our_state states
+    -- A state signal belongs in this function if the old state is
+    -- passed in, and the new state returned
+    our_state (old, new) =
+      any (old `Foldable.elem`) args
+      && new `Foldable.elem` res
+    (our_old, our_new) = unzip our_states
+    -- Mark the result
+    zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+    res' = fmap (mark_state (zip our_new [0..])) zipped_res
+    -- Mark the args
+    zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+    args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+    hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+
+    mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+    mark_state states (id, use) =
+      case lookup id states of
+        Nothing -> use
+        Just state_id -> State state_id
+
+-- | Returns pairs of signals that should be mapped to state in this function.
+getStateSignals ::
+  HsFunction                      -- | The function to look at
+  -> FlatFunction                 -- | The function to look at
+  -> [(SignalId, SignalId)]   
+        -- | TODO The state signals. The first is the state number, the second the
+        --   signal to assign the current state to, the last is the signal
+        --   that holds the new state.
+
+getStateSignals hsfunc flatfunc =
+  [(old_id, new_id) 
+    | (old_num, old_id) <- args
+    , (new_num, new_id) <- res
+    , old_num == new_num]
+  where
+    sigs = flat_sigs flatfunc
+    -- Translate args and res to lists of (statenum, sigid)
+    args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+    res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+    
 -- | Find the given function, flatten it and add it to the session. Then
 --   (recursively) do the same for any functions used.
 resolvFunc ::
@@ -286,7 +387,7 @@ addBuiltIn (BuiltIn name args res) = do
     setEntity hsfunc entity
   where
     hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
-    entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
+    entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing Nothing
 
 builtin_funcs = 
   [