From 6615a04d5d42a0e1875bd1a281372509ca64e641 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 19 Feb 2009 15:13:45 +0100 Subject: [PATCH 01/16] Also allow uppercase letters and a period in VHDL ids. --- VHDL.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/VHDL.hs b/VHDL.hs index 4ab3be3..37bcd74 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -330,4 +330,4 @@ mkVHDLId s = AST.unsafeVHDLBasicId s' where -- Strip invalid characters. - s' = filter (`elem` ['a'..'z'] ++ ['0'..'9'] ++ ['_']) s + s' = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.") s -- 2.30.2 From 684c5b250d98bc3e96193e073300234ea617b07e Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 19 Feb 2009 15:31:14 +0100 Subject: [PATCH 02/16] Print the list of signals sorted by id. --- Pretty.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/Pretty.hs b/Pretty.hs index 433c15a..3c007f9 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -47,7 +47,7 @@ instance Pretty FlatFunction where (text "Args: ") $$ nest 10 (pPrint args) $+$ (text "Result: ") $$ nest 10 (pPrint res) $+$ (text "Defs: ") $$ nest 10 (ppdefs defs) - $+$ text "Signals: " $$ nest 10 (printList ppsig sigs) + $+$ text "Signals: " $$ nest 10 (ppsigs sigs) where ppsig (id, info) = pPrint id <> pPrint info ppdefs defs = vcat (map pPrint sorted) @@ -57,6 +57,9 @@ instance Pretty FlatFunction where sigDefDst (FApp _ _ dst) = head $ Foldable.toList dst sigDefDst (CondDef _ _ _ dst) = dst sigDefDst (UncondDef _ dst) = dst + ppsigs sigs = vcat (map pPrint sorted) + where + sorted = List.sortBy (\a b -> compare (fst a) (fst b)) sigs instance Pretty SigDef where -- 2.30.2 From 0bc61dd521c7211ba4db643036f8517bb8bb48f4 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 19 Feb 2009 15:48:58 +0100 Subject: [PATCH 03/16] Support construction of empty tuples. --- Flatten.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/Flatten.hs b/Flatten.hs index 11738c7..1eaa0ff 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -157,13 +157,18 @@ flattenExpr binds var@(Var id) = Left sig_use -> return ([], sig_use) Right _ -> error "Higher order functions not supported." IdInfo.DataConWorkId datacon -> do - lit <- dataConToLiteral datacon - let ty = CoreUtils.exprType var - sig_id <- genSignalId SigInternal ty - -- Add a name hint to the signal - addNameHint (Name.getOccString id) sig_id - addDef (UncondDef (Right $ Literal lit) sig_id) - return ([], Single sig_id) + if DataCon.isTupleCon datacon && (null $ DataCon.dataConAllTyVars datacon) + then do + -- Empty tuple construction + return ([], Tuple []) + else do + lit <- dataConToLiteral datacon + let ty = CoreUtils.exprType var + sig_id <- genSignalId SigInternal ty + -- Add a name hint to the signal + addNameHint (Name.getOccString id) sig_id + addDef (UncondDef (Right $ Literal lit) sig_id) + return ([], Single sig_id) otherwise -> error $ "Ids other than local vars and dataconstructors not supported: " ++ (showSDoc $ ppr id) -- 2.30.2 From acb620510e3623e8dfd979a8b732babd19086a9b Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 19 Feb 2009 16:14:52 +0100 Subject: [PATCH 04/16] Let the exec function output something. --- Alu.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Alu.hs b/Alu.hs index 3880245..ca2dbe9 100644 --- a/Alu.hs +++ b/Alu.hs @@ -61,11 +61,11 @@ salu High a b s = (s, a `hwand` b) salu Low a b s = (s, a `hwor` b) type ExecState = (RegisterBankState, Bit, Bit) -exec :: (RegAddr, Bit, AluOp) -> ExecState -> (ExecState, ()) +exec :: (RegAddr, Bit, AluOp) -> ExecState -> (ExecState, (Bit)) -- Read & Exec exec (addr, Low, op) s = - (s', ()) + (s', z') where (reg_s, t, z) = s (reg_s', t') = register_bank (addr, Low, dontcare) reg_s @@ -74,7 +74,7 @@ exec (addr, Low, op) s = -- Write exec (addr, High, op) s = - (s', ()) + (s', dontcare) where (reg_s, t, z) = s (reg_s', _) = register_bank (addr, High, z) reg_s -- 2.30.2 From 82e90697d7c570456f7bb0df8e4dc832ca242f74 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 19 Feb 2009 16:15:16 +0100 Subject: [PATCH 05/16] Write each VHDL entity to a seperate file. --- Translator.hs | 21 ++++++++++++++------- VHDL.hs | 29 ++++++++++++++--------------- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/Translator.hs b/Translator.hs index e375e45..d11d29e 100644 --- a/Translator.hs +++ b/Translator.hs @@ -51,7 +51,8 @@ makeVHDL filename name = do -- Translate to VHDL vhdl <- moduleToVHDL core [name] -- Write VHDL to file - writeVHDL vhdl "../vhdl/vhdl/output.vhdl" + mapM (writeVHDL "../vhdl/vhdl/") vhdl + return () -- | Show the core structure of the given binds in the given file. listBind :: String -> String -> IO () @@ -65,14 +66,14 @@ listBind filename name = do -- | Translate the binds with the given names from the given core module to -- VHDL -moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO AST.DesignFile +moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO [AST.DesignFile] moduleToVHDL core names = do --liftIO $ putStr $ prettyShow (cm_binds core) let binds = findBinds core names --putStr $ prettyShow binds -- Turn bind into VHDL let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty) - putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl + mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl @@ -86,11 +87,17 @@ moduleToVHDL core names = do modFuncs nameFlatFunction modFuncs VHDL.createEntity modFuncs VHDL.createArchitecture - VHDL.getDesignFile + VHDL.getDesignFiles --- | Write the given design file to the given file -writeVHDL :: AST.DesignFile -> String -> IO () -writeVHDL = ForSyDe.Backend.VHDL.FileIO.writeDesignFile +-- | 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 +-- will be used as a filename. +writeVHDL :: String -> AST.DesignFile -> IO () +writeVHDL dir vhdl = do + let AST.DesignFile _ (u:us) = vhdl + let AST.LUEntity (AST.EntityDec id _) = u + let fname = dir ++ AST.fromVHDLId id ++ ".vhdl" + ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname -- | Loads the given file and turns it into a core module. loadModule :: String -> IO HscTypes.CoreModule diff --git a/VHDL.hs b/VHDL.hs index 37bcd74..d2e9389 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -21,18 +21,16 @@ import FlattenTypes import TranslatorTypes import Pretty -getDesignFile :: VHDLState AST.DesignFile -getDesignFile = do +getDesignFiles :: VHDLState [AST.DesignFile] +getDesignFiles = do -- Extract the library units generated from all the functions in the -- session. funcs <- getFuncs - let units = concat $ map getLibraryUnits funcs + let units = Maybe.mapMaybe getLibraryUnits funcs let context = [ AST.Library $ mkVHDLId "IEEE", AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All] - return $ AST.DesignFile - context - units + return $ map (\(ent, arch) -> AST.DesignFile context [ent, arch]) units -- | Create an entity for a given function createEntity :: @@ -277,18 +275,19 @@ getEntityId fdata = getLibraryUnits :: (HsFunction, FuncData) -- | A function from the session - -> [AST.LibraryUnit] -- | The library units it generates + -> Maybe (AST.LibraryUnit, AST.LibraryUnit) -- | The entity and architecture for the function getLibraryUnits (hsfunc, fdata) = case funcEntity fdata of - Nothing -> [] - Just ent -> case ent_decl ent of - Nothing -> [] - Just decl -> [AST.LUEntity decl] - ++ - case funcArch fdata of - Nothing -> [] - Just arch -> [AST.LUArch arch] + Nothing -> Nothing + Just ent -> + case ent_decl ent of + Nothing -> Nothing + Just decl -> + case funcArch fdata of + Nothing -> Nothing + Just arch -> + Just (AST.LUEntity decl, AST.LUArch arch) -- | The VHDL Bit type bit_ty :: AST.TypeMark -- 2.30.2 From 023e8550e96ed275acf746580642c9f6fee60329 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 27 Feb 2009 14:35:05 +0100 Subject: [PATCH 06/16] Add a two-port mux hardware model. --- Adders.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Adders.hs b/Adders.hs index ac93a33..4745d8c 100644 --- a/Adders.hs +++ b/Adders.hs @@ -16,6 +16,10 @@ show_add f = do print ("Sum: " ++ (displaysigs s)); print ("Carry: " ++ (displ b = [Low, Low, Low, High] (s, c) = f (a, b) +mux2 :: Bit -> (Bit, Bit) -> Bit +mux2 Low (a, b) = a +mux2 High (a, b) = b + -- Not really an adder, but this is nice minimal hardware description wire :: Bit -> Bit wire a = a -- 2.30.2 From 56b4b2edb9bd1d06cafefc12a06feb7ef5622291 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 27 Feb 2009 14:37:55 +0100 Subject: [PATCH 07/16] Make exec have a single binding. This prevents two separate invocations of register_bank, which leads to having a separate register bank for reading and writing. --- Alu.hs | 16 ++-------------- 1 file changed, 2 insertions(+), 14 deletions(-) diff --git a/Alu.hs b/Alu.hs index ca2dbe9..ea9bae8 100644 --- a/Alu.hs +++ b/Alu.hs @@ -56,28 +56,16 @@ alu :: AluOp -> Bit -> Bit -> Bit alu High a b = a `hwand` b alu Low a b = a `hwor` b -salu :: AluOp -> Bit -> Bit -> () -> ((), Bit) -salu High a b s = (s, a `hwand` b) -salu Low a b s = (s, a `hwor` b) - type ExecState = (RegisterBankState, Bit, Bit) exec :: (RegAddr, Bit, AluOp) -> ExecState -> (ExecState, (Bit)) -- Read & Exec -exec (addr, Low, op) s = +exec (addr, we, op) s = (s', z') where (reg_s, t, z) = s - (reg_s', t') = register_bank (addr, Low, dontcare) reg_s + (reg_s', t') = register_bank (addr, we, z) reg_s z' = alu op t' t s' = (reg_s', t', z') --- Write -exec (addr, High, op) s = - (s', dontcare) - where - (reg_s, t, z) = s - (reg_s', _) = register_bank (addr, High, z) reg_s - s' = (reg_s', t, z) - -- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2 From 93dad0e8b95c29c56b03c556e16b26aadf4e7a40 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Fri, 27 Feb 2009 16:24:57 +0100 Subject: [PATCH 08/16] Add some newlines in the output. --- Translator.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Translator.hs b/Translator.hs index d11d29e..ed560ec 100644 --- a/Translator.hs +++ b/Translator.hs @@ -61,6 +61,7 @@ listBind filename name = do let binds = findBinds core [name] putStr "\n" putStr $ prettyShow binds + putStr "\n\n" putStr $ showSDoc $ ppr binds putStr "\n\n" -- 2.30.2 From 23f93793c5f5f44f1443493c171a0b98295a1651 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 09:59:45 +0100 Subject: [PATCH 09/16] Allow for generating VHDL for stateless functions. Previously, the top level function needed to be stateful always. Now, the makeVHDL function has a Bool argument to specify statefulness. --- Translator.hs | 71 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 42 insertions(+), 29 deletions(-) diff --git a/Translator.hs b/Translator.hs index ed560ec..77790ff 100644 --- a/Translator.hs +++ b/Translator.hs @@ -42,14 +42,14 @@ import VHDLTypes import qualified VHDL main = do - makeVHDL "Alu.hs" "register_bank" + makeVHDL "Alu.hs" "register_bank" True -makeVHDL :: String -> String -> IO () -makeVHDL filename name = do +makeVHDL :: String -> String -> Bool -> IO () +makeVHDL filename name stateful = do -- Load the module core <- loadModule filename -- Translate to VHDL - vhdl <- moduleToVHDL core [name] + vhdl <- moduleToVHDL core [(name, stateful)] -- Write VHDL to file mapM (writeVHDL "../vhdl/vhdl/") vhdl return () @@ -66,25 +66,27 @@ listBind filename name = do putStr "\n\n" -- | Translate the binds with the given names from the given core module to --- VHDL -moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO [AST.DesignFile] -moduleToVHDL core names = do +-- VHDL. The Bool in the tuple makes the function stateful (True) or +-- stateless (False). +moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [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 -- Turn bind into VHDL - let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty) + let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty) mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl where -- Turns the given bind into VHDL - mkVHDL binds = do + mkVHDL binds statefuls = do -- Add the builtin functions mapM addBuiltIn builtin_funcs -- Create entities and architectures for them - mapM processBind binds + Monad.zipWithM processBind statefuls binds modFuncs nameFlatFunction modFuncs VHDL.createEntity modFuncs VHDL.createArchitecture @@ -133,14 +135,15 @@ findBind binds lookfor = -- | Processes the given bind as a top level bind. processBind :: - CoreBind -- The bind to process + Bool -- ^ Should this be stateful function? + -> CoreBind -- ^ The bind to process -> VHDLState () -processBind (Rec _) = error "Recursive binders not supported" -processBind bind@(NonRec var expr) = do +processBind _ (Rec _) = error "Recursive binders not supported" +processBind stateful bind@(NonRec var expr) = do -- Create the function signature let ty = CoreUtils.exprType expr - let hsfunc = mkHsFunction var ty + let hsfunc = mkHsFunction var ty stateful flattenBind hsfunc bind -- | Flattens the given bind into the given signature and adds it to the @@ -193,27 +196,37 @@ resolvFunc hsfunc = do mkHsFunction :: Var.Var -- ^ The function defined -> Type -- ^ The function type (including arguments!) + -> Bool -- ^ Is this a stateful function? -> HsFunction -- ^ The resulting HsFunction -mkHsFunction f ty = +mkHsFunction f ty stateful= HsFunction hsname hsargs hsres where hsname = getOccString f (arg_tys, res_ty) = Type.splitFunTys ty - -- The last argument must be state - state_ty = last arg_tys - state = useAsState (mkHsValueMap state_ty) - -- All but the last argument are inports - inports = map (useAsPort . mkHsValueMap)(init arg_tys) - hsargs = inports ++ [state] - hsres = case splitTupleType res_ty of - -- Result type must be a two tuple (state, ports) - Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty - then - Tuple [state, useAsPort (mkHsValueMap outport_ty)] - else - error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty) - otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports." + (hsargs, hsres) = + if stateful + then + let + -- The last argument must be state + state_ty = last arg_tys + state = useAsState (mkHsValueMap state_ty) + -- All but the last argument are inports + inports = map (useAsPort . mkHsValueMap)(init arg_tys) + hsargs = inports ++ [state] + hsres = case splitTupleType res_ty of + -- Result type must be a two tuple (state, ports) + Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty + then + Tuple [state, useAsPort (mkHsValueMap outport_ty)] + else + error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty) + otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports." + in + (hsargs, hsres) + else + -- Just use everything as a port + (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty) -- | Adds signal names to the given FlatFunction nameFlatFunction :: -- 2.30.2 From 048c653a2e8ce47a6a8f9414ca6dd3467d0a0ff8 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 10:22:04 +0100 Subject: [PATCH 10/16] Put VHDL files for each design in a separate directory. --- Translator.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/Translator.hs b/Translator.hs index 77790ff..015f036 100644 --- 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. -- 2.30.2 From ca2a895b27e5cc5a3e4b4da9e94efeb9779e1e79 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 11:56:05 +0100 Subject: [PATCH 11/16] Don't add duplicate name hints. --- FlattenTypes.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/FlattenTypes.hs b/FlattenTypes.hs index f75b0d5..44879d0 100644 --- a/FlattenTypes.hs +++ b/FlattenTypes.hs @@ -193,8 +193,12 @@ addNameHint :: String -> SignalId -> FlattenState () addNameHint hint id = do info <- getSignalInfo id let hints = nameHints info - let hints' = (hint:hints) - setSignalInfo id (info {nameHints = hints'}) + if hint `elem` hints + then do + return () + else do + let hints' = (hint:hints) + setSignalInfo id (info {nameHints = hints'}) -- | Returns the SignalInfo for the given signal. Errors if the signal is not -- known in the session. -- 2.30.2 From 700f7c01ff7a4f9b4fa1e5950ff0b30d62143516 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 11:56:34 +0100 Subject: [PATCH 12/16] Add StandalonDeriving language option to Pretty. --- Pretty.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Pretty.hs b/Pretty.hs index 3c007f9..d23081e 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -1,5 +1,9 @@ +-- Needed for the Show deriving for Core types +{-# LANGUAGE StandaloneDeriving #-} + module Pretty (prettyShow) where + import qualified Data.Map as Map import qualified Data.Foldable as Foldable import qualified List -- 2.30.2 From 0dd32af30fee665611e77cfb7bf8fc82f70c970b Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 11:58:25 +0100 Subject: [PATCH 13/16] Never inline the half_adder function. --- Adders.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Adders.hs b/Adders.hs index 4745d8c..7243b50 100644 --- a/Adders.hs +++ b/Adders.hs @@ -59,6 +59,7 @@ no_carry_adder (a, b) = a `hwxor` b -- Combinatoric stateless half adder -- A -> B -> (S, C) half_adder :: (Bit, Bit) -> (Bit, Bit) +{-# NOINLINE half_adder #-} half_adder (a, b) = ( a `hwxor` b, a `hwand` b ) -- 2.30.2 From db63e913f56b427533d29327b25a14b6b75b6d79 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 12:21:35 +0100 Subject: [PATCH 14/16] Add a is_FApp predicate. --- FlattenTypes.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/FlattenTypes.hs b/FlattenTypes.hs index 44879d0..b7be464 100644 --- a/FlattenTypes.hs +++ b/FlattenTypes.hs @@ -96,6 +96,12 @@ data SigDef = defDst :: SignalId } deriving (Show, Eq) +-- | Is the given SigDef a FApp? +is_FApp :: SigDef -> Bool +is_FApp d = case d of + (FApp _ _ _) -> True + _ -> False + -- | An expression on signals data SignalExpr = EqLit SignalId String -- ^ Is the given signal equal to the given (VHDL) literal -- 2.30.2 From ab69875b604cf6e97bb3c9c19f4d997a57578ec4 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 12:21:57 +0100 Subject: [PATCH 15/16] Add vim modeline. --- FlattenTypes.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/FlattenTypes.hs b/FlattenTypes.hs index b7be464..eba0599 100644 --- a/FlattenTypes.hs +++ b/FlattenTypes.hs @@ -218,3 +218,5 @@ setSignalInfo id' info' = do (defs, sigs, n) <- State.get let sigs' = map (\(id, info) -> (id, if id == id' then info' else info)) sigs State.put (defs, sigs', n) + +-- vim: set ts=8 sw=2 sts=2 expandtab: -- 2.30.2 From 221d523e2cd3de079ea642a65f31950caf94152b Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 3 Mar 2009 12:24:57 +0100 Subject: [PATCH 16/16] Add initial (dummy) propagateState function. The propagateState function will propagate the state variables down to called functions whenever possible. For now, it just leaves functions unchanged. --- Translator.hs | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/Translator.hs b/Translator.hs index 015f036..7ede250 100644 --- a/Translator.hs +++ b/Translator.hs @@ -164,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 :: -- 2.30.2