X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=NormalizeTools.hs;h=85fae47e8f66a19865f281ee25e642d9dca1f16f;hb=c0b63b2aae039cecafb06bbcf63e50ee0359709b;hp=7ccb4d1a119e8523d9a4c1a32560b69ccec31e59;hpb=570e26f7870fffb1b08fcf44c972b2152d942fc6;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 7ccb4d1..85fae47 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -7,12 +7,15 @@ module NormalizeTools where import Debug.Trace import qualified List import qualified Data.Monoid as Monoid +import qualified Data.Either as Either +import qualified Control.Arrow as Arrow 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 +import Data.Accessor.MonadState as MonadState -- GHC API import CoreSyn @@ -31,6 +34,8 @@ import Outputable ( showSDoc, ppr, nest ) -- Local imports import NormalizeTypes +import Pretty +import qualified VHDLTools -- Create a new internal var with the given name and type. A Unique is -- appended to the given name, to ensure uniqueness (not strictly neccesary, @@ -58,8 +63,8 @@ mkTypeVar str kind = do -- works for both value and type level expressions, so it can return a Var or -- TyVar (which is just an alias for Var). mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var -mkBinderFor (Type ty) = mkTypeVar string (Type.typeKind ty) -mkBinderFor expr = mkInternalVar string (CoreUtils.exprType expr) +mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty) +mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr) -- Creates a reference to the given variable. This works for both a normal -- variable as well as a type variable @@ -74,6 +79,17 @@ cloneVar v = do -- contains, but vannillaIdInfo is always correct, since it means "no info"). return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo +-- Creates a new function with the same name as the given binder (but with a +-- new unique) and with the given function body. Returns the new binder for +-- this function. +mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr +mkFunction bndr body = do + let ty = CoreUtils.exprType body + id <- cloneVar bndr + let newid = Var.setVarType id ty + Trans.lift $ addGlobalBind newid body + return newid + -- Apply the given transformation to all expressions in the given expression, -- including the expression itself. everywhere :: (String, Transform) -> Transform @@ -107,6 +123,11 @@ subeverywhere trans (App a b) = do b' <- trans b return $ App a' b' +subeverywhere trans (Let (NonRec b bexpr) expr) = do + bexpr' <- trans bexpr + expr' <- trans expr + return $ Let (NonRec b bexpr') expr' + subeverywhere trans (Let (Rec binds) expr) = do expr' <- trans expr binds' <- mapM transbind binds @@ -130,26 +151,33 @@ subeverywhere trans (Case scrut b t alts) = do transalt (con, binders, expr) = do expr' <- trans expr return (con, binders, expr') - -subeverywhere trans expr = return expr +subeverywhere trans (Var x) = return $ Var x +subeverywhere trans (Lit x) = return $ Lit x +subeverywhere trans (Type x) = return $ Type x + +subeverywhere trans (Cast expr ty) = do + expr' <- trans expr + return $ Cast expr' ty --- Apply the given transformation to all expressions, except for every first --- argument of an application. -notapplied :: (String, Transform) -> Transform -notapplied trans = applyboth (subnotapplied trans) trans +subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr + +-- Apply the given transformation to all expressions, except for direct +-- arguments of an application +notappargs :: (String, Transform) -> Transform +notappargs trans = applyboth (subnotappargs trans) trans -- Apply the given transformation to all (direct and indirect) subexpressions --- (but not the expression itself), except for the first argument of an --- applicfirst argument of an application -subnotapplied :: (String, Transform) -> Transform -subnotapplied trans (App a b) = do - a' <- subnotapplied trans a - b' <- notapplied trans b +-- (but not the expression itself), except for direct arguments of an +-- application +subnotappargs :: (String, Transform) -> Transform +subnotappargs trans (App a b) = do + a' <- subnotappargs trans a + b' <- subnotappargs trans b return $ App a' b' -- Let subeverywhere handle all other expressions -subnotapplied trans expr = subeverywhere (notapplied trans) expr +subnotappargs trans expr = subeverywhere (notappargs trans) expr -- Runs each of the transforms repeatedly inside the State monad. dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr @@ -158,14 +186,23 @@ dotransforms transs expr = do 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 -inlinebind condition (Let (Rec binds) expr) | not $ null replace = - change newexpr +inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform +inlinebind condition expr@(Let (Rec binds) res) = do + -- Find all bindings that adhere to the condition + res_eithers <- mapM docond binds + case Either.partitionEithers res_eithers of + -- No replaces? No change + ([], _) -> return expr + (replace, others) -> do + -- Substitute the to be replaced binders with their expression + let newexpr = substitute replace (Let (Rec others) res) + change newexpr where - -- Find all simple bindings - (replace, others) = List.partition condition binds - -- Substitute the to be replaced binders with their expression - newexpr = substitute replace (Let (Rec others) expr) + docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr)) + docond b = do + res <- condition b + return $ case res of True -> Left b; False -> Right b + -- Leave all other expressions unchanged inlinebind _ expr = return expr @@ -191,11 +228,28 @@ mkUnique = Trans.lift $ do -- Replace each of the binders given with the coresponding expressions in the -- given expression. substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr -substitute replace expr = CoreSubst.substExpr subs expr - where subs = foldl (\s (b, e) -> CoreSubst.extendSubst s b e) CoreSubst.emptySubst replace +substitute [] expr = expr +-- Apply one substitution on the expression, but also on any remaining +-- substitutions. This seems to be the only way to handle substitutions like +-- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed +-- according to CoreSubst documentation (but it doesn't seem to be a problem). +-- TODO: Find out how this works, exactly. +substitute ((b, e):subss) expr = substitute subss' expr' + where + -- Create the Subst + subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e) + -- Apply this substitution to the main expression + expr' = CoreSubst.substExpr subs expr + -- Apply this substitution on all the expressions in the remaining + -- substitutions + subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss -- 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 +runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply) + +-- Is the given expression representable at runtime, based on the type? +isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool +isRepr (Type ty) = return False +isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)