diff options
Diffstat (limited to 'compiler/simplCore/CoreMonad.hs')
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 147 |
1 files changed, 89 insertions, 58 deletions
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index c689eea346..0c5d8d9fd2 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -9,12 +9,12 @@ module CoreMonad ( -- * Configuration of the core-to-core passes CoreToDo(..), runWhen, runMaybe, - SimplifierMode(..), + SimplMode(..), FloatOutSwitches(..), pprPassDetails, -- * Plugins - PluginPass, bindsOnlyPass, + CorePluginPass, bindsOnlyPass, -- * Counting SimplCount, doSimplTick, doFreeSimplTick, simplCountN, @@ -47,14 +47,11 @@ module CoreMonad ( putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn, - - -- * Getting 'Name's - thNameToGhcName + dumpIfSet_dyn ) where -import Name( Name ) -import TcRnMonad ( initTcForLookup ) +import GhcPrelude hiding ( read ) + import CoreSyn import HscTypes import Module @@ -64,13 +61,11 @@ import Annotations import IOEnv hiding ( liftIO, failM, failWithM ) import qualified IOEnv ( liftIO ) -import TcEnv ( lookupGlobal ) import Var import Outputable import FastString import qualified ErrUtils as Err import ErrUtils( Severity(..) ) -import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils @@ -87,11 +82,6 @@ import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) -import Prelude hiding ( read ) - -import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) -import qualified Language.Haskell.TH as TH - {- ************************************************************************ * * @@ -107,14 +97,15 @@ data CoreToDo -- These are diff core-to-core passes, = CoreDoSimplify -- The core-to-core simplifier. Int -- Max iterations - SimplifierMode - | CoreDoPluginPass String PluginPass + SimplMode + | CoreDoPluginPass String CorePluginPass | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoCallArity + | CoreDoExitify | CoreDoStrictness | CoreDoWorkerWrapper | CoreDoSpecialising @@ -122,7 +113,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules -- matching this string - | CoreDoVectorisation | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things @@ -142,12 +132,12 @@ instance Outputable CoreToDo where ppr CoreLiberateCase = text "Liberate case" ppr CoreDoStaticArgs = text "Static argument" ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" ppr CoreDoStrictness = text "Demand analysis" ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" ppr CoreDoSpecialising = text "Specialise" ppr CoreDoSpecConstr = text "SpecConstr" ppr CoreCSE = text "Common sub-expression" - ppr CoreDoVectorisation = text "Vectorisation" ppr CoreDesugar = text "Desugar (before optimization)" ppr CoreDesugarOpt = text "Desugar (after optimization)" ppr CoreTidy = text "Tidy Core" @@ -163,17 +153,19 @@ pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n , ppr md ] pprPassDetails _ = Outputable.empty -data SimplifierMode -- See comments in SimplMonad +data SimplMode -- See comments in SimplMonad = SimplMode { sm_names :: [String] -- Name(s) of the phase , sm_phase :: CompilerPhase + , sm_dflags :: DynFlags -- Just for convenient non-monadic + -- access; we don't override these , sm_rules :: Bool -- Whether RULES are enabled , 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 } -instance Outputable SimplifierMode where +instance Outputable SimplMode where ppr (SimplMode { sm_phase = p, sm_names = ss , sm_rules = r, sm_inline = i , sm_eta_expand = eta, sm_case_case = cc }) @@ -235,7 +227,7 @@ runMaybe Nothing _ = CoreDoNothing -} -- | A description of the plugin pass itself -type PluginPass = ModGuts -> CoreM ModGuts +type CorePluginPass = ModGuts -> CoreM ModGuts bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts bindsOnlyPass pass guts @@ -251,7 +243,7 @@ bindsOnlyPass pass guts -} getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = sdocWithPprDebug -- For now, anyway +getVerboseSimplStats = getPprDebug -- For now, anyway zeroSimplCount :: DynFlags -> SimplCount isZeroSimplCount :: SimplCount -> Bool @@ -341,6 +333,79 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) else Outputable.empty ] +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +BUt alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void#->sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + pprTickCounts :: Map Tick Int -> SDoc pprTickCounts counts = vcat (map pprTickGroup groups) @@ -358,7 +423,7 @@ pprTickGroup group@((tick1,_):_) | (tick,n) <- sortBy (flip (comparing snd)) group]) pprTickGroup [] = panic "pprTickGroup" -data Tick +data Tick -- See Note [Which transformations are innocuous] = PreInlineUnconditionally Id | PostInlineUnconditionally Id @@ -379,7 +444,6 @@ data Tick | CaseIdentity Id -- Case binder | FillInCaseDefault Id -- Case binder - | BottomFound | SimplifierDone -- Ticked at each iteration of the simplifier instance Outputable Tick where @@ -408,7 +472,6 @@ tickToTag (CaseMerge _) = 10 tickToTag (CaseElim _) = 11 tickToTag (CaseIdentity _) = 12 tickToTag (FillInCaseDefault _) = 13 -tickToTag BottomFound = 14 tickToTag SimplifierDone = 16 tickToTag (AltMerge _) = 17 @@ -428,7 +491,6 @@ tickString (AltMerge _) = "AltMerge" tickString (CaseElim _) = "CaseElim" tickString (CaseIdentity _) = "CaseIdentity" tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString BottomFound = "BottomFound" tickString SimplifierDone = "SimplifierDone" pprTickCts :: Tick -> SDoc @@ -780,34 +842,3 @@ dumpIfSet_dyn flag str doc ; unqual <- getPrintUnqualified ; when (dopt flag dflags) $ liftIO $ Err.dumpSDoc dflags unqual flag str doc } - -{- -************************************************************************ -* * - Finding TyThings -* * -************************************************************************ --} - -instance MonadThings CoreM where - lookupThing name = do { hsc_env <- getHscEnv - ; liftIO $ lookupGlobal hsc_env name } - -{- -************************************************************************ -* * - Template Haskell interoperability -* * -************************************************************************ --} - --- | Attempt to convert a Template Haskell name to one that GHC can --- understand. Original TH names such as those you get when you use --- the @'foo@ syntax will be translated to their equivalent GHC name --- exactly. Qualified or unqualified TH names will be dynamically bound --- to names in the module being compiled, if possible. Exact TH names --- will be bound to the name they represent, exactly. -thNameToGhcName :: TH.Name -> CoreM (Maybe Name) -thNameToGhcName th_name = do - hsc_env <- getHscEnv - liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name) |