Commit 6ecd27ea authored by Austin Seipp's avatar Austin Seipp

compiler: de-lhs simplCore/

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent b9b1fab3
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
{-
(c) The AQUA Project, Glasgow University, 1993-1998
\section{Common subexpression}
-}
\begin{code}
{-# LANGUAGE CPP #-}
module CSE (cseProgram) where
......@@ -22,9 +22,8 @@ import BasicTypes ( isAlwaysActive )
import TrieMap
import Data.List
\end{code}
{-
Simple common sub-expression
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we see
......@@ -146,13 +145,13 @@ Consider
Then we can CSE the inner (f x) to y. In fact 'case' is like a strict
let-binding, and we can use cseRhs for dealing with the scrutinee.
%************************************************************************
%* *
************************************************************************
* *
\section{Common subexpression}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
cseProgram :: CoreProgram -> CoreProgram
cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
......@@ -256,16 +255,15 @@ cseAlts env scrut' bndr bndr' alts
= (con, args', tryForCSE env' rhs)
where
(env', args') = addBinders alt_env args
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\section{The CSE envt}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
type InExpr = CoreExpr -- Pre-cloning
type InBndr = CoreBndr
type InAlt = CoreAlt
......@@ -313,4 +311,3 @@ addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
where
(sub', vs') = substRecBndrs (cs_subst cse) vs
\end{code}
%
% (c) The AQUA Project, Glasgow University, 1993-1998
%
{-
(c) The AQUA Project, Glasgow University, 1993-1998
\section[CoreMonad]{The core pipeline monad}
-}
\begin{code}
{-# LANGUAGE CPP, UndecidableInstances #-}
module CoreMonad (
......@@ -118,19 +118,19 @@ saveLinkerGlobals = return ()
restoreLinkerGlobals :: () -> IO ()
restoreLinkerGlobals () = return ()
#endif
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Debug output
%* *
%************************************************************************
* *
************************************************************************
These functions are not CoreM monad stuff, but they probably ought to
be, and it makes a conveneint place. place for them. They print out
stuff before and after core passes, and do Core Lint when necessary.
-}
\begin{code}
showPass :: CoreToDo -> CoreM ()
showPass pass = do { dflags <- getDynFlags
; liftIO $ showPassIO dflags pass }
......@@ -286,17 +286,15 @@ interactiveInScope hsc_env
-- I think it's because of the GHCi debugger, which can bind variables
-- f :: [t] -> [t]
-- where t is a RuntimeUnk (see TcType)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
The CoreToDo type and related types
Abstraction of core-to-core passes to run.
%* *
%************************************************************************
\begin{code}
* *
************************************************************************
-}
data CoreToDo -- These are diff core-to-core passes,
-- which may be invoked in any order,
......@@ -330,9 +328,6 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreTidy
| CorePrep
\end{code}
\begin{code}
coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core
......@@ -384,9 +379,7 @@ pprPassDetails :: CoreToDo -> SDoc
pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n
, ppr md ]
pprPassDetails _ = Outputable.empty
\end{code}
\begin{code}
data SimplifierMode -- See comments in SimplMonad
= SimplMode
{ sm_names :: [String] -- Name(s) of the phase
......@@ -410,10 +403,7 @@ instance Outputable SimplifierMode where
, pp_flag cc (sLit "case-of-case") ])
where
pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
\end{code}
\begin{code}
data FloatOutSwitches = FloatOutSwitches {
floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
-- doing so will abstract over n or fewer
......@@ -450,9 +440,7 @@ runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe (Just x) f = f x
runMaybe Nothing _ = CoreDoNothing
\end{code}
{-
Note [RULEs enabled in SimplGently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RULES are enabled when doing "gentle" simplification. Two reasons:
......@@ -470,13 +458,13 @@ But watch out: list fusion can prevent floating. So use phase control
to switch off those rules until after floating.
%************************************************************************
%* *
************************************************************************
* *
Types for Plugins
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- | A description of the plugin pass itself
type PluginPass = ModGuts -> CoreM ModGuts
......@@ -484,16 +472,15 @@ bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
bindsOnlyPass pass guts
= do { binds' <- pass (mg_binds guts)
; return (guts { mg_binds = binds' }) }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Counting and logging
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
verboseSimplStats :: Bool
verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
......@@ -504,9 +491,7 @@ pprSimplCount :: SimplCount -> SDoc
doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount
doFreeSimplTick :: Tick -> SimplCount -> SimplCount
plusSimplCount :: SimplCount -> SimplCount -> SimplCount
\end{code}
\begin{code}
data SimplCount
= VerySimplCount !Int -- Used when don't want detailed stats
......@@ -608,10 +593,7 @@ pprTickGroup group@((tick1,_):_)
-- flip as we want largest first
| (tick,n) <- sortBy (flip (comparing snd)) group])
pprTickGroup [] = panic "pprTickGroup"
\end{code}
\begin{code}
data Tick
= PreInlineUnconditionally Id
| PostInlineUnconditionally Id
......@@ -725,16 +707,15 @@ cmpEqTick (CaseElim a) (CaseElim b) = a `com
cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
cmpEqTick _ _ = EQ
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Monad and carried data structure definitions
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
newtype CoreState = CoreState {
cs_uniq_supply :: UniqSupply
}
......@@ -841,16 +822,13 @@ runCoreM hsc_env rule_base us mod print_unqual m = do
extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
extract (value, _, writer) = (value, cw_simpl_count writer)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Core combinators, not exported
%* *
%************************************************************************
\begin{code}
* *
************************************************************************
-}
nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
nop s x = do
......@@ -869,11 +847,7 @@ modifyS f = CoreM (\s -> nop (f s) ())
write :: CoreWriter -> CoreM ()
write w = CoreM (\s -> return ((), s, w))
\end{code}
\subsection{Lifting IO into the monad}
\begin{code}
-- \subsection{Lifting IO into the monad}
-- | Lift an 'IOEnv' operation into 'CoreM'
liftIOEnv :: CoreIOEnv a -> CoreM a
......@@ -886,16 +860,14 @@ instance MonadIO CoreM where
liftIOWithCount :: IO (SimplCount, a) -> CoreM a
liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Reader, writer and state accessors
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
getHscEnv :: CoreM HscEnv
getHscEnv = read cr_hsc_env
......@@ -928,13 +900,13 @@ getPackageFamInstEnv = do
hsc_env <- getHscEnv
eps <- liftIO $ hscEPS hsc_env
return $ eps_fam_inst_env eps
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Initializing globals
%* *
%************************************************************************
* *
************************************************************************
This is a rather annoying function. When a plugin is loaded, it currently
gets linked against a *newly loaded* copy of the GHC package. This would
......@@ -973,8 +945,8 @@ will have to say `reinitializeGlobals` before it does anything, but never mind.
I've threaded the cr_globals through CoreM rather than giving them as an
argument to the plugin function so that we can turn this function into
(return ()) without breaking any plugins when we eventually get 1. working.
-}
\begin{code}
reinitializeGlobals :: CoreM ()
reinitializeGlobals = do
linker_globals <- read cr_globals
......@@ -982,15 +954,15 @@ reinitializeGlobals = do
let dflags = hsc_dflags hsc_env
liftIO $ restoreLinkerGlobals linker_globals
liftIO $ setUnsafeGlobalDynFlags dflags
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Dealing with annotations
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- | Get all annotations of a given type. This happens lazily, that is
-- no deserialization will take place until the [a] is actually demanded and
-- the [a] can also be empty (the UniqFM is not filtered).
......@@ -1011,8 +983,7 @@ getFirstAnnotations deserialize guts
= liftM (mapUFM head . filterUFM (not . null))
$ getAnnotations deserialize guts
\end{code}
{-
Note [Annotations]
~~~~~~~~~~~~~~~~~~
A Core-to-Core pass that wants to make use of annotations calls
......@@ -1031,13 +1002,12 @@ only want to deserialise every annotation once, we would have to build a cache
for every module in the HTP. In the end, it's probably not worth it as long as
we aren't using annotations heavily.
%************************************************************************
%* *
************************************************************************
* *
Direct screen output
%* *
%************************************************************************
\begin{code}
* *
************************************************************************
-}
msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
msg how doc = do
......@@ -1079,29 +1049,28 @@ debugTraceMsg = msg (flip Err.debugTraceMsg 3)
-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Finding TyThings
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
instance MonadThings CoreM where
lookupThing name = do
hsc_env <- getHscEnv
liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Template Haskell interoperability
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
#ifdef GHCI
-- | Attempt to convert a Template Haskell name to one that GHC can
-- understand. Original TH names such as those you get when you use
......@@ -1114,4 +1083,3 @@ thNameToGhcName th_name = do
hsc_env <- getHscEnv
liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
#endif
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
%************************************************************************
%* *
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
************************************************************************
* *
\section[FloatIn]{Floating Inwards pass}
%* *
%************************************************************************
* *
************************************************************************
The main purpose of @floatInwards@ is floating into branches of a
case, so that we don't allocate things, save them on the stack, and
then discover that they aren't needed in the chosen branch.
-}
\begin{code}
{-# LANGUAGE CPP #-}
module FloatIn ( floatInwards ) where
......@@ -31,12 +31,12 @@ import UniqFM
import DynFlags
import Outputable
import Data.List( mapAccumL )
\end{code}
{-
Top-level interface function, @floatInwards@. Note that we do not
actually float any bindings downwards from the top-level.
-}
\begin{code}
floatInwards :: DynFlags -> CoreProgram -> CoreProgram
floatInwards dflags = map fi_top_bind
where
......@@ -44,13 +44,13 @@ floatInwards dflags = map fi_top_bind
= NonRec binder (fiExpr dflags [] (freeVars rhs))
fi_top_bind (Rec pairs)
= Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Mail from Andr\'e [edited]}
%* *
%************************************************************************
* *
************************************************************************
{\em Will wrote: What??? I thought the idea was to float as far
inwards as possible, no matter what. This is dropping all bindings
......@@ -110,13 +110,13 @@ Also, even if a is not found to be strict in the new context and is
still left as a let, if the branch is not taken (or b is not entered)
the closure for a is not built.
%************************************************************************
%* *
************************************************************************
* *
\subsection{Main floating-inwards code}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
type FreeVarSet = IdSet
type BoundVarSet = IdSet
......@@ -143,13 +143,13 @@ fiExpr dflags to_drop (_, AnnCast expr (fvs_co, co))
Cast (fiExpr dflags e_drop expr) co
where
[drop_here, e_drop, co_drop] = sepBindsByDropPoint dflags False [freeVarsOf expr, fvs_co] to_drop
\end{code}
{-
Applications: we do float inside applications, mainly because we
need to get at all the arguments. The next simplifier run will
pull out any silly ones.
-}
\begin{code}
fiExpr dflags to_drop ann_expr@(_,AnnApp {})
= wrapFloats drop_here $ wrapFloats extra_drop $
mkApps (fiExpr dflags fun_drop ann_fun)
......@@ -175,8 +175,8 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {})
drop_here : extra_drop : fun_drop : arg_drops
= sepBindsByDropPoint dflags False (extra_fvs : fun_fvs : arg_fvs) to_drop
\end{code}
{-
Note [Do not destroy the let/app invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Watch out for
......@@ -223,8 +223,8 @@ This is what the 'go' function in the AnnLam case is doing.
Urk! if all are tyvars, and we don't float in, we may miss an
opportunity to float inside a nested case branch
-}
\begin{code}
fiExpr dflags to_drop lam@(_, AnnLam _ _)
| okToFloatInside bndrs -- Float in
-- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088
......@@ -235,14 +235,14 @@ fiExpr dflags to_drop lam@(_, AnnLam _ _)
where
(bndrs, body) = collectAnnBndrs lam
\end{code}
{-
We don't float lets inwards past an SCC.
ToDo: keep info on current cc, and when passing
one, if it is not the same, annotate all lets in binds with current
cc, change current cc to the new one and float binds into expr.
-}
\begin{code}
fiExpr dflags to_drop (_, AnnTick tickish expr)
| tickishScoped tickish
= -- Wimp out for now - we could push values in
......@@ -250,8 +250,8 @@ fiExpr dflags to_drop (_, AnnTick tickish expr)
| otherwise
= Tick tickish (fiExpr dflags to_drop expr)
\end{code}
{-
For @Lets@, the possible ``drop points'' for the \tr{to_drop}
bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
or~(b2), in each of the RHSs of the pairs of a @Rec@.
......@@ -300,9 +300,8 @@ Here y is not free in rhs or body; but we still want to dump bindings
that bind y outside the let. So we augment extra_fvs with the
idRuleAndUnfoldingVars of x. No need for type variables, hence not using
idFreeVars.
-}
\begin{code}
fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
= fiExpr dflags new_to_drop body
where
......@@ -365,8 +364,8 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body)
fi_bind to_drops pairs
= [ (binder, fiExpr dflags to_drop rhs)
| ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
\end{code}
{-
For @Case@, the possible ``drop points'' for the \tr{to_drop}
bindings are: (a)~inside the scrutinee, (b)~inside one of the
alternatives/default [default FVs always {\em first}!].
......@@ -378,8 +377,8 @@ inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
scalars also need to be floated inward, but unpacks have a single non-DEFAULT
alternative that binds the elements of the tuple. We now therefore also support
floating in cases with a single alternative that may bind values.
-}
\begin{code}
fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
| isUnLiftedType (idType case_bndr)
, exprOkForSideEffects (deAnnotate scrut)
......@@ -448,14 +447,13 @@ noFloatIntoExpr (AnnLam bndr e)
noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs)
-- We'd just float right back out again...
-- Should match the test in SimplEnv.doFloatFromRhs
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{@sepBindsByDropPoint@}
%* *
%************************************************************************
* *
************************************************************************
This is the crucial function. The idea is: We have a wad of bindings
that we'd like to distribute inside a collection of {\em drop points};
......@@ -471,8 +469,8 @@ then it has to go in a you-must-drop-it-above-all-these-drop-points
point.
We have to maintain the order on these drop-point-related lists.
-}
\begin{code}
sepBindsByDropPoint
:: DynFlags
-> Bool -- True <=> is case expression
......@@ -560,4 +558,3 @@ floatIsDupable :: DynFlags -> FloatBind -> Bool
floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut
floatIsDupable dflags (FloatLet (Rec prs)) = all (exprIsDupable dflags . snd) prs
floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
\end{code}