X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=eb4e59f5da01448e8390445e6a511593c626941d;hb=6917dbf733c6c9d7ecfe1796133664be26b6b1dc;hp=2373c342dd40a0f861d014901d19ff71c50b3785;hpb=d5cfe79d359fd4d7177a6cc7232ccb294ce039f8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 2373c34..eb4e59f 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -14,6 +14,7 @@ import qualified Control.Monad.State as State
 import qualified Data.Foldable as Foldable
 import Name
 import qualified Data.Map as Map
+import Data.Accessor
 import Data.Generics
 import NameEnv ( lookupNameEnv )
 import qualified HscTypes
@@ -91,10 +92,12 @@ moduleToVHDL core list = do
       mapM addBuiltIn builtin_funcs
       -- Create entities and architectures for them
       Monad.zipWithM processBind statefuls binds
-      modFuncs nameFlatFunction
-      modFuncs VHDL.createEntity
-      modFuncs VHDL.createArchitecture
-      VHDL.getDesignFiles
+      modFuncMap $ Map.map (fdFlatFunc ^: (fmap nameFlatFunction))
+      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdEntity ^= (VHDL.createEntity hsfunc fdata) $ fdata)
+      funcs <- getFuncMap
+      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdArch ^= (VHDL.createArchitecture funcs hsfunc fdata) $ fdata)
+      funcs <- getFuncs
+      return $ VHDL.getDesignFiles (map snd funcs)
 
 -- | Write the given design file to a file inside the given dir
 --   The first library unit in the designfile must be an entity, whose name
@@ -190,7 +193,6 @@ propagateState ::
 propagateState hsfunc flatfunc =
     flatfunc {flat_defs = apps', flat_sigs = sigs'} 
   where
-    apps = filter is_FApp (flat_defs flatfunc)
     (olds, news) = unzip $ getStateSignals hsfunc flatfunc
     states' = zip olds news
     -- Find all signals used by all sigdefs
@@ -201,7 +203,7 @@ propagateState hsfunc flatfunc =
     -- 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) apps
+    (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 
@@ -212,18 +214,20 @@ propagateState hsfunc flatfunc =
 propagateState' ::
   [(SignalId, SignalId)]
                       -- ^ TODO
-  -> SigDef           -- ^ The function application to process. Must be
-                      --   a FApp constructor.
+  -> SigDef           -- ^ The SigDef to process.
   -> ([SignalId], SigDef) 
                       -- ^ Any signal ids that should become substates,
                       --   and the resulting application.
 
-propagateState' states app =
-    (our_old ++ our_new, app {appFunc = hsfunc'})
+propagateState' states def =
+    if (is_FApp def) then
+      (our_old ++ our_new, def {appFunc = hsfunc'})
+    else
+      ([], def)
   where
-    hsfunc = appFunc app
-    args = appArgs app
-    res = appRes app
+    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
@@ -330,21 +334,15 @@ mkHsFunction f ty stateful=
 
 -- | Adds signal names to the given FlatFunction
 nameFlatFunction ::
-  HsFunction
-  -> FuncData
-  -> VHDLState ()
+  FlatFunction
+  -> FlatFunction
 
-nameFlatFunction hsfunc fdata =
-  let func = flatFunc fdata in
-  case func of
-    -- Skip (builtin) functions without a FlatFunction
-    Nothing -> do return ()
-    -- Name the signals in all other functions
-    Just flatfunc ->
-      let s = flat_sigs flatfunc in
-      let s' = map nameSignal s in
-      let flatfunc' = flatfunc { flat_sigs = s' } in
-      setFlatFunc hsfunc flatfunc'
+nameFlatFunction flatfunc =
+  -- Name the signals
+  let 
+    s = flat_sigs flatfunc
+    s' = map nameSignal s in
+  flatfunc { flat_sigs = s' }
   where
     nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
     nameSignal (id, info) =
@@ -386,7 +384,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 = 
   [