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.

diff --git a/Normalize.hs b/Normalize.hs
new file mode 100644 (file)
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 (file)
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 (file)
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 39446211b06e9c6c838575c3e2535b669ad9b224..32d2addfee4b79afe25822b2fe0f2c486c3d9929 100644 (file)
--- 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