From 4db642db9cc23c626b891491c8bad5112499c9d3 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Thu, 18 Jun 2009 11:30:12 +0200 Subject: [PATCH] Add infrastructure for running core to core transformations. This does not add any actual transformations, just the supporting functions and functions to run the transformations. --- Normalize.hs | 35 ++++++++++++ NormalizeTools.hs | 141 ++++++++++++++++++++++++++++++++++++++++++++++ NormalizeTypes.hs | 29 ++++++++++ Translator.hs | 22 ++++++-- 4 files changed, 221 insertions(+), 6 deletions(-) create mode 100644 Normalize.hs create mode 100644 NormalizeTools.hs create mode 100644 NormalizeTypes.hs diff --git a/Normalize.hs b/Normalize.hs new file mode 100644 index 0000000..5aacd7a --- /dev/null +++ b/Normalize.hs @@ -0,0 +1,35 @@ +-- +-- Functions to bring a Core expression in normal form. This module provides a +-- top level function "normalize", and defines the actual transformation passes that +-- are performed. +-- +module Normalize (normalize) where + +-- Standard modules +import Debug.Trace +import qualified List +import qualified Maybe +import qualified Control.Monad as Monad + +-- GHC API +import CoreSyn +import qualified UniqSupply +import qualified CoreUtils +import qualified Type +import qualified Id +import qualified CoreSubst +import Outputable ( showSDoc, ppr, nest ) + +-- Local imports +import NormalizeTypes +import NormalizeTools +import CoreTools + +-- What transforms to run? +transforms = [] + +-- 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 + diff --git a/NormalizeTools.hs b/NormalizeTools.hs new file mode 100644 index 0000000..90daf48 --- /dev/null +++ b/NormalizeTools.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE PackageImports #-} +-- +-- This module provides functions for program transformations. +-- +module NormalizeTools where +-- Standard modules +import Debug.Trace +import qualified Data.Monoid as Monoid +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 Data.Accessor + +-- GHC API +import CoreSyn +import qualified UniqSupply +import qualified Unique +import qualified OccName +import qualified Name +import qualified Var +import qualified SrcLoc +import qualified Type +import qualified IdInfo +import Outputable ( showSDoc, ppr, nest ) + +-- Local imports +import NormalizeTypes + +-- 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, +-- since the Unique is also stored in the name, but this ensures variable +-- names are unique in the output). +mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var +mkInternalVar str ty = do + uniq <- mkUnique + let occname = OccName.mkVarOcc (str ++ show uniq) + let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan + return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo + +-- Apply the given transformation to all expressions in the given expression, +-- including the expression itself. +everywhere :: (String, Transform) -> Transform +everywhere trans = applyboth (subeverywhere (everywhere trans)) trans + +-- Apply the first transformation, followed by the second transformation, and +-- keep applying both for as long as expression still changes. +applyboth :: Transform -> (String, Transform) -> Transform +applyboth first (name, second) expr = do + -- Apply the first + expr' <- first expr + -- Apply the second + (expr'', changed) <- Writer.listen $ second expr' + if Monoid.getAny changed + then + trace ("Transform " ++ name ++ " changed from:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nTo:\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n") $ + applyboth first (name, second) expr'' + else + return expr'' + +-- Apply the given transformation to all direct subexpressions (only), not the +-- expression itself. +subeverywhere :: Transform -> Transform +subeverywhere trans (App a b) = do + a' <- trans a + b' <- trans b + return $ App a' b' + +subeverywhere trans (Let (Rec binds) expr) = do + expr' <- trans expr + binds' <- mapM transbind binds + return $ Let (Rec binds') expr' + where + transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr) + transbind (b, e) = do + e' <- trans e + return (b, e') + +subeverywhere trans (Lam x expr) = do + expr' <- trans expr + return $ Lam x expr' + +subeverywhere trans (Case scrut b t alts) = do + scrut' <- trans scrut + alts' <- mapM transalt alts + return $ Case scrut' b t alts' + where + transalt :: CoreAlt -> TransformMonad CoreAlt + transalt (con, binders, expr) = do + expr' <- trans expr + return (con, binders, expr') + + +subeverywhere trans expr = return expr + +-- 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 + +-- 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 + return $ App a' b' + +-- 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 + (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs + if Monoid.getAny changed then dotransforms' transs expr' else return expr' + +-- Sets the changed flag in the TransformMonad, to signify that some +-- transform has changed the result +setChanged :: TransformMonad () +setChanged = Writer.tell (Monoid.Any True) + +-- Sets the changed flag and returns the given value. +change :: a -> TransformMonad a +change val = do + setChanged + return val + +-- Create a new Unique +mkUnique :: TransformMonad Unique.Unique +mkUnique = Trans.lift $ do + us <- getA tsUniqSupply + let (us', us'') = UniqSupply.splitUniqSupply us + putA tsUniqSupply us' + return $ UniqSupply.uniqFromSupply us'' diff --git a/NormalizeTypes.hs b/NormalizeTypes.hs new file mode 100644 index 0000000..e61570a --- /dev/null +++ b/NormalizeTypes.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} +module NormalizeTypes where + + +-- Standard modules +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 Debug.Trace + +-- GHC API +import CoreSyn +import qualified UniqSupply +import Outputable ( Outputable, showSDoc, ppr ) + +-- Local imports +import CoreShow +import Pretty + +data TransformState = TransformState { + tsUniqSupply_ :: UniqSupply.UniqSupply +} + +$( Data.Accessor.Template.deriveAccessors ''TransformState ) + +type TransformMonad a = Writer.WriterT Monoid.Any (State.State TransformState) a +-- | Transforms a CoreExpr and keeps track if it has changed. +type Transform = CoreExpr -> TransformMonad CoreExpr diff --git a/Translator.hs b/Translator.hs index 3944621..32d2add 100644 --- a/Translator.hs +++ b/Translator.hs @@ -1,6 +1,8 @@ module Translator where import qualified Directory import qualified List +import Debug.Trace +import qualified Control.Arrow as Arrow import GHC hiding (loadModule, sigName) import CoreSyn import qualified CoreUtils @@ -26,6 +28,7 @@ import MonadUtils ( liftIO ) import Outputable ( showSDoc, ppr ) import GHC.Paths ( libdir ) import DynFlags ( defaultDynFlags ) +import qualified UniqSupply import List ( find ) import qualified List import qualified Monad @@ -43,6 +46,7 @@ import Text.PrettyPrint.HughesPJ (render) import TranslatorTypes import HsValueMap import Pretty +import Normalize import Flatten import FlattenTypes import VHDLTypes @@ -81,25 +85,31 @@ listBind filename name = do moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, 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 + -- Generate a UniqSupply + -- Running + -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" . + -- on the compiler dir of ghc suggests that 'z' is not used to generate a + -- unique supply anywhere. + uniqSupply <- UniqSupply.mkSplitUniqSupply 'z' -- Turn bind into VHDL - let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty) + let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty) mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" return vhdl where -- Turns the given bind into VHDL - mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)] - mkVHDL binds statefuls = do + 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 + return $ VHDL.createDesignFiles binds' -- | Write the given design file to a file with the given name inside the -- given dir -- 2.30.2