X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=NormalizeTools.hs;h=1290fd85bd8b19d7aa93a90f59b81c779061c796;hb=46f93616d6a7ef012c5f07698d56372881196015;hp=400bf88bfa503e12232ef5ddac1ff8868b01c20b;hpb=757befa0b3e9765ad3eca2990df8a790e187326c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 400bf88..1290fd8 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -7,6 +7,7 @@ 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 @@ -14,6 +15,7 @@ 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 @@ -28,10 +30,14 @@ import qualified IdInfo import qualified CoreUtils import qualified CoreSubst import qualified VarSet +import qualified HscTypes import Outputable ( showSDoc, ppr, nest ) -- Local imports import NormalizeTypes +import Pretty +import VHDLTypes +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, @@ -100,15 +106,15 @@ applyboth first (name, second) expr = do -- Apply the second (expr'', changed) <- Writer.listen $ second expr' if Monoid.getAny $ - -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ +-- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ changed then -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ - -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ +-- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ applyboth first (name, second) $ expr'' else - -- trace ("No changes") $ +-- trace ("No changes") $ return expr'' -- Apply the given transformation to all direct subexpressions (only), not the @@ -119,6 +125,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 @@ -142,9 +153,16 @@ 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 + +subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr -- Apply the given transformation to all expressions, except for direct -- arguments of an application @@ -170,14 +188,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 @@ -221,6 +248,19 @@ substitute ((b, e):subss) expr = substitute subss' expr' -- 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 :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a +runTransformSession env uniqSupply session = State.evalState session emptyTransformState + where + emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env + emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState + +-- 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) + +is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool +is_local_var (CoreSyn.Var v) = do + bndrs <- getGlobalBinders + return $ not $ v `elem` bndrs +is_local_var _ = return False