NormalizeTools.hs

   1 {-# LANGUAGE PackageImports #-}
   2 --
   3 -- This module provides functions for program transformations.
   4 --
   5 module NormalizeTools where
   6 -- Standard modules
   7 import Debug.Trace
   8 import qualified Data.Monoid as Monoid
   9 import qualified Control.Monad as Monad
  10 import qualified Control.Monad.Trans.State as State
  11 import qualified Control.Monad.Trans.Writer as Writer
  12 import qualified "transformers" Control.Monad.Trans as Trans
  13 import Data.Accessor
  14
  15 -- GHC API
  16 import CoreSyn
  17 import qualified UniqSupply
  18 import qualified Unique
  19 import qualified OccName
  20 import qualified Name
  21 import qualified Var
  22 import qualified SrcLoc
  23 import qualified Type
  24 import qualified IdInfo
  25 import Outputable ( showSDoc, ppr, nest )
  26
  27 -- Local imports
  28 import NormalizeTypes
  29
  30 -- Create a new internal var with the given name and type. A Unique is
  31 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
  32 -- since the Unique is also stored in the name, but this ensures variable
  33 -- names are unique in the output).
  34 mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
  35 mkInternalVar str ty = do
  36   uniq <- mkUnique
  37   let occname = OccName.mkVarOcc (str ++ show uniq)
  38   let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
  39   return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
  40
  41 -- Apply the given transformation to all expressions in the given expression,
  42 -- including the expression itself.
  43 everywhere :: (String, Transform) -> Transform
  44 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  45
  46 -- Apply the first transformation, followed by the second transformation, and
  47 -- keep applying both for as long as expression still changes.
  48 applyboth :: Transform -> (String, Transform) -> Transform
  49 applyboth first (name, second) expr  = do
  50   -- Apply the first
  51   expr' <- first expr
  52   -- Apply the second
  53   (expr'', changed) <- Writer.listen $ second expr'
  54   if Monoid.getAny changed
  55     then
  56       trace ("Transform " ++ name ++ " changed from:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nTo:\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n") $
  57       applyboth first (name, second) expr''
  58     else
  59       return expr''
  60
  61 -- Apply the given transformation to all direct subexpressions (only), not the
  62 -- expression itself.
  63 subeverywhere :: Transform -> Transform
  64 subeverywhere trans (App a b) = do
  65   a' <- trans a
  66   b' <- trans b
  67   return $ App a' b'
  68
  69 subeverywhere trans (Let (Rec binds) expr) = do
  70   expr' <- trans expr
  71   binds' <- mapM transbind binds
  72   return $ Let (Rec binds') expr'
  73   where
  74     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
  75     transbind (b, e) = do
  76       e' <- trans e
  77       return (b, e')
  78
  79 subeverywhere trans (Lam x expr) = do
  80   expr' <- trans expr
  81   return $ Lam x expr'
  82
  83 subeverywhere trans (Case scrut b t alts) = do
  84   scrut' <- trans scrut
  85   alts' <- mapM transalt alts
  86   return $ Case scrut' b t alts'
  87   where
  88     transalt :: CoreAlt -> TransformMonad CoreAlt
  89     transalt (con, binders, expr) = do
  90       expr' <- trans expr
  91       return (con, binders, expr')
  92
  93
  94 subeverywhere trans expr = return expr
  95
  96 -- Apply the given transformation to all expressions, except for every first
  97 -- argument of an application.
  98 notapplied :: (String, Transform) -> Transform
  99 notapplied trans = applyboth (subnotapplied trans) trans
 100
 101 -- Apply the given transformation to all (direct and indirect) subexpressions
 102 -- (but not the expression itself), except for the first argument of an
 103 -- applicfirst argument of an application
 104 subnotapplied :: (String, Transform) -> Transform
 105 subnotapplied trans (App a b) = do
 106   a' <- subnotapplied trans a
 107   b' <- notapplied trans b
 108   return $ App a' b'
 109
 110 -- Let subeverywhere handle all other expressions
 111 subnotapplied trans expr = subeverywhere (notapplied trans) expr
 112
 113 -- Run the given transforms over the given expression
 114 dotransforms :: [Transform] -> UniqSupply.UniqSupply -> CoreExpr -> CoreExpr
 115 dotransforms transs uniqSupply = (flip State.evalState initState) . (dotransforms' transs)
 116                        where initState = TransformState uniqSupply
 117
 118 -- Runs each of the transforms repeatedly inside the State monad.
 119 dotransforms' :: [Transform] -> CoreExpr -> State.State TransformState CoreExpr
 120 dotransforms' transs expr = do
 121   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
 122   if Monoid.getAny changed then dotransforms' transs expr' else return expr'
 123
 124 -- Sets the changed flag in the TransformMonad, to signify that some
 125 -- transform has changed the result
 126 setChanged :: TransformMonad ()
 127 setChanged = Writer.tell (Monoid.Any True)
 128
 129 -- Sets the changed flag and returns the given value.
 130 change :: a -> TransformMonad a
 131 change val = do
 132   setChanged
 133   return val
 134
 135 -- Create a new Unique
 136 mkUnique :: TransformMonad Unique.Unique
 137 mkUnique = Trans.lift $ do
 138     us <- getA tsUniqSupply
 139     let (us', us'') = UniqSupply.splitUniqSupply us
 140     putA tsUniqSupply us'
 141     return $ UniqSupply.uniqFromSupply us''