\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}
%************************************************************************
\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
libCaseBind env (Rec pairs)
= (env_body, Rec pairs')
where
- (binders, rhss) = unzip pairs
+ (binders, _rhss) = unzip pairs
env_body = addBinders env binders
-- 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
-- (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!]
- && couldBeSmallEnoughToInline (bombOutSize env) rhs
+ && maybe True (\size -> couldBeSmallEnoughToInline size rhs)
+ (bombOutSize env)
\end{code}
-> 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
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}
\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)
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}