diff options
author | Austin Seipp <austin@well-typed.com> | 2014-12-03 12:45:25 -0600 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2014-12-03 13:52:27 -0600 |
commit | 6ecd27eae6f3a6f3ec3e1a6a66cad09b4eb332be (patch) | |
tree | 7df2409f0660ca6b6fe2282d34fdc1b05dba4a68 | |
parent | b9b1fab36a3df98bf3796df3090e4d5d8d592f7e (diff) | |
download | haskell-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. +-} |