Add (a) CoreM monad, (b) new Annotations feature

[ghc-hetmet.git] / compiler / simplCore / LiberateCase.lhs

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index 9c51103..4b1055b 100644 (file)
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -4,28 +4,15 @@
 \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module LiberateCase ( liberateCase ) where
 
 #include "HsVersions.h"
 
 import DynFlags
-import HscTypes
-import CoreLint                ( showPass, endPass )
 import CoreSyn
 import CoreUnfold      ( couldBeSmallEnoughToInline )
-import Rules           ( RuleBase )
-import UniqSupply      ( UniqSupply )
-import SimplMonad      ( SimplCount, zeroSimplCount )
 import Id
 import VarEnv
-import Name            ( localiseName )
 import Util             ( notNull )
 \end{code}
 
@@ -130,19 +117,10 @@ and the level of @h@ is zero (NB not one).
 %************************************************************************
 
 \begin{code}
-liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-            -> IO (SimplCount, ModGuts)
-liberateCase hsc_env _ _ guts
-  = do { let dflags = hsc_dflags hsc_env
-
-       ; showPass dflags "Liberate case"
-       ; let { env = initEnv dflags
-             ; binds' = do_prog env (mg_binds guts) }
-       ; endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
-                       {- no specific flag for dumping -} 
-       ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
+liberateCase :: DynFlags -> [CoreBind] -> [CoreBind]
+liberateCase dflags binds = do_prog (initEnv dflags) binds
   where
-    do_prog env [] = []
+    do_prog _   [] = []
     do_prog env (bind:binds) = bind' : do_prog env' binds
                             where
                               (env', bind') = libCaseBind env bind
@@ -166,7 +144,7 @@ libCaseBind env (NonRec binder rhs)
 libCaseBind env (Rec pairs)
   = (env_body, Rec pairs')
   where
-    (binders, rhss) = unzip pairs
+    (binders, _rhss) = unzip pairs
 
     env_body = addBinders env binders
 
@@ -178,10 +156,10 @@ libCaseBind env (Rec pairs)
        -- processing the rhs with an *un-extended* environment, so
        -- that the same process doesn't occur for ever!
        --
-    extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs)
+    extended_env = addRecBinds env [ (localiseId binder, libCase env_body rhs)
                                   | (binder, rhs) <- pairs ]
 
-       -- Two subtle things: 
+       -- The call to localiseId is needed for two subtle reasons
        -- (a)  Reset the export flags on the binders so
        --      that we don't get name clashes on exported things if the 
        --      local binding floats out to top level.  This is most unlikely
@@ -191,7 +169,6 @@ libCaseBind env (Rec pairs)
        -- (b)  Make the name an Internal one.  External Names should never be
        --      nested; if it were floated to the top level, we'd get a name
        --      clash at code generation time.
-    adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr)))
 
     rhs_small_enough (id,rhs)
        =  idArity id > 0       -- Note [Only functions!]
@@ -208,9 +185,9 @@ libCase :: LibCaseEnv
        -> CoreExpr
        -> CoreExpr
 
-libCase env (Var v)            = libCaseId env v
-libCase env (Lit lit)          = Lit lit
-libCase env (Type ty)          = Type ty
+libCase env (Var v)             = libCaseId env v
+libCase _   (Lit lit)           = Lit lit
+libCase _   (Type ty)           = Type ty
 libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
 libCase env (Note note body)    = Note note (libCase env body)
 libCase env (Cast e co)         = Cast (libCase env e) co
@@ -229,8 +206,10 @@ libCase env (Case scrut bndr ty alts)
     env_alts = addBinders (mk_alt_env scrut) [bndr]
     mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
     mk_alt_env (Cast scrut _)  = mk_alt_env scrut      -- Note [Scrutinee with cast]
-    mk_alt_env otehr          = env
+    mk_alt_env _              = env
 
+libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
+                         -> (AltCon, [CoreBndr], CoreExpr)
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 \end{code}
 
@@ -384,6 +363,7 @@ initEnv dflags
                 lc_rec_env = emptyVarEnv,
                 lc_scruts = [] }
 
+bombOutSize :: LibCaseEnv -> Maybe Int
 bombOutSize = lc_size
 \end{code}