X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=ab7923947a97123ff75241e58ebcb95ab2955c79;hb=08652e67c4d5d9a40687f93c286021a867c1bca0;hp=c29d217b00a794a4596b98f46cdc0b21ce4d1790;hpb=ebd091d5cd703b249838baaa125e6c0fa0fe0e45;p=ghc-hetmet.git

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index c29d217..ab79239 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -4,13 +4,6 @@
 \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"
@@ -142,7 +135,7 @@ liberateCase hsc_env _ _ guts
 			{- no specific flag for dumping -} 
 	; return (zeroSimplCount dflags, guts { mg_binds = 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 +159,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
 
@@ -195,7 +188,8 @@ libCaseBind env (Rec pairs)
 
     rhs_small_enough (id,rhs)
 	=  idArity id > 0	-- Note [Only functions!]
-	&& couldBeSmallEnoughToInline (bombOutSize env) rhs
+	&& maybe True (\size -> couldBeSmallEnoughToInline size rhs)
+                      (bombOutSize env)
 \end{code}
 
 
@@ -207,9 +201,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
@@ -228,8 +222,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}
 
@@ -349,7 +345,7 @@ topLevel = 0
 \begin{code}
 data LibCaseEnv
   = LibCaseEnv {
-	lc_size :: Int,		-- Bomb-out size for deciding if
+	lc_size :: Maybe Int,	-- Bomb-out size for deciding if
 				-- potential liberatees are too big.
 				-- (passed in from cmd-line args)
 
@@ -377,12 +373,13 @@ data LibCaseEnv
 
 initEnv :: DynFlags -> LibCaseEnv
 initEnv dflags 
-  = LibCaseEnv { lc_size = specThreshold dflags,
+  = LibCaseEnv { lc_size = liberateCaseThreshold dflags,
 		 lc_lvl = 0,
 		 lc_lvl_env = emptyVarEnv, 
 		 lc_rec_env = emptyVarEnv,
 		 lc_scruts = [] }
 
+bombOutSize :: LibCaseEnv -> Maybe Int
 bombOutSize = lc_size
 \end{code}