From: Matthijs Kooijman Date: Fri, 19 Jun 2009 14:40:15 +0000 (+0200) Subject: Recursively normalize binds. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=ce21f6b5bc31049d9f663bab7c0f7984ccec5875;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Recursively normalize binds. This allows for functions to use other (user-defined) functions, which will then also get VHDL generated. Also restructures some code to make this possible. In particular, the TranslatorState is now no longer used (but not yet removed). --- diff --git a/Normalize.hs b/Normalize.hs index 2b37e09..653cd68 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -3,12 +3,14 @@ -- top level function "normalize", and defines the actual transformation passes that -- are performed. -- -module Normalize (normalize) where +module Normalize (normalizeModule) where -- Standard modules import Debug.Trace import qualified Maybe import qualified Control.Monad as Monad +import qualified Data.Map as Map +import Data.Accessor -- GHC API import CoreSyn @@ -16,7 +18,7 @@ import qualified UniqSupply import qualified CoreUtils import qualified Type import qualified Id -import qualified UniqSet +import qualified VarSet import qualified CoreFVs import Outputable ( showSDoc, ppr, nest ) @@ -231,7 +233,7 @@ casevalsimpl expr@(Case scrut b ty alts) = do -- based on Just we return here. return $ (Just (id, expr), (con, bndrs, Var id)) -- Find if any of the binders are used by expr - where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr + where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr -- Don't simplify anything else doalt alt = return (Nothing, alt) -- Leave all other expressions unchanged @@ -248,7 +250,7 @@ caseremove, caseremovetop :: Transform -- Replace a useless case by the value of its single alternative caseremove (Case scrut b ty [(con, bndrs, expr)]) | not usesvars = change expr -- Find if any of the binders are used by expr - where usesvars = (not . UniqSet.isEmptyUniqSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr + where usesvars = (not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))) expr -- Leave all other expressions unchanged caseremove expr = return expr -- Perform this transform everywhere @@ -284,8 +286,54 @@ appsimpltop = everywhere ("appsimpl", appsimpl) -- What transforms to run? transforms = [etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] --- Normalize a core expression by running transforms until none applies --- anymore. Uses a UniqSupply to generate new identifiers. -normalize :: UniqSupply.UniqSupply -> CoreExpr -> CoreExpr -normalize = dotransforms transforms +-- Turns the given bind into VHDL +normalizeModule :: + UniqSupply.UniqSupply -- ^ A UniqSupply we can use + -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module) + -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings) + -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful + -> [(CoreBndr, CoreExpr)] -- ^ The resulting VHDL +normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession uniqsupply $ do + -- Put all the bindings in this module in the tsBindings map + putA tsBindings (Map.fromList bindings) + -- (Recursively) normalize each of the requested bindings + mapM normalizeBind generate_for + -- Get all initial bindings and the ones we produced + bindings_map <- getA tsBindings + let bindings = Map.assocs bindings_map + normalized_bindings <- getA tsNormalized + -- But return only the normalized bindings + return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings + +normalizeBind :: CoreBndr -> TransformSession () +normalizeBind bndr = do + normalized_funcs <- getA tsNormalized + -- See if this function was normalized already + if VarSet.elemVarSet bndr normalized_funcs + then + -- Yup, don't do it again + return () + else do + -- Nope, note that it has been and do it. + modA tsNormalized (flip VarSet.extendVarSet bndr) + expr_maybe <- getGlobalBind bndr + case expr_maybe of + Just expr -> do + -- Normalize this expression + expr' <- dotransforms transforms expr + let expr'' = trace ("Before:\n\n" ++ showSDoc ( ppr expr ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr expr')) expr' + -- And store the normalized version in the session + modA tsBindings (Map.insert bndr expr'') + -- Find all vars used with a function type. All of these should be global + -- binders (i.e., functions used), since any local binders with a function + -- type should have been inlined already. + let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> trace (showSDoc $ ppr $ Id.idType v) ((Type.isFunTy . snd . Type.splitForAllTys . Id.idType)v)) expr'' + let used_funcs = VarSet.varSetElems used_funcs_set + -- Process each of the used functions recursively + mapM normalizeBind (trace (show used_funcs) used_funcs) + return () + -- We don't have a value for this binder, let's assume this is a builtin + -- function. This might need some extra checking and a nice error + -- message). + Nothing -> return () diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 6699101..817dd51 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -11,6 +11,7 @@ import qualified Control.Monad as Monad import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Writer as Writer import qualified "transformers" Control.Monad.Trans as Trans +import qualified Data.Map as Map import Data.Accessor -- GHC API @@ -25,6 +26,7 @@ import qualified Type import qualified IdInfo import qualified CoreUtils import qualified CoreSubst +import qualified VarSet import Outputable ( showSDoc, ppr, nest ) -- Local imports @@ -113,16 +115,11 @@ subnotapplied trans (App a b) = do -- Let subeverywhere handle all other expressions subnotapplied trans expr = subeverywhere (notapplied trans) expr --- Run the given transforms over the given expression -dotransforms :: [Transform] -> UniqSupply.UniqSupply -> CoreExpr -> CoreExpr -dotransforms transs uniqSupply = (flip State.evalState initState) . (dotransforms' transs) - where initState = TransformState uniqSupply - -- Runs each of the transforms repeatedly inside the State monad. -dotransforms' :: [Transform] -> CoreExpr -> State.State TransformState CoreExpr -dotransforms' transs expr = do +dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr +dotransforms transs expr = do (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs - if Monoid.getAny changed then dotransforms' transs expr' else return expr' + if Monoid.getAny changed then dotransforms transs expr' else return expr' -- Inline all let bindings that satisfy the given condition inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform @@ -160,3 +157,9 @@ mkUnique = Trans.lift $ do substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr substitute replace expr = CoreSubst.substExpr subs expr where subs = foldl (\s (b, e) -> CoreSubst.extendIdSubst s b e) CoreSubst.emptySubst replace + +-- Run a given TransformSession. Used mostly to setup the right calls and +-- an initial state. +runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a +runTransformSession uniqSupply session = State.evalState session initState + where initState = TransformState uniqSupply Map.empty VarSet.emptyVarSet diff --git a/NormalizeTypes.hs b/NormalizeTypes.hs index e61570a..e959bbb 100644 --- a/NormalizeTypes.hs +++ b/NormalizeTypes.hs @@ -7,11 +7,14 @@ import qualified Control.Monad.Trans.Writer as Writer import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid import qualified Data.Accessor.Template +import Data.Accessor +import qualified Data.Map as Map import Debug.Trace -- GHC API import CoreSyn import qualified UniqSupply +import qualified VarSet import Outputable ( Outputable, showSDoc, ppr ) -- Local imports @@ -19,11 +22,28 @@ import CoreShow import Pretty data TransformState = TransformState { - tsUniqSupply_ :: UniqSupply.UniqSupply + tsUniqSupply_ :: UniqSupply.UniqSupply + , tsBindings_ :: Map.Map CoreBndr CoreExpr + , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized } $( Data.Accessor.Template.deriveAccessors ''TransformState ) -type TransformMonad a = Writer.WriterT Monoid.Any (State.State TransformState) a +-- A session of multiple transformations over multiple expressions +type TransformSession = (State.State TransformState) +-- Wrap a writer around a TransformSession, to run a single transformation +-- over a single expression and track if the expression was changed. +type TransformMonad = Writer.WriterT Monoid.Any TransformSession + -- | Transforms a CoreExpr and keeps track if it has changed. type Transform = CoreExpr -> TransformMonad CoreExpr + +-- Finds the value of a global binding, if available +getGlobalBind :: CoreBndr -> TransformSession (Maybe CoreExpr) +getGlobalBind bndr = do + bindings <- getA tsBindings + return $ Map.lookup bndr bindings + +-- Adds a new global binding with the given value +addGlobalBind :: CoreBndr -> CoreExpr -> TransformSession () +addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr) diff --git a/Translator.hs b/Translator.hs index 6b0cdd1..262a1b6 100644 --- a/Translator.hs +++ b/Translator.hs @@ -82,7 +82,7 @@ listBind filename name = do moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)] moduleToVHDL core list = do let (names, statefuls) = unzip list - let binds = findBinds core names + let binds = map fst $ findBinds core names -- Generate a UniqSupply -- Running -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . @@ -90,23 +90,13 @@ moduleToVHDL core list = do -- unique supply anywhere. uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' -- Turn bind into VHDL - let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty) + let all_bindings = (CoreSyn.flattenBinds $ cm_binds core) + let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls + let vhdl = VHDL.createDesignFiles normalized_bindings mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl - putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" + --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl where - -- Turns the given bind into VHDL - 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 binds' -- | Write the given design file to a file with the given name inside the -- given dir @@ -148,18 +138,6 @@ findBind binds lookfor = -- Var. find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds --- | Processes the given bind as a top level bind. -processBind :: - Bool -- ^ Should this be stateful function? - -> (CoreBndr, CoreExpr) -- ^ The bind to process - -> TranslatorState () - -processBind stateful bind@(var, expr) = do - -- Create the function signature - let ty = CoreUtils.exprType expr - let hsfunc = mkHsFunction var ty stateful - flattenBind hsfunc bind - -- | Flattens the given bind into the given signature and adds it to the -- session. Then (recursively) finds any functions it uses and does the same -- with them.