summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAustin Seipp <austin@well-typed.com>2014-12-03 12:45:25 -0600
committerAustin Seipp <austin@well-typed.com>2014-12-03 13:52:27 -0600
commit6ecd27eae6f3a6f3ec3e1a6a66cad09b4eb332be (patch)
tree7df2409f0660ca6b6fe2282d34fdc1b05dba4a68
parentb9b1fab36a3df98bf3796df3090e4d5d8d592f7e (diff)
downloadhaskell-6ecd27eae6f3a6f3ec3e1a6a66cad09b4eb332be.tar.gz
compiler: de-lhs simplCore/
Signed-off-by: Austin Seipp <austin@well-typed.com>
-rw-r--r--compiler/simplCore/CSE.hs (renamed from compiler/simplCore/CSE.lhs)35
-rw-r--r--compiler/simplCore/CoreMonad.hs (renamed from compiler/simplCore/CoreMonad.lhs)186
-rw-r--r--compiler/simplCore/FloatIn.hs (renamed from compiler/simplCore/FloatIn.lhs)75
-rw-r--r--compiler/simplCore/FloatOut.hs (renamed from compiler/simplCore/FloatOut.lhs)69
-rw-r--r--compiler/simplCore/LiberateCase.hs (renamed from compiler/simplCore/LiberateCase.lhs)71
-rw-r--r--compiler/simplCore/OccurAnal.hs (renamed from compiler/simplCore/OccurAnal.lhs)142
-rw-r--r--compiler/simplCore/SAT.hs (renamed from compiler/simplCore/SAT.lhs)43
-rw-r--r--compiler/simplCore/SetLevels.hs (renamed from compiler/simplCore/SetLevels.lhs)109
-rw-r--r--compiler/simplCore/SimplCore.hs (renamed from compiler/simplCore/SimplCore.lhs)101
-rw-r--r--compiler/simplCore/SimplEnv.hs (renamed from compiler/simplCore/SimplEnv.lhs)112
-rw-r--r--compiler/simplCore/SimplMonad.hs (renamed from compiler/simplCore/SimplMonad.lhs)51
-rw-r--r--compiler/simplCore/SimplUtils.hs (renamed from compiler/simplCore/SimplUtils.lhs)164
-rw-r--r--compiler/simplCore/Simplify.hs (renamed from compiler/simplCore/Simplify.lhs)195
13 files changed, 616 insertions, 737 deletions
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.hs
index ccd4b2e721..7dbf892f9e 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.hs
@@ -1,9 +1,9 @@
-%
-% (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}
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.hs
index c175b07384..d50027c6ea 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -1,9 +1,9 @@
-%
-% (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}
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.hs
index 13d03efa24..34252881ab 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.hs
@@ -1,17 +1,17 @@
-%
-% (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}
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.hs
index 55ed111a70..4cd871334d 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.hs
@@ -1,11 +1,11 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
\section[FloatOut]{Float bindings outwards (towards the top level)}
``Long-distance'' floating of bindings towards the top level.
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -31,8 +31,8 @@ import FastString
import qualified Data.IntMap as M
#include "HsVersions.h"
-\end{code}
+{-
-----------------
Overall game plan
-----------------
@@ -106,13 +106,13 @@ vwhich might usefully be separated to
Well, maybe. We don't do this at the moment.
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
floatOutwards :: FloatOutSwitches
-> DynFlags
-> UniqSupply
@@ -144,15 +144,15 @@ floatTopBind bind
in case bind' of
Rec prs -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
NonRec {} -> (fs, float_bag `snocBag` bind') }
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection[FloatOut-Bind]{Floating in a binding (the business end)}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
floatBind :: LevelledBind -> (FloatStats, FloatBinds, CoreBind)
floatBind (NonRec (TB var _) rhs)
= case (floatExpr rhs) of { (fs, rhs_floats, rhs') ->
@@ -205,8 +205,8 @@ floatList _ [] = (zeroStats, emptyFloats, [])
floatList f (a:as) = case f a of { (fs_a, binds_a, b) ->
case floatList f as of { (fs_as, binds_as, bs) ->
(fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }}
-\end{code}
+{-
Note [Floating out of Rec rhss]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider Rec { f<1,0> = \xy. body }
@@ -239,13 +239,13 @@ We could perhaps get rid of the 'tops' component of the floating binds,
but this case works just as well.
-%************************************************************************
+************************************************************************
\subsection[FloatOut-Expr]{Floating in expressions}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
floatBody :: Level
-> LevelledExpr
-> (FloatStats, FloatBinds, CoreExpr)
@@ -342,8 +342,8 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
float_alt bind_lvl (con, bs, rhs)
= case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
(fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
-\end{code}
+{-
Note [Avoiding unnecessary floating]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general we want to avoid floating a let unnecessarily, because
@@ -383,16 +383,16 @@ altogether when profiling got in the way.
So now we do the partition right at the (Let..) itself.
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection{Utility bits for floating stats}
-%* *
-%************************************************************************
+* *
+************************************************************************
I didn't implement this with unboxed numbers. I don't want to be too
strict in this stuff, as it is rarely turned on. (WDP 95/09)
+-}
-\begin{code}
data FloatStats
= FlS Int -- Number of top-floats * lambda groups they've been past
Int -- Number of non-top-floats * lambda groups they've been past
@@ -414,14 +414,13 @@ add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
add_to_stats :: FloatStats -> FloatBinds -> FloatStats
add_to_stats (FlS a b c) (FB tops others)
= FlS (a + lengthBag tops) (b + lengthBag (flattenMajor others)) (c + 1)
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Utility bits for floating}
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Representation of FloatBinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -441,9 +440,8 @@ That is why MajorEnv is represented as a finite map.
We keep the bindings destined for the *top* level separate, because
we float them out even if they don't escape a *value* lambda; see
partitionByMajorLevel.
+-}
-
-\begin{code}
type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted
type MajorEnv = M.IntMap MinorEnv -- Keyed by major level
type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level
@@ -563,4 +561,3 @@ wrapTick t (FB tops defns)
-- Conversely, inlining of HNFs inside an SCC is allowed, and
-- indeed the HNF we're floating here might well be inlined back
-- again, and we don't want to end up with duplicate ticks.
-\end{code}
diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.hs
index 21adf20f44..1df1405329 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.hs
@@ -1,9 +1,9 @@
-%
-% (c) The AQUA Project, Glasgow University, 1994-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1994-1998
+
\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
module LiberateCase ( liberateCase ) where
@@ -15,8 +15,8 @@ import CoreUnfold ( couldBeSmallEnoughToInline )
import Id
import VarEnv
import Util ( notNull )
-\end{code}
+{-
The liberate-case transformation
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This module walks over @Core@, and looks for @case@ on free variables.
@@ -111,13 +111,13 @@ Here, the level of @f@ is zero, the level of @g@ is one,
and the level of @h@ is zero (NB not one).
-%************************************************************************
-%* *
+************************************************************************
+* *
Top-level code
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
liberateCase :: DynFlags -> CoreProgram -> CoreProgram
liberateCase dflags binds = do_prog (initEnv dflags) binds
where
@@ -125,18 +125,18 @@ liberateCase dflags binds = do_prog (initEnv dflags) binds
do_prog env (bind:binds) = bind' : do_prog env' binds
where
(env', bind') = libCaseBind env bind
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Main payload
-%* *
-%************************************************************************
+* *
+************************************************************************
Bindings
~~~~~~~~
-\begin{code}
+-}
+
libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
libCaseBind env (NonRec binder rhs)
@@ -164,8 +164,8 @@ libCaseBind env (Rec pairs)
= idArity id > 0 -- Note [Only functions!]
&& maybe True (\size -> couldBeSmallEnoughToInline (lc_dflags env) size rhs)
(bombOutSize env)
-\end{code}
+{-
Note [Need to localiseId in libCaseBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The call to localiseId is needed for two subtle reasons
@@ -191,8 +191,8 @@ rhs_small_enough call in the comprehension for env_rhs does.
Expressions
~~~~~~~~~~~
+-}
-\begin{code}
libCase :: LibCaseEnv
-> CoreExpr
-> CoreExpr
@@ -224,12 +224,12 @@ libCase env (Case scrut bndr ty alts)
libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
-> (AltCon, [CoreBndr], CoreExpr)
libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
-\end{code}
-
+{-
Ids
~~~
-\begin{code}
+-}
+
libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
| Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
@@ -253,8 +253,8 @@ freeScruts env rec_bind_lvl
, scrut_at_lvl > rec_bind_lvl]
-- Note [When to specialise]
-- Note [Avoiding fruitless liberate-case]
-\end{code}
+{-
Note [When to specialise]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
@@ -294,13 +294,13 @@ an occurrence of 'g', we want to check that there's a scruted-var v st
b) v's scrutinisation site is *inside* g
-%************************************************************************
-%* *
+************************************************************************
+* *
Utility functions
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
= env { lc_lvl_env = lvl_env' }
@@ -342,22 +342,20 @@ lookupLevel env id
= case lookupVarEnv (lc_lvl_env env) id of
Just lvl -> lvl
Nothing -> topLevel
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
The environment
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
type LibCaseLevel = Int
topLevel :: LibCaseLevel
topLevel = 0
-\end{code}
-\begin{code}
data LibCaseEnv
= LibCaseEnv {
lc_dflags :: DynFlags,
@@ -408,4 +406,3 @@ initEnv dflags
-- (passed in from cmd-line args)
bombOutSize :: LibCaseEnv -> Maybe Int
bombOutSize = liberateCaseThreshold . lc_dflags
-\end{code}
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.hs
index ef212bca85..26aec9dcc7 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -1,17 +1,16 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-%************************************************************************
-%* *
+************************************************************************
+* *
\section[OccurAnal]{Occurrence analysis pass}
-%* *
-%************************************************************************
+* *
+************************************************************************
The occurrence analyser re-typechecks a core expression, returning a new
core expression with (hopefully) improved usage information.
+-}
-\begin{code}
{-# LANGUAGE CPP, BangPatterns #-}
module OccurAnal (
@@ -41,18 +40,17 @@ import Util
import Outputable
import FastString
import Data.List
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
-%************************************************************************
+* *
+************************************************************************
Here's the externally-callable interface:
+-}
-\begin{code}
occurAnalysePgm :: Module -- Used only in debug output
-> (Activation -> Bool)
-> [CoreRule] -> [CoreVect] -> VarSet
@@ -114,19 +112,18 @@ occurAnalyseExpr' enable_binder_swap expr
env = (initOccEnv all_active_rules) {occ_binder_swap = enable_binder_swap}
-- To be conservative, we say that all inlines and rules are active
all_active_rules = \_ -> True
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
-%* *
-%************************************************************************
+* *
+************************************************************************
Bindings
~~~~~~~~
+-}
-\begin{code}
occAnalBind :: OccEnv -- The incoming OccEnv
-> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs
-> CoreBind
@@ -177,8 +174,8 @@ occAnalRecBind env imp_rules_edges pairs body_usage
nodes :: [Node Details]
nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs
-\end{code}
+{-
Note [Dead code]
~~~~~~~~~~~~~~~~
Dropping dead code for a cyclic Strongly Connected Component is done
@@ -634,9 +631,8 @@ But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite
- now there's another opportunity to apply the RULE
This showed up when compiling Control.Concurrent.Chan.getChanContents.
+-}
-
-\begin{code}
type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
-- which is gotten from the Id.
data Details
@@ -793,8 +789,8 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds)
| (ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs },_,_) <- nodes
, let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set
, not (isEmptyVarSet trimmed_rule_fvs)]
-\end{code}
+{-
@loopBreakSCC@ is applied to the list of (binder,rhs) pairs for a cyclic
strongly connected component (there's guaranteed to be a cycle). It returns the
same pairs, but
@@ -809,8 +805,8 @@ Furthermore, the order of the binds is such that if we neglect dependencies
on the no-inline Ids then the binds are topologically sorted. This means
that the simplifier will generally do a good job if it works from top bottom,
recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
+-}
-\begin{code}
type Binding = (Id,CoreExpr)
mk_loop_breaker :: Node Details -> Binding
@@ -944,8 +940,8 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
is_con_app (Lam _ e) = is_con_app e
is_con_app (Tick _ e) = is_con_app e
is_con_app _ = False
-\end{code}
+{-
Note [Complexity of loop breaking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The loop-breaking algorithm knocks out one binder at a time, and
@@ -1067,9 +1063,8 @@ ToDo: try using the occurrence info for the inline'd binder.
[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC.
[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC.
+-}
-
-\begin{code}
occAnalRecRhs :: OccEnv -> CoreExpr -- Rhs
-> (UsageDetails, CoreExpr)
-- Returned usage details covers only the RHS,
@@ -1111,8 +1106,8 @@ addIdOccs usage id_set = foldVarSet add usage id_set
-- b) We don't want to substitute a BIG expression inside a RULE
-- even if that's the only occurrence of the thing
-- (Same goes for INLINE.)
-\end{code}
+{-
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
By default we use an rhsCtxt for the RHS of a binding. This tells the
@@ -1155,7 +1150,8 @@ for the various clauses.
Expressions
~~~~~~~~~~~
-\begin{code}
+-}
+
occAnal :: OccEnv
-> CoreExpr
-> (UsageDetails, -- Gives info only about the "interesting" Ids
@@ -1174,14 +1170,14 @@ occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
occAnal _ (Coercion co)
= (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
-- See Note [Gather occurrences of coercion variables]
-\end{code}
+{-
Note [Gather occurrences of coercion variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to gather info about what coercion variables appear, so that
we can sort them into the right place when doing dependency analysis.
+-}
-\begin{code}
occAnal env (Tick tickish body)
| Breakpoint _ ids <- tickish
= (mapVarEnv markInsideSCC usage
@@ -1206,9 +1202,7 @@ occAnal env (Cast expr co)
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
}
-\end{code}
-\begin{code}
occAnal env app@(App _ _)
= occAnalApp env (collectArgs app)
@@ -1286,7 +1280,7 @@ occAnal env (Let bind body)
(final_usage, mkLets new_binds body') }}
occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
-occAnalArgs _ [] _
+occAnalArgs _ [] _
= (emptyDetails, [])
occAnalArgs env (arg:args) one_shots
@@ -1299,8 +1293,8 @@ occAnalArgs env (arg:args) one_shots
case occAnal arg_env arg of { (uds1, arg') ->
case occAnalArgs env args one_shots' of { (uds2, args') ->
(uds1 +++ uds2, arg':args') }}}
-\end{code}
+{-
Applications are dealt with specially because we want
the "build hack" to work.
@@ -1315,8 +1309,8 @@ that y may be duplicated thereby.
If we aren't careful we duplicate the (expensive x) call!
Constructors are rather like lambdas in this way.
+-}
-\begin{code}
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr])
-> (UsageDetails, Expr CoreBndr)
@@ -1371,8 +1365,8 @@ markManyIf :: Bool -- If this is true
-> UsageDetails
markManyIf True uds = mapVarEnv markMany uds
markManyIf False uds = uds
-\end{code}
+{-
Note [Use one-shot information]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The occurrrence analyser propagates one-shot-lambda information in two situation
@@ -1402,8 +1396,8 @@ Simplify.mkDupableAlt
In this example, though, the Simplifier will bring 'a' and 'b' back to
life, beause it binds 'y' to (a,b) (imagine got inlined and
scrutinised y).
+-}
-\begin{code}
occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
-> CoreAlt
-> (UsageDetails, Alt IdWithOccInfo)
@@ -1440,16 +1434,15 @@ wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs
wrapAltRHS _ _ alt_usg _ alt_rhs
= (alt_usg, alt_rhs)
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
OccEnv
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
data OccEnv
= OccEnv { occ_encl :: !OccEncl -- Enclosing context information
, occ_one_shots :: !OneShots -- Tells about linearity
@@ -1502,16 +1495,16 @@ rhsCtxt :: OccEnv -> OccEnv
rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }
argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
-argCtxt env []
+argCtxt env []
= (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])
-argCtxt env (one_shots:one_shots_s)
+argCtxt env (one_shots:one_shots_s)
= (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)
isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
-oneShotGroup :: OccEnv -> [CoreBndr]
+oneShotGroup :: OccEnv -> [CoreBndr]
-> ( OccEnv
, [CoreBndr] )
-- The result binders have one-shot-ness set that they might not have had originally.
@@ -1532,7 +1525,7 @@ oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs
go ctxt (bndr:bndrs) rev_bndrs
| isId bndr
-
+
= case ctxt of
[] -> go [] bndrs (bndr : rev_bndrs)
(one_shot : ctxt) -> go ctxt bndrs (bndr': rev_bndrs)
@@ -1544,10 +1537,7 @@ oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs
addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
= env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }
-\end{code}
-
-\begin{code}
transClosureFV :: UniqFM VarSet -> UniqFM VarSet
-- If (f,g), (g,h) are in the input, then (f,h) is in the output
-- as well as (f,g), (g,h)
@@ -1578,14 +1568,13 @@ extendFvs env s
extras :: VarSet -- env(s)
extras = foldUFM unionVarSet emptyVarSet $
intersectUFM_C (\x _ -> x) env s
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Binder swap
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Binder swap]
~~~~~~~~~~~~~~~~~~
@@ -1656,7 +1645,7 @@ When the scrutinee is a GlobalId we must take care in two ways
i) In order to *know* whether 'x' occurs free in the RHS, we need its
occurrence info. BUT, we don't gather occurrence info for
- GlobalIds. That's the reason for the (small) occ_gbl_scrut env in
+ GlobalIds. That's the reason for the (small) occ_gbl_scrut env in
OccEnv is for: it says "gather occurrence info for these".
ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
@@ -1734,8 +1723,8 @@ binder-swap in OccAnal:
It's fixed by doing the binder-swap in OccAnal because we can do the
binder-swap unconditionally and still get occurrence analysis
information right.
+-}
-\begin{code}
mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
-- Does two things: a) makes the occ_one_shots = OccVanilla
-- b) extends the GlobalScruts if possible
@@ -1758,16 +1747,15 @@ mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr
-- new binding for it, and it might have an External Name, or
-- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
-- Also we don't want any INLINE or NOINLINE pragmas!
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection[OccurAnal-types]{OccEnv}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
-- INVARIANT: never IAmDead
-- (Deadness is signalled by not being in the map at all)
@@ -1835,16 +1823,15 @@ setBinderOcc usage bndr
| otherwise = setIdOccInfo bndr occ_info
where
occ_info = lookupVarEnv usage bndr `orElse` IAmDead
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Operations over OccInfo}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
mkOneOcc env id int_cxt
| isLocalId id
@@ -1882,4 +1869,3 @@ orOccInfo (OneOcc in_lam1 _ int_cxt1)
(int_cxt1 && int_cxt2)
orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
NoOccInfo
-\end{code}
diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.hs
index bd5b718669..dc76df0e08 100644
--- a/compiler/simplCore/SAT.lhs
+++ b/compiler/simplCore/SAT.hs
@@ -1,12 +1,12 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
-%************************************************************************
+************************************************************************
Static Argument Transformation pass
-%************************************************************************
+************************************************************************
May be seen as removing invariants from loops:
Arguments of recursive functions that do not change in recursive
@@ -46,9 +46,8 @@ Geometric Mean +0.0% -0.2% -6.9%
The previous patch, to fix polymorphic floatout demand signatures, is
essential to make this work well!
+-}
-
-\begin{code}
{-# LANGUAGE CPP #-}
module SAT ( doStaticArgs ) where
@@ -72,17 +71,14 @@ import Data.List
import FastString
#include "HsVersions.h"
-\end{code}
-\begin{code}
doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
where
sat_bind_threaded_us us bind =
let (us1, us2) = splitUniqSupply us
in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))
-\end{code}
-\begin{code}
+
-- We don't bother to SAT recursive groups since it can lead
-- to massive code expansion: see Andre Santos' thesis for details.
-- This means we only apply the actual SAT to Rec groups of one element,
@@ -111,8 +107,7 @@ satBind (Rec pairs) interesting_ids = do
rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss
let (rhss', sat_info_rhss') = unzip rhss_SATed
return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
-\end{code}
-\begin{code}
+
data App = VarApp Id | TypeApp Type | CoApp Coercion
data Staticness a = Static a | NotStatic
@@ -177,8 +172,7 @@ finalizeApp (Just (v, sat_info')) id_sat_info =
Nothing -> sat_info'
Just sat_info -> mergeSATInfo sat_info sat_info'
in extendVarEnv id_sat_info v sat_info''
-\end{code}
-\begin{code}
+
satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
satTopLevelExpr expr interesting_ids = do
(expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
@@ -249,15 +243,15 @@ satExpr co@(Coercion _) _ = do
satExpr (Cast expr coercion) interesting_ids = do
(expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
return (Cast expr' coercion, sat_info_expr, expr_app)
-\end{code}
-%************************************************************************
+{-
+************************************************************************
Static Argument Transformation Monad
-%************************************************************************
+************************************************************************
+-}
-\begin{code}
type SatM result = UniqSM result
runSAT :: UniqSupply -> SatM a -> a
@@ -265,14 +259,13 @@ runSAT = initUs_
newUnique :: SatM Unique
newUnique = getUniqueM
-\end{code}
-
-%************************************************************************
+{-
+************************************************************************
Static Argument Transformation Monad
-%************************************************************************
+************************************************************************
To do the transformation, the game plan is to:
@@ -368,8 +361,8 @@ GHC.Base.until =
Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK
type argument. This is bad because it means the application sat_worker_s1aU x_a6X
is not well typed.
+-}
-\begin{code}
saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
| Just arg_staticness <- maybe_arg_staticness
@@ -436,5 +429,3 @@ saTransform binder arg_staticness rhs_binders rhs_body
isStaticValue :: Staticness App -> Bool
isStaticValue (Static (VarApp _)) = True
isStaticValue _ = False
-
-\end{code}
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.hs
index b8726d93a4..e7000409e7 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.hs
@@ -1,6 +1,6 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
\section{SetLevels}
***************************
@@ -40,8 +40,8 @@
The simplifier tries to get rid of occurrences of x, in favour of wild,
in the hope that there will only be one remaining occurrence of x, namely
the scrutinee of the case, and we can inline it.
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
module SetLevels (
setLevels,
@@ -80,15 +80,15 @@ import UniqSupply
import Util
import Outputable
import FastString
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Level numbers}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
type LevelledExpr = TaggedExpr FloatSpec
type LevelledBind = TaggedBind FloatSpec
type LevelledBndr = TaggedBndr FloatSpec
@@ -107,8 +107,8 @@ data FloatSpec
floatSpecLevel :: FloatSpec -> Level
floatSpecLevel (FloatMe l) = l
floatSpecLevel (StayPut l) = l
-\end{code}
+{-
The {\em level number} on a (type-)lambda-bound variable is the
nesting depth of the (type-)lambda which binds it. The outermost lambda
has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
@@ -162,8 +162,8 @@ One particular case is that of workers: we don't want to float the
call to the worker outside the wrapper, otherwise the worker might get
inlined into the floated expression, and an importing module won't see
the worker at all.
+-}
-\begin{code}
instance Outputable FloatSpec where
ppr (FloatMe l) = char 'F' <> ppr l
ppr (StayPut l) = ppr l
@@ -199,16 +199,15 @@ instance Outputable Level where
instance Eq Level where
(Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Main level-setting code}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
setLevels :: FloatOutSwitches
-> CoreProgram
-> UniqSupply
@@ -237,13 +236,13 @@ lvlTopBind env (Rec pairs)
(env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL bndrs
rhss' <- mapM (lvlExpr env' . freeVars) rhss
return (Rec (bndrs' `zip` rhss'), env')
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Setting expression levels}
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Floating over-saturated applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -258,13 +257,13 @@ is minimal, and the extra local thunks allocated cost money.
Arguably we could float even class-op applications if they were going to
top level -- but then they must be applied to a constant dictionary and
will almost certainly be optimised away anyway.
+-}
-\begin{code}
lvlExpr :: LevelEnv -- Context
-> CoreExprWithFVs -- Input expression
-> LvlM LevelledExpr -- Result expression
-\end{code}
+{-
The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
binder. Here's an example
@@ -279,8 +278,8 @@ don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
--- because it isn't a *maximal* free expression.
If there were another lambda in @r@'s rhs, it would get level-2 as well.
+-}
-\begin{code}
lvlExpr env (_, AnnType ty) = return (Type (substTy (le_subst env) ty))
lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
lvlExpr env (_, AnnVar v) = return (lookupVar env v)
@@ -398,8 +397,8 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
; return (con, bs', rhs') }
where
(new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
-\end{code}
+{-
Note [Floating cases]
~~~~~~~~~~~~~~~~~~~~~
Consider this:
@@ -443,8 +442,8 @@ the inner case out, at least not unless x is also evaluated at its
binding site.
That's why we apply exprOkForSpeculation to scrut' and not to scrut.
+-}
-\begin{code}
lvlMFE :: Bool -- True <=> strict context [body of case or let]
-> LevelEnv -- Level of in-scope names/tyvars
-> CoreExprWithFVs -- input expression
@@ -516,8 +515,8 @@ lvlMFE strict_ctxt env ann_expr@(fvs, _)
--
-- Also a strict contxt includes uboxed values, and they
-- can't be bound at top level
-\end{code}
+{-
Note [Unlifted MFEs]
~~~~~~~~~~~~~~~~~~~~
We don't float unlifted MFEs, which potentially loses big opportunites.
@@ -566,8 +565,8 @@ Because in doing so we share a tiny bit of computation (the switch) but
in exchange we build a thunk, which is bad. This case reduces allocation
by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
Doesn't change any other allocation at all.
+-}
-\begin{code}
annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id
-- See Note [Bottoming floats] for why we want to add
-- bottoming information right now
@@ -608,8 +607,8 @@ notWorthFloating e abs_vars
is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
is_triv _ = False
-\end{code}
+{-
Note [Floating literals]
~~~~~~~~~~~~~~~~~~~~~~~~
It's important to float Integer literals, so that they get shared,
@@ -663,15 +662,15 @@ OLD comment was:
to the condition above. We should really try this out.
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection{Bindings}
-%* *
-%************************************************************************
+* *
+************************************************************************
The binding stuff works for top level too.
+-}
-\begin{code}
lvlBind :: LevelEnv
-> CoreBindWithFVs
-> LvlM (LevelledBind, LevelEnv)
@@ -789,16 +788,15 @@ lvlFloatRhs abs_vars dest_lvl env rhs
; return (mkLams abs_vars_w_lvls rhs') }
where
(rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Deciding floatability}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
substAndLvlBndrs is_rec env lvl bndrs
= lvlBndrs subst_env lvl subst_bndrs
@@ -847,9 +845,7 @@ lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
where
lvld_bndrs = [TB bndr (StayPut new_lvl) | bndr <- bndrs]
add_lvl env v = extendVarEnv env v new_lvl
-\end{code}
-\begin{code}
-- Destination level is the max Id level of the expression
-- (We'll abstract the type variables, if any.)
destLevel :: LevelEnv -> VarSet
@@ -895,16 +891,15 @@ countFreeIds = foldVarSet add 0
add :: Var -> Int -> Int
add v n | isId v = n+1
| otherwise = n
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Free-To-Level Monad}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
type InVar = Var -- Pre cloning
type InId = Id -- Pre cloning
type OutVar = Var -- Post cloning
@@ -1028,17 +1023,12 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
close v = foldVarSet (unionVarSet . close)
(unitVarSet v)
(varTypeTyVars v)
-\end{code}
-\begin{code}
type LvlM result = UniqSM result
initLvl :: UniqSupply -> UniqSM a -> a
initLvl = initUs_
-\end{code}
-
-\begin{code}
newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId] -> UniqSM (LevelEnv, [OutId])
-- The envt is extended to bind the new bndrs to dest_lvl, but
-- the ctxt_lvl is unaffected
@@ -1109,8 +1099,8 @@ zap_demand_info :: Var -> Var
zap_demand_info v
| isId v = zapDemandIdInfo v
| otherwise = v
-\end{code}
+{-
Note [Zapping the demand info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
VERY IMPORTANT: we must zap the demand info if the thing is going to
@@ -1119,3 +1109,4 @@ binding site. Eg
f :: Int -> Int
f x = let v = 3*4 in v+x
Here v is strict; but if we float v to top level, it isn't any more.
+-}
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.hs
index 883f2ef7f9..75766e8ef2 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.hs
@@ -1,9 +1,9 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
\section[SimplCore]{Driver for simplifying @Core@ programs}
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
module SimplCore ( core2core, simplifyExpr ) where
@@ -55,15 +55,15 @@ import Control.Monad
import DynamicLoading ( loadPlugins )
import Plugins ( installCoreToDos )
#endif
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{The driver for the simplifier}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core hsc_env guts
= do { us <- mkSplitUniqSupply 's'
@@ -91,16 +91,15 @@ core2core hsc_env guts
-- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-- would mean our cached value would go out of date.
print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Generating the main optimisation pipeline
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
= core_todo
@@ -311,11 +310,9 @@ getCoreToDo dflags
maybe_rule_check (Phase 0)
]
-\end{code}
-Loading plugins
+-- Loading plugins
-\begin{code}
addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
#ifndef GHCI
addPluginPasses builtin_passes = return builtin_passes
@@ -327,15 +324,15 @@ addPluginPasses builtin_passes
where
query_plug todos (_, plug, options) = installCoreToDos plug options todos
#endif
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
The CoreToDo interpreter
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses passes guts
= foldM do_pass guts passes
@@ -395,15 +392,15 @@ doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
#endif
doCorePass pass = pprPanic "doCorePass" (ppr pass)
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Core pass combinators}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
printCore :: DynFlags -> CoreProgram -> IO ()
printCore dflags binds
= Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
@@ -467,16 +464,15 @@ observe do_pass = doPassM $ \binds -> do
dflags <- getDynFlags
_ <- liftIO $ do_pass dflags binds
return binds
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Gentle simplification
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-> CoreExpr
-> IO CoreExpr
@@ -525,16 +521,15 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently env expr = do
expr1 <- simplExpr env (occurAnalyseExpr expr)
simplExpr env (occurAnalyseExpr expr1)
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{The driver for the simplifier}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm pass guts
= do { hsc_env <- getHscEnv
@@ -700,14 +695,13 @@ dump_end_iteration dflags print_unqual iteration_no counts binds rules
pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr
, pprSimplCount counts
, ptext (sLit "---- End of simplifier counts for") <+> hdr ]
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Shorting out indirections
-%* *
-%************************************************************************
+* *
+************************************************************************
If we have this:
@@ -826,8 +820,8 @@ could be eliminated. But I don't think it's very common
and it's dangerous to do this fiddling in STG land
because we might elminate a binding that's mentioned in the
unfolding for something.
+-}
-\begin{code}
type IndEnv = IdEnv Id -- Maps local_id -> exported_id
shortOutIndirections :: CoreProgram -> CoreProgram
@@ -920,4 +914,3 @@ transferIdInfo exported_id local_id
(specInfo local_info)
-- Remember to set the function-name field of the
-- rules as we transfer them from one function to another
-\end{code}
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.hs
index d8aec03b03..a5d8551a3a 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.hs
@@ -1,9 +1,9 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
\section[SimplMonad]{The simplifier Monad}
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
module SimplEnv (
@@ -61,15 +61,15 @@ import FastString
import Util
import Data.List
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection[Simplify-types]{Type declarations}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
type InBndr = CoreBndr
type InVar = Var -- Not yet cloned
type InId = Id -- Not yet cloned
@@ -90,16 +90,15 @@ type OutBind = CoreBind
type OutExpr = CoreExpr
type OutAlt = CoreAlt
type OutArg = CoreArg
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsubsection{The @SimplEnv@ type}
-%* *
-%************************************************************************
-
+* *
+************************************************************************
+-}
-\begin{code}
data SimplEnv
= SimplEnv {
----------- Static part of the environment -----------
@@ -159,8 +158,8 @@ instance Outputable SimplSR where
-- fvs = exprFreeVars e
-- filter_env env = filterVarEnv_Directly keep env
-- keep uniq _ = uniq `elemUFM_Directly` fvs
-\end{code}
+{-
Note [SimplEnv invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~
seInScope:
@@ -224,9 +223,8 @@ seIdSubst:
map to the same target: x->x, y->x. Notably:
case y of x { ... }
That's why the "set" is actually a VarEnv Var
+-}
-
-\begin{code}
mkSimplEnv :: SimplifierMode -> SimplEnv
mkSimplEnv mode
= SimplEnv { seMode = mode
@@ -240,8 +238,8 @@ mkSimplEnv mode
init_in_scope :: InScopeSet
init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
-- See Note [WildCard binders]
-\end{code}
+{-
Note [WildCard binders]
~~~~~~~~~~~~~~~~~~~~~~~
The program to be simplified may have wild binders
@@ -259,8 +257,8 @@ thing. Generally, you want to run the simplifier to get rid of the
wild-ids before doing much else.
It's a very dark corner of GHC. Maybe it should be cleaned up.
+-}
-\begin{code}
getMode :: SimplEnv -> SimplifierMode
getMode env = seMode env
@@ -330,15 +328,13 @@ setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst
mkContEx :: SimplEnv -> InExpr -> SimplSR
mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
-\end{code}
-
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Floats}
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Simplifier floats]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -359,8 +355,8 @@ Examples
Can't happen:
NonRec x# (a /# b) -- Might fail; does not satisfy let/app
NonRec x# (f y) -- Might diverge; does not satisfy let/app
+-}
-\begin{code}
data Floats = Floats (OrdList OutBind) FloatFlag
-- See Note [Simplifier floats]
@@ -399,25 +395,25 @@ doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff})
= not (isNilOL fs) && want_to_float && can_float
where
- want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
+ want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
-- See Note [Float when cheap or expandable]
can_float = case ff of
FltLifted -> True
FltOkSpec -> isNotTopLevel lvl && isNonRec rec
FltCareful -> isNotTopLevel lvl && isNonRec rec && str
-\end{code}
+{-
Note [Float when cheap or expandable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to float a let from a let if the residual RHS is
a) cheap, such as (\x. blah)
b) expandable, such as (f b) if f is CONLIKE
-But there are
+But there are
- cheap things that are not expandable (eg \x. expensive)
- expandable things that are not cheap (eg (f b) where b is CONLIKE)
so we must take the 'or' of the two.
+-}
-\begin{code}
emptyFloats :: Floats
emptyFloats = Floats nilOL FltLifted
@@ -489,8 +485,8 @@ getFloatBinds (SimplEnv {seFloats = Floats bs _})
isEmptyFloats :: SimplEnv -> Bool
isEmptyFloats (SimplEnv {seFloats = Floats bs _})
= isNilOL bs
-\end{code}
+{-
-- mapFloats commented out: used only in a commented-out bit of Simplify,
-- concerning ticks
--
@@ -502,11 +498,11 @@ isEmptyFloats (SimplEnv {seFloats = Floats bs _})
-- app (Rec bs) = Rec (map fun bs)
-%************************************************************************
-%* *
+************************************************************************
+* *
Substitution of Vars
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Global Ids in the substitution]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -518,8 +514,8 @@ for a LocalId version of g (with the same unique though):
... case X.g_34 of { (p,q) -> ...} ... }
So we want to look up the inner X.g_34 in the substitution, where we'll
find that it has been substituted by b. (Or conceivably cloned.)
+-}
-\begin{code}
substId :: SimplEnv -> InId -> SimplSR
-- Returns DoneEx only on a non-Var expression
substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
@@ -547,19 +543,18 @@ lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
Just (DoneId v) -> v
Just _ -> pprPanic "lookupRecBndr" (ppr v)
Nothing -> refine in_scope v
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\section{Substituting an Id binder}
-%* *
-%************************************************************************
+* *
+************************************************************************
These functions are in the monad only so that they can be made strict via seq.
+-}
-\begin{code}
simplBinders, simplLamBndrs
:: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
simplBinders env bndrs = mapAccumLM simplBinder env bndrs
@@ -656,9 +651,7 @@ substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }
= extendVarEnv id_subst old_id (DoneId new_id)
| otherwise
= delVarEnv id_subst old_id
-\end{code}
-\begin{code}
------------------------------------
seqTyVar :: TyVar -> ()
seqTyVar b = b `seq` ()
@@ -671,9 +664,8 @@ seqId id = seqType (idType id) `seq`
seqIds :: [Id] -> ()
seqIds [] = ()
seqIds (id:ids) = seqId id `seq` seqIds ids
-\end{code}
-
+{-
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
We *do* transfer the arity from from the in_id of a let binding to the
@@ -719,9 +711,8 @@ cases where he really, really wanted a RULE for a recursive function
to apply in that function's own right-hand side.
See Note [Loop breaking and RULES] in OccAnal.
+-}
-
-\begin{code}
addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr)
-- Rules are added back into the bin
addBndrRules env in_id out_id
@@ -732,16 +723,15 @@ addBndrRules env in_id out_id
old_rules = idSpecialisation in_id
new_rules = CoreSubst.substSpec subst out_id old_rules
final_id = out_id `setIdSpecialisation` new_rules
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Impedence matching to type substitution
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
getTvSubst :: SimplEnv -> TvSubst
getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
= mkTvSubst in_scope tv_env
@@ -813,5 +803,3 @@ substUnfolding :: SimplEnv -> Unfolding -> Unfolding
substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst (text "subst-unfolding") env) unf
-- Do *not* short-cut in the case of an empty substitution
-- See Note [SimplEnv invariants]
-\end{code}
-
diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.hs
index ca14688583..451bf34f7c 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.hs
@@ -1,9 +1,9 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
\section[SimplMonad]{The simplifier Monad}
+-}
-\begin{code}
module SimplMonad (
-- The monad
SimplM,
@@ -31,18 +31,18 @@ import FastString
import MonadUtils
import ErrUtils
import Control.Monad ( when, liftM, ap )
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Monad plumbing}
-%* *
-%************************************************************************
+* *
+************************************************************************
For the simplifier monad, we want to {\em thread} a unique supply and a counter.
(Command-line switches move around through the explicitly-passed SimplEnv.)
+-}
-\begin{code}
newtype SimplM result
= SM { unSM :: SimplTopEnv -- Envt that does not change much
-> UniqSupply -- We thread the unique supply because
@@ -57,9 +57,7 @@ data SimplTopEnv
-- Zero means infinity!
, st_rules :: RuleBase
, st_fams :: (FamInstEnv, FamInstEnv) }
-\end{code}
-\begin{code}
initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
-> UniqSupply -- No init count; set to 0
-> Int -- Size of the bindings, used to limit
@@ -136,19 +134,18 @@ thenSmpl_ m k
traceSmpl :: String -> SDoc -> SimplM ()
traceSmpl herald doc
= do { dflags <- getDynFlags
- ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $
+ ; when (dopt Opt_D_dump_simpl_trace dflags) $ liftIO $
printInfoForUser dflags alwaysQualify $
hang (text herald) 2 doc }
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{The unique supply}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
instance MonadUnique SimplM where
getUniqueSupplyM
= SM (\_st_env us sc -> case splitUniqSupply us of
@@ -179,16 +176,15 @@ getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
newId :: FastString -> Type -> SimplM Id
newId fs ty = do uniq <- getUniqueM
return (mkSysLocal fs uniq ty)
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Counting up what we've done}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
getSimplCount :: SimplM SimplCount
getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
@@ -220,4 +216,3 @@ freeTick :: Tick -> SimplM ()
freeTick t
= SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
in sc' `seq` return ((), us, sc'))
-\end{code}
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.hs
index 1cfba43c5e..eec0f4b230 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1,9 +1,9 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
\section[SimplUtils]{The simplifier utilities}
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
module SimplUtils (
@@ -17,16 +17,16 @@ module SimplUtils (
simplEnvForGHCi, updModeForStableUnfoldings,
-- The continuation type
- SimplCont(..), DupFlag(..),
+ SimplCont(..), DupFlag(..),
isSimplified,
contIsDupable, contResultType, contInputType,
contIsTrivial, contArgs, dropArgs,
- pushSimplifiedArgs, countValArgs, countArgs,
+ pushSimplifiedArgs, countValArgs, countArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
- interestingCallContext, interestingArg,
+ interestingCallContext, interestingArg,
-- ArgInfo
- ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo,
+ ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo,
argInfoExpr, argInfoValArgs,
abstractFloats
@@ -62,14 +62,13 @@ import FastString
import Pair
import Control.Monad ( when )
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
The SimplCont type
-%* *
-%************************************************************************
+* *
+************************************************************************
A SimplCont allows the simplifier to traverse the expression in a
zipper-like fashion. The SimplCont represents the rest of the expression,
@@ -90,8 +89,8 @@ Key points:
* A SimplCont describes a context that *does not* bind
any variables. E.g. \x. [] is not a SimplCont
+-}
-\begin{code}
data SimplCont
= Stop -- An empty context, or <hole>
OutType -- Type of the <hole>
@@ -210,8 +209,8 @@ instance Outputable DupFlag where
ppr OkToDup = ptext (sLit "ok")
ppr NoDup = ptext (sLit "nodup")
ppr Simplified = ptext (sLit "simpl")
-\end{code}
+{-
Note [DupFlag invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~
In both (ApplyTo dup _ env k)
@@ -221,8 +220,8 @@ the following invariants hold
(a) if dup = OkToDup, then continuation k is also ok-to-dup
(b) if dup = OkToDup or Simplified, the subst-env is empty
(and and hence no need to re-simplify)
+-}
-\begin{code}
-------------------
mkBoringStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty BoringCtxt
@@ -297,7 +296,7 @@ countArgs _ = 0
contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
-- Summarises value args, discards type args and coercions
--- The returned continuation of the call is only used to
+-- The returned continuation of the call is only used to
-- answer questions like "are you interesting?"
contArgs cont
| lone cont = (True, [], cont)
@@ -326,9 +325,8 @@ dropArgs :: Int -> SimplCont -> SimplCont
dropArgs 0 cont = cont
dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other)
-\end{code}
-
+{-
Note [Interesting call context]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
@@ -361,9 +359,8 @@ since we can just eliminate this case instead (x is in WHNF). Similar
applies when x is bound to a lambda expression. Hence
contIsInteresting looks for case expressions with just a single
default case.
+-}
-
-\begin{code}
interestingCallContext :: SimplCont -> CallCtxt
-- See Note [Interesting call context]
interestingCallContext cont
@@ -511,14 +508,13 @@ interestingArgContext rules call_cont
interesting RuleArgCtxt = True
interesting _ = False
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
SimplifierMode
-%* *
-%************************************************************************
+* *
+************************************************************************
The SimplifierMode controls several switches; see its definition in
CoreMonad
@@ -526,8 +522,8 @@ CoreMonad
sm_inline :: Bool -- Whether inlining is enabled
sm_case_case :: Bool -- Whether case-of-case is enabled
sm_eta_expand :: Bool -- Whether eta-expansion is enabled
+-}
-\begin{code}
simplEnvForGHCi :: DynFlags -> SimplEnv
simplEnvForGHCi dflags
= mkSimplEnv $ SimplMode { sm_names = ["GHCi"]
@@ -553,8 +549,8 @@ updModeForStableUnfoldings inline_rule_act current_mode
where
phaseFromActivation (ActiveAfter n) = Phase n
phaseFromActivation _ = InitialPhase
-\end{code}
+{-
Note [Inlining in gentle mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Something is inlined if
@@ -670,8 +666,8 @@ the wrapper (initially, the worker's only call site!). But,
if the wrapper is sure to be called, the strictness analyser will
mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
continuation.
+-}
-\begin{code}
activeUnfolding :: SimplEnv -> Id -> Bool
activeUnfolding env
| not (sm_inline mode) = active_unfolding_minimal
@@ -733,15 +729,13 @@ activeRule env
| otherwise = isActive (sm_phase mode)
where
mode = getMode env
-\end{code}
-
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
preInlineUnconditionally
-%* *
-%************************************************************************
+* *
+************************************************************************
preInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -851,8 +845,8 @@ Note [Do not inline CoVars unconditionally]
Coercion variables appear inside coercions, and the RHS of a let-binding
is a term (not a coercion) so we can't necessarily inline the latter in
the former.
+-}
-\begin{code}
preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
-- Precondition: rhs satisfies the let/app invariant
-- See Note [CoreSyn let/app invariant] in CoreSyn
@@ -922,13 +916,12 @@ preInlineUnconditionally dflags env top_lvl bndr rhs
-- top level things, but then we become more leery about inlining
-- them.
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
postInlineUnconditionally
-%* *
-%************************************************************************
+* *
+************************************************************************
postInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -957,8 +950,8 @@ it's best to inline it anyway. We often get a=E; b=a from desugaring,
with both a and b marked NOINLINE. But that seems incompatible with
our new view that inlining is like a RULE, so I'm sticking to the 'active'
story for now.
+-}
-\begin{code}
postInlineUnconditionally
:: DynFlags -> SimplEnv -> TopLevelFlag
-> OutId -- The binder (an InId would be fine too)
@@ -1041,8 +1034,8 @@ postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding
where
active = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
-- See Note [pre/postInlineUnconditionally in gentle mode]
-\end{code}
+{-
Note [Top level and postInlineUnconditionally]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't do postInlineUnconditionally for top-level things (even for
@@ -1089,13 +1082,13 @@ won't inline because 'e' is too big.
c.f. Note [Stable unfoldings and preInlineUnconditionally]
-%************************************************************************
-%* *
+************************************************************************
+* *
Rebuilding a lambda
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
mkLam :: [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
-- mkLam tries three things
-- a) eta reduction, if that gives a trivial expression
@@ -1138,9 +1131,8 @@ mkLam bndrs body cont
| otherwise
= return (mkLams bndrs body)
-\end{code}
-
+{-
Note [Eta expanding lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general we *do* want to eta-expand lambdas. Consider
@@ -1191,13 +1183,13 @@ It does not make sense to transform
/\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)
because the latter is not well-kinded.
-%************************************************************************
-%* *
+************************************************************************
+* *
Eta expansion
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
-- See Note [Eta-expanding at let bindings]
tryEtaExpandRhs env bndr rhs
@@ -1226,8 +1218,8 @@ tryEtaExpandRhs env bndr rhs
old_arity = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
old_id_arity = idArity bndr
-\end{code}
+{-
Note [Eta-expanding at let bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We now eta expand at let-bindings, which is where the payoff comes.
@@ -1256,7 +1248,7 @@ Note [Do not eta-expand PAPs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to have old_arity = manifestArity rhs, which meant that we
would eta-expand even PAPs. But this gives no particular advantage,
-and can lead to a massive blow-up in code size, exhibited by Trac #9020.
+and can lead to a massive blow-up in code size, exhibited by Trac #9020.
Suppose we have a PAP
foo :: IO ()
foo = returnIO ()
@@ -1276,11 +1268,11 @@ Does it matter not eta-expanding such functions? I'm not sure. Perhaps
strictness analysis will have less to bite on?
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection{Floating lets out of big lambdas}
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Floating and type abstraction]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1356,9 +1348,8 @@ as we would normally do.
That's why the whole transformation is part of the same process that
floats let-bindings and constructor arguments out of RHSs. In particular,
it is guarded by the doFloatFromRhs call in simplLazyBind.
+-}
-
-\begin{code}
abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
abstractFloats main_tvs body_env body
= ASSERT( notNull body_floats )
@@ -1437,8 +1428,8 @@ abstractFloats main_tvs body_env body
-- where x* has an INLINE prag on it. Now, once x* is inlined,
-- the occurrences of x' will be just the occurrences originally
-- pinned on x.
-\end{code}
+{-
Note [Abstract over coercions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
@@ -1468,11 +1459,11 @@ Historical note: if you use let-bindings instead of a substitution, beware of th
-- to appear many times. (NB: mkInlineMe eliminates
-- such notes on trivial RHSs, so do it manually.)
-%************************************************************************
-%* *
+************************************************************************
+* *
prepareAlts
-%* *
-%************************************************************************
+* *
+************************************************************************
prepareAlts tries these things:
@@ -1515,8 +1506,8 @@ h y = case y of
If we inline h into f, the default case of the inlined h can't happen.
If we don't notice this, we may end up filtering out *all* the cases
of the inner case y, which give us nowhere to go!
+-}
-\begin{code}
prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-- The returned alternatives can be empty, none are possible
prepareAlts scrut case_bndr' alts
@@ -1524,18 +1515,18 @@ prepareAlts scrut case_bndr' alts
-- OutId, it has maximum information; this is important.
-- Test simpl013 is an example
= do { us <- getUniquesM
- ; let (imposs_deflt_cons, refined_deflt, alts')
+ ; let (imposs_deflt_cons, refined_deflt, alts')
= filterAlts us (varType case_bndr') imposs_cons alts
; when refined_deflt $ tick (FillInCaseDefault case_bndr')
-
+
; alts'' <- combineIdenticalAlts case_bndr' alts'
; return (imposs_deflt_cons, alts'') }
where
imposs_cons = case scrut of
Var v -> otherCons (idUnfolding v)
_ -> []
-\end{code}
+{-
Note [Combine identical alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If several alternatives are identical, merge them into
@@ -1578,8 +1569,8 @@ NB: it's important that all this is done in [InAlt], *before* we work
on the alternatives themselves, because Simpify.simplAlt may zap the
occurrence info on the binders in the alternatives, which in turn
defeats combineIdenticalAlts (see Trac #7360).
+-}
-\begin{code}
combineIdenticalAlts :: OutId -> [InAlt] -> SimplM [InAlt]
-- See Note [Combine identical alternatives]
combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
@@ -1592,14 +1583,13 @@ combineIdenticalAlts case_bndr ((_con1,bndrs1,rhs1) : con_alts)
identical_to_alt1 (_con,bndrs,rhs) = all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1
combineIdenticalAlts _ alts = return alts
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
mkCase
-%* *
-%************************************************************************
+* *
+************************************************************************
mkCase tries these things
@@ -1628,9 +1618,8 @@ mkCase tries these things
False -> False
and similar friends.
+-}
-
-\begin{code}
mkCase, mkCase1, mkCase2
:: DynFlags
-> OutExpr -> OutId
@@ -1720,8 +1709,8 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
--------------------------------------------------
mkCase2 _dflags scrut bndr alts_ty alts
= return (Case scrut bndr alts_ty alts)
-\end{code}
+{-
Note [Dead binders]
~~~~~~~~~~~~~~~~~~~~
Note that dead-ness is maintained by the simplifier, so that it is
@@ -1787,5 +1776,4 @@ without getting changed to c1=I# c2.
I don't think this is worth fixing, even if I knew how. It'll
all come out in the next pass anyway.
-
-
+-}
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.hs
index cc55529906..7611f56a4b 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.hs
@@ -1,9 +1,9 @@
-%
-% (c) The AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
\section[Simplify]{The main module of the simplifier}
+-}
-\begin{code}
{-# LANGUAGE CPP #-}
module Simplify ( simplTopBinds, simplExpr ) where
@@ -49,9 +49,8 @@ import FastString
import Pair
import Util
import ErrUtils
-\end{code}
-
+{-
The guts of the simplifier is in this module, but the driver loop for
the simplifier is in SimplCore.lhs.
@@ -205,13 +204,13 @@ we should eta expand wherever we find a (value) lambda? Then the eta
expansion at a let RHS can concentrate solely on the PAP case.
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection{Bindings}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv
simplTopBinds env0 binds0
@@ -238,19 +237,18 @@ simplTopBinds env0 binds0
simpl_bind env (NonRec b r) = simplRecOrTopPair env' TopLevel NonRecursive b b' r
where
(env', b') = addBndrRules env b (lookupRecBndr env b)
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Lazy bindings}
-%* *
-%************************************************************************
+* *
+************************************************************************
simplRecBind is used for
* recursive bindings only
+-}
-\begin{code}
simplRecBind :: SimplEnv -> TopLevelFlag
-> [(InId, InExpr)]
-> SimplM SimplEnv
@@ -272,15 +270,15 @@ simplRecBind env0 top_lvl pairs0
go env ((old_bndr, new_bndr, rhs) : pairs)
= do { env' <- simplRecOrTopPair env top_lvl Recursive old_bndr new_bndr rhs
; go env' pairs }
-\end{code}
+{-
simplOrTopPair is used for
* recursive bindings (whether top level or not)
* top-level non-recursive bindings
It assumes the binder has already been simplified, but not its IdInfo.
+-}
-\begin{code}
simplRecOrTopPair :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutBndr -> InExpr -- Binder and rhs
@@ -302,9 +300,8 @@ simplRecOrTopPair env top_lvl is_rec old_bndr new_bndr rhs
= pprTrace "SimplBind" (ppr old_bndr) thing_inside
-- trace_bind emits a trace for each top-level binding, which
-- helps to locate the tracing for inlining and rule firing
-\end{code}
-
+{-
simplLazyBind is used for
* [simplRecOrTopPair] recursive bindings (whether top level or not)
* [simplRecOrTopPair] top-level non-recursive bindings
@@ -318,8 +315,8 @@ Nota bene:
3. It does not check for pre-inline-unconditionally;
that should have been done already.
+-}
-\begin{code}
simplLazyBind :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutId -- Binder, both pre-and post simpl
@@ -368,12 +365,12 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
; return (env', rhs') }
; completeBind env' top_lvl bndr bndr1 rhs' }
-\end{code}
+{-
A specialised variant of simplNonRec used when the RHS is already simplified,
notably in knownCon. It uses case-binding where necessary.
+-}
-\begin{code}
simplNonRecX :: SimplEnv
-> InId -- Old binder
-> OutExpr -- Simplified RHS
@@ -409,8 +406,8 @@ completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
; return (addFloats env env1, rhs1) } -- Add the floats to the main env
else return (env, wrapFloats env1 rhs1) -- Wrap the floats around the RHS
; completeBind env2 NotTopLevel old_bndr new_bndr rhs2 }
-\end{code}
+{-
{- No, no, no! Do not try preInlineUnconditionally in completeNonRecX
Doing so risks exponential behaviour, because new_rhs has been simplified once already
In the cases described by the folowing commment, postInlineUnconditionally will
@@ -451,8 +448,8 @@ We also want to deal well cases like this
Here we want to make e1,e2 trivial and get
x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
That's what the 'go' loop in prepareRhs does
+-}
-\begin{code}
prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
@@ -491,9 +488,8 @@ prepareRhs top_lvl env0 _ rhs0
go _ env other
= return (False, env, other)
-\end{code}
-
+{-
Note [Float coercions]
~~~~~~~~~~~~~~~~~~~~~~
When we find the binding
@@ -542,9 +538,8 @@ But 'v' isn't in scope!
These strange casts can happen as a result of case-of-case
bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
(# p,q #) -> p+q
+-}
-
-\begin{code}
makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e
; return (env', ValArg e') }
@@ -589,8 +584,8 @@ bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
bindingOk top_lvl _ expr_ty
| isTopLevel top_lvl = not (isUnLiftedType expr_ty)
| otherwise = True
-\end{code}
+{-
Note [Cannot trivialise]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider tih
@@ -613,11 +608,11 @@ trivial):
We don't want to ANF-ise this.
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection{Completing a lazy binding}
-%* *
-%************************************************************************
+* *
+************************************************************************
completeBind
* deals only with Ids, not TyVars
@@ -637,8 +632,8 @@ It does *not* attempt to do let-to-case. Why? Because it is used for
(so let-to-case is inappropriate).
Nor does it do the atomic-argument thing
+-}
-\begin{code}
completeBind :: SimplEnv
-> TopLevelFlag -- Flag stuck into unfolding
-> InId -- Old binder
@@ -782,8 +777,8 @@ simplUnfolding env top_lvl id new_rhs unf
act = idInlineActivation id
rule_env = updMode (updModeForStableUnfoldings act) env
-- See Note [Simplifying inside stable unfoldings] in SimplUtils
-\end{code}
+{-
Note [Force bottoming field]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to force bottoming, or the new unfolding holds
@@ -845,11 +840,11 @@ After inlining f at some of its call sites the original binding may
The solution here is a bit ad hoc...
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection[Simplify-simplExpr]{The main function: simplExpr}
-%* *
-%************************************************************************
+* *
+************************************************************************
The reason for this OutExprStuff stuff is that we want to float *after*
simplifying a RHS, not before. If we do so naively we get quadratic
@@ -887,9 +882,8 @@ whole round if we float first. This can cascade. Consider
Only in this second round can the \y be applied, and it
might do the same again.
+-}
-
-\begin{code}
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
where
@@ -1149,16 +1143,15 @@ simplTick env tickish expr cont
-- So we've moved a constant amount of work out of the scc to expose
-- the case. We only do this when the continuation is interesting: in
-- for now, it has to be another Case (maybe generalise this later).
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{The main rebuilder}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- At this point the substitution in the SimplEnv should be irrelevant
-- only the in-scope set and floats should matter
@@ -1178,16 +1171,15 @@ rebuild env expr cont
| otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
; rebuild env (App expr arg') cont }
TickIt t cont -> rebuild env (mkTick t expr) cont
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Lambdas}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
-> SimplM (SimplEnv, OutExpr)
simplCast env body co0 cont0
@@ -1253,14 +1245,13 @@ simplCast env body co0 cont0
arg_se' = arg_se `setInScope` env
add_coerce co _ cont = CoerceIt co cont
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Lambdas}
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Zap unfolding when beta-reducing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1274,8 +1265,8 @@ stupid situation of
let b{Unf=Just x} = y
in ...b...
Here it'd be far better to drop the unfolding and use the actual RHS.
+-}
-\begin{code}
simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
@@ -1355,15 +1346,15 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
; let (env2, bndr2) = addBndrRules env1 bndr bndr1
; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
; simplLam env3 bndrs body cont }
-\end{code}
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
Variables
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
simplVar :: SimplEnv -> InVar -> SimplM OutExpr
-- Look up an InVar in the environment
simplVar env var
@@ -1501,8 +1492,8 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules })
-- Rules don't match
; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules
} }
-\end{code}
+{-
Note [RULES apply to simplified arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very desirable to try RULES once the arguments have been simplified, because
@@ -1550,13 +1541,13 @@ discard the entire application and replace it with (error "foo"). Getting
all this at once is TOO HARD!
-%************************************************************************
-%* *
+************************************************************************
+* *
Rewrite rules
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
tryRules :: SimplEnv -> [CoreRule]
-> Id -> [OutExpr] -> SimplCont
-> SimplM (Maybe (CoreExpr, SimplCont))
@@ -1618,8 +1609,8 @@ tryRules env rules fn args call_cont
log_rule dflags flag hdr details
= liftIO . dumpSDoc dflags alwaysQualify flag "" $
sep [text hdr, nest 4 details]
-\end{code}
+{-
Note [Optimising tagToEnum#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have an enumeration data type:
@@ -1654,11 +1645,11 @@ is recursive, and hence a loop breaker:
So it's up to the programmer: rules can cause divergence
-%************************************************************************
-%* *
+************************************************************************
+* *
Rebuilding a case expression
-%* *
-%************************************************************************
+* *
+************************************************************************
Note [Case elimination]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -1754,7 +1745,7 @@ let-bound to (error "good").
Nevertheless, the paper "A semantics for imprecise exceptions" allows
this transformation. If you want to fix the evaluation order, use
'pseq'. See Trac #8900 for an example where the loss of this
-transformation bit us in practice.
+transformation bit us in practice.
See also Note [Empty case alternatives] in CoreSyn.
@@ -1828,8 +1819,8 @@ Why don't we drop the case? Because it's strict in v. It's technically
wrong to drop even unnecessary evaluations, and in practice they
may be a result of 'seq' so we *definitely* don't want to drop those.
I don't really know how to improve this situation.
+-}
-\begin{code}
---------------------------------------------------------
-- Eliminate the case if possible
@@ -1957,8 +1948,8 @@ reallyRebuildCase env scrut case_bndr alts cont
-- (which in any case is only build in simplAlts)
-- The case binder *not* scope over the whole returned case-expression
; rebuild env' case_expr nodup_cont }
-\end{code}
+{-
simplCaseBinder checks whether the scrutinee is a variable, v. If so,
try to eliminate uses of v in the RHSs in favour of case_bndr; that
way, there's a chance that v will now only be used once, and hence
@@ -2039,8 +2030,8 @@ taking advantage of the `seq`.
At one point I did transformation in LiberateCase, but it's more
robust here. (Otherwise, there's a danger that we'll simply drop the
'seq' altogether, before LiberateCase gets to see it.)
+-}
-\begin{code}
simplAlts :: SimplEnv
-> OutExpr
-> InId -- Case binder
@@ -2183,8 +2174,8 @@ zapBndrOccInfo :: Bool -> Id -> Id
zapBndrOccInfo keep_occ_info pat_id
| keep_occ_info = pat_id
| otherwise = zapIdOccInfo pat_id
-\end{code}
+{-
Note [Add unfolding for scrutinee]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general it's unlikely that a variable scrutinee will appear
@@ -2220,11 +2211,11 @@ So instead we add the unfolding x -> Just a, and x -> Nothing in the
respective RHSs.
-%************************************************************************
-%* *
+************************************************************************
+* *
\subsection{Known constructor}
-%* *
-%************************************************************************
+* *
+************************************************************************
We are a bit careful with occurrence info. Here's an example
@@ -2238,8 +2229,8 @@ and then
f (h v)
All this should happen in one sweep.
+-}
-\begin{code}
knownCon :: SimplEnv
-> OutExpr -- The scrutinee
-> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)
@@ -2304,16 +2295,15 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
missingAlt env case_bndr _ cont
= WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
return (env, mkImpossibleExpr (contResultType cont))
-\end{code}
-
-%************************************************************************
-%* *
+{-
+************************************************************************
+* *
\subsection{Duplicating continuations}
-%* *
-%************************************************************************
+* *
+************************************************************************
+-}
-\begin{code}
prepareCaseCont :: SimplEnv
-> [InAlt] -> SimplCont
-> SimplM (SimplEnv,
@@ -2346,8 +2336,8 @@ prepareCaseCont env alts cont
| otherwise = not (all is_bot_alt alts)
is_bot_alt (_,_,rhs) = exprIsBottom rhs
-\end{code}
+{-
Note [Bottom alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~
When we have
@@ -2358,8 +2348,8 @@ will disappear immediately. This is more direct than creating
join points and inlining them away; and in some cases we would
not even create the join points (see Note [Single-alternative case])
and we would keep the case-of-case which is silly. See Trac #4930.
+-}
-\begin{code}
mkDupableCont :: SimplEnv -> SimplCont
-> SimplM (SimplEnv, SimplCont, SimplCont)
@@ -2512,8 +2502,8 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do
; env' <- addPolyBind NotTopLevel env (NonRec (join_bndr `setIdArity` join_arity) join_rhs)
; return (env', (con, bndrs', join_call)) }
-- See Note [Duplicated env]
-\end{code}
+{-
Note [Fusing case continuations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important to fuse two successive case continuations when the
@@ -2846,3 +2836,4 @@ whether to use a real join point or just duplicate the continuation:
Hence: check whether the case binder's type is unlifted, because then
the outer case is *not* a seq.
+-}