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 List
   9 import qualified Data.Monoid as Monoid
  10 import qualified Data.Either as Either
  11 import qualified Control.Arrow as Arrow
  12 import qualified Control.Monad as Monad
  13 import qualified Control.Monad.Trans.State as State
  14 import qualified Control.Monad.Trans.Writer as Writer
  15 import qualified "transformers" Control.Monad.Trans as Trans
  16 import qualified Data.Map as Map
  17 import Data.Accessor
  18 import Data.Accessor.MonadState as MonadState
  19
  20 -- GHC API
  21 import CoreSyn
  22 import qualified UniqSupply
  23 import qualified Unique
  24 import qualified OccName
  25 import qualified Name
  26 import qualified Var
  27 import qualified SrcLoc
  28 import qualified Type
  29 import qualified IdInfo
  30 import qualified CoreUtils
  31 import qualified CoreSubst
  32 import qualified VarSet
  33 import Outputable ( showSDoc, ppr, nest )
  34
  35 -- Local imports
  36 import NormalizeTypes
  37 import Pretty
  38 import qualified VHDLTools
  39
  40 -- Create a new internal var with the given name and type. A Unique is
  41 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
  42 -- since the Unique is also stored in the name, but this ensures variable
  43 -- names are unique in the output).
  44 mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var
  45 mkInternalVar str ty = do
  46   uniq <- mkUnique
  47   let occname = OccName.mkVarOcc (str ++ show uniq)
  48   let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
  49   return $ Var.mkLocalIdVar name ty IdInfo.vanillaIdInfo
  50
  51 -- Create a new type variable with the given name and kind. A Unique is
  52 -- appended to the given name, to ensure uniqueness (not strictly neccesary,
  53 -- since the Unique is also stored in the name, but this ensures variable
  54 -- names are unique in the output).
  55 mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var
  56 mkTypeVar str kind = do
  57   uniq <- mkUnique
  58   let occname = OccName.mkVarOcc (str ++ show uniq)
  59   let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan
  60   return $ Var.mkTyVar name kind
  61
  62 -- Creates a binder for the given expression with the given name. This
  63 -- works for both value and type level expressions, so it can return a Var or
  64 -- TyVar (which is just an alias for Var).
  65 mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var
  66 mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty)
  67 mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr)
  68
  69 -- Creates a reference to the given variable. This works for both a normal
  70 -- variable as well as a type variable
  71 mkReferenceTo :: Var.Var -> CoreExpr
  72 mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var)
  73                   | otherwise       = (Var var)
  74
  75 cloneVar :: Var.Var -> TransformMonad Var.Var
  76 cloneVar v = do
  77   uniq <- mkUnique
  78   -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it
  79   -- contains, but vannillaIdInfo is always correct, since it means "no info").
  80   return $ Var.lazySetVarIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo
  81
  82 -- Creates a new function with the same name as the given binder (but with a
  83 -- new unique) and with the given function body. Returns the new binder for
  84 -- this function.
  85 mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr
  86 mkFunction bndr body = do
  87   let ty = CoreUtils.exprType body
  88   id <- cloneVar bndr
  89   let newid = Var.setVarType id ty
  90   Trans.lift $ addGlobalBind newid body
  91   return newid
  92
  93 -- Apply the given transformation to all expressions in the given expression,
  94 -- including the expression itself.
  95 everywhere :: (String, Transform) -> Transform
  96 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  97
  98 -- Apply the first transformation, followed by the second transformation, and
  99 -- keep applying both for as long as expression still changes.
 100 applyboth :: Transform -> (String, Transform) -> Transform
 101 applyboth first (name, second) expr  = do
 102   -- Apply the first
 103   expr' <- first expr
 104   -- Apply the second
 105   (expr'', changed) <- Writer.listen $ second expr'
 106   if Monoid.getAny $
 107   --      trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
 108         changed
 109     then
 110 --      trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
 111  --     trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
 112       applyboth first (name, second) $
 113         expr''
 114     else
 115     --  trace ("No changes") $
 116       return expr''
 117
 118 -- Apply the given transformation to all direct subexpressions (only), not the
 119 -- expression itself.
 120 subeverywhere :: Transform -> Transform
 121 subeverywhere trans (App a b) = do
 122   a' <- trans a
 123   b' <- trans b
 124   return $ App a' b'
 125
 126 subeverywhere trans (Let (NonRec b bexpr) expr) = do
 127   bexpr' <- trans bexpr
 128   expr' <- trans expr
 129   return $ Let (NonRec b bexpr') expr'
 130
 131 subeverywhere trans (Let (Rec binds) expr) = do
 132   expr' <- trans expr
 133   binds' <- mapM transbind binds
 134   return $ Let (Rec binds') expr'
 135   where
 136     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
 137     transbind (b, e) = do
 138       e' <- trans e
 139       return (b, e')
 140
 141 subeverywhere trans (Lam x expr) = do
 142   expr' <- trans expr
 143   return $ Lam x expr'
 144
 145 subeverywhere trans (Case scrut b t alts) = do
 146   scrut' <- trans scrut
 147   alts' <- mapM transalt alts
 148   return $ Case scrut' b t alts'
 149   where
 150     transalt :: CoreAlt -> TransformMonad CoreAlt
 151     transalt (con, binders, expr) = do
 152       expr' <- trans expr
 153       return (con, binders, expr')
 154
 155 subeverywhere trans (Var x) = return $ Var x
 156 subeverywhere trans (Lit x) = return $ Lit x
 157 subeverywhere trans (Type x) = return $ Type x
 158
 159 subeverywhere trans (Cast expr ty) = do
 160   expr' <- trans expr
 161   return $ Cast expr' ty
 162
 163 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
 164
 165 -- Apply the given transformation to all expressions, except for direct
 166 -- arguments of an application
 167 notappargs :: (String, Transform) -> Transform
 168 notappargs trans = applyboth (subnotappargs trans) trans
 169
 170 -- Apply the given transformation to all (direct and indirect) subexpressions
 171 -- (but not the expression itself), except for direct arguments of an
 172 -- application
 173 subnotappargs :: (String, Transform) -> Transform
 174 subnotappargs trans (App a b) = do
 175   a' <- subnotappargs trans a
 176   b' <- subnotappargs trans b
 177   return $ App a' b'
 178
 179 -- Let subeverywhere handle all other expressions
 180 subnotappargs trans expr = subeverywhere (notappargs trans) expr
 181
 182 -- Runs each of the transforms repeatedly inside the State monad.
 183 dotransforms :: [Transform] -> CoreExpr -> TransformSession CoreExpr
 184 dotransforms transs expr = do
 185   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
 186   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 187
 188 -- Inline all let bindings that satisfy the given condition
 189 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 190 inlinebind condition expr@(Let (Rec binds) res) = do
 191     -- Find all bindings that adhere to the condition
 192     res_eithers <- mapM docond binds
 193     case Either.partitionEithers res_eithers of
 194       -- No replaces? No change
 195       ([], _) -> return expr
 196       (replace, others) -> do
 197         -- Substitute the to be replaced binders with their expression
 198         let newexpr = substitute replace (Let (Rec others) res)
 199         change newexpr
 200   where
 201     docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
 202     docond b = do
 203       res <- condition b
 204       return $ case res of True -> Left b; False -> Right b
 205
 206 -- Leave all other expressions unchanged
 207 inlinebind _ expr = return expr
 208
 209 -- Sets the changed flag in the TransformMonad, to signify that some
 210 -- transform has changed the result
 211 setChanged :: TransformMonad ()
 212 setChanged = Writer.tell (Monoid.Any True)
 213
 214 -- Sets the changed flag and returns the given value.
 215 change :: a -> TransformMonad a
 216 change val = do
 217   setChanged
 218   return val
 219
 220 -- Create a new Unique
 221 mkUnique :: TransformMonad Unique.Unique
 222 mkUnique = Trans.lift $ do
 223     us <- getA tsUniqSupply
 224     let (us', us'') = UniqSupply.splitUniqSupply us
 225     putA tsUniqSupply us'
 226     return $ UniqSupply.uniqFromSupply us''
 227
 228 -- Replace each of the binders given with the coresponding expressions in the
 229 -- given expression.
 230 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
 231 substitute [] expr = expr
 232 -- Apply one substitution on the expression, but also on any remaining
 233 -- substitutions. This seems to be the only way to handle substitutions like
 234 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
 235 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
 236 -- TODO: Find out how this works, exactly.
 237 substitute ((b, e):subss) expr = substitute subss' expr'
 238   where
 239     -- Create the Subst
 240     subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
 241     -- Apply this substitution to the main expression
 242     expr' = CoreSubst.substExpr subs expr
 243     -- Apply this substitution on all the expressions in the remaining
 244     -- substitutions
 245     subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
 246
 247 -- Run a given TransformSession. Used mostly to setup the right calls and
 248 -- an initial state.
 249 runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a
 250 runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply)
 251
 252 -- Is the given expression representable at runtime, based on the type?
 253 isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
 254 isRepr (Type ty) = return False
 255 isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr)