1{- 2(c) The AQUA Project, Glasgow University, 1993-1998 3 4\section[CoreMonad]{The core pipeline monad} 5-} 6 7{-# LANGUAGE CPP #-} 8{-# LANGUAGE DeriveFunctor #-} 9 10module CoreMonad ( 11 -- * Configuration of the core-to-core passes 12 CoreToDo(..), runWhen, runMaybe, 13 SimplMode(..), 14 FloatOutSwitches(..), 15 pprPassDetails, 16 17 -- * Plugins 18 CorePluginPass, bindsOnlyPass, 19 20 -- * Counting 21 SimplCount, doSimplTick, doFreeSimplTick, simplCountN, 22 pprSimplCount, plusSimplCount, zeroSimplCount, 23 isZeroSimplCount, hasDetailedCounts, Tick(..), 24 25 -- * The monad 26 CoreM, runCoreM, 27 28 -- ** Reading from the monad 29 getHscEnv, getRuleBase, getModule, 30 getDynFlags, getOrigNameCache, getPackageFamInstEnv, 31 getVisibleOrphanMods, getUniqMask, 32 getPrintUnqualified, getSrcSpanM, 33 34 -- ** Writing to the monad 35 addSimplCount, 36 37 -- ** Lifting into the monad 38 liftIO, liftIOWithCount, 39 40 -- ** Dealing with annotations 41 getAnnotations, getFirstAnnotations, 42 43 -- ** Screen output 44 putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, 45 fatalErrorMsg, fatalErrorMsgS, 46 debugTraceMsg, debugTraceMsgS, 47 dumpIfSet_dyn 48 ) where 49 50import GhcPrelude hiding ( read ) 51 52import CoreSyn 53import HscTypes 54import Module 55import DynFlags 56import BasicTypes ( CompilerPhase(..) ) 57import Annotations 58 59import IOEnv hiding ( liftIO, failM, failWithM ) 60import qualified IOEnv ( liftIO ) 61import Var 62import Outputable 63import FastString 64import qualified ErrUtils as Err 65import ErrUtils( Severity(..) ) 66import UniqSupply 67import UniqFM ( UniqFM, mapUFM, filterUFM ) 68import MonadUtils 69import NameCache 70import SrcLoc 71import Data.List (intersperse, groupBy, sortBy) 72import Data.Ord 73import Data.Dynamic 74import Data.IORef 75import Data.Map (Map) 76import qualified Data.Map as Map 77import qualified Data.Map.Strict as MapStrict 78import Data.Word 79import Control.Monad 80import Control.Applicative ( Alternative(..) ) 81import Panic (throwGhcException, GhcException(..)) 82 83{- 84************************************************************************ 85* * 86 The CoreToDo type and related types 87 Abstraction of core-to-core passes to run. 88* * 89************************************************************************ 90-} 91 92data CoreToDo -- These are diff core-to-core passes, 93 -- which may be invoked in any order, 94 -- as many times as you like. 95 96 = CoreDoSimplify -- The core-to-core simplifier. 97 Int -- Max iterations 98 SimplMode 99 | CoreDoPluginPass String CorePluginPass 100 | CoreDoFloatInwards 101 | CoreDoFloatOutwards FloatOutSwitches 102 | CoreLiberateCase 103 | CoreDoPrintCore 104 | CoreDoStaticArgs 105 | CoreDoCallArity 106 | CoreDoExitify 107 | CoreDoStrictness 108 | CoreDoWorkerWrapper 109 | CoreDoSpecialising 110 | CoreDoSpecConstr 111 | CoreCSE 112 | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules 113 -- matching this string 114 | CoreDoNothing -- Useful when building up 115 | CoreDoPasses [CoreToDo] -- lists of these things 116 117 | CoreDesugar -- Right after desugaring, no simple optimisation yet! 118 | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces 119 -- Core output, and hence useful to pass to endPass 120 121 | CoreTidy 122 | CorePrep 123 | CoreOccurAnal 124 125instance Outputable CoreToDo where 126 ppr (CoreDoSimplify _ _) = text "Simplifier" 127 ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s 128 ppr CoreDoFloatInwards = text "Float inwards" 129 ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) 130 ppr CoreLiberateCase = text "Liberate case" 131 ppr CoreDoStaticArgs = text "Static argument" 132 ppr CoreDoCallArity = text "Called arity analysis" 133 ppr CoreDoExitify = text "Exitification transformation" 134 ppr CoreDoStrictness = text "Demand analysis" 135 ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" 136 ppr CoreDoSpecialising = text "Specialise" 137 ppr CoreDoSpecConstr = text "SpecConstr" 138 ppr CoreCSE = text "Common sub-expression" 139 ppr CoreDesugar = text "Desugar (before optimization)" 140 ppr CoreDesugarOpt = text "Desugar (after optimization)" 141 ppr CoreTidy = text "Tidy Core" 142 ppr CorePrep = text "CorePrep" 143 ppr CoreOccurAnal = text "Occurrence analysis" 144 ppr CoreDoPrintCore = text "Print core" 145 ppr (CoreDoRuleCheck {}) = text "Rule check" 146 ppr CoreDoNothing = text "CoreDoNothing" 147 ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes 148 149pprPassDetails :: CoreToDo -> SDoc 150pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n 151 , ppr md ] 152pprPassDetails _ = Outputable.empty 153 154data SimplMode -- See comments in SimplMonad 155 = SimplMode 156 { sm_names :: [String] -- Name(s) of the phase 157 , sm_phase :: CompilerPhase 158 , sm_dflags :: DynFlags -- Just for convenient non-monadic 159 -- access; we don't override these 160 , sm_rules :: Bool -- Whether RULES are enabled 161 , sm_inline :: Bool -- Whether inlining is enabled 162 , sm_case_case :: Bool -- Whether case-of-case is enabled 163 , sm_eta_expand :: Bool -- Whether eta-expansion is enabled 164 } 165 166instance Outputable SimplMode where 167 ppr (SimplMode { sm_phase = p, sm_names = ss 168 , sm_rules = r, sm_inline = i 169 , sm_eta_expand = eta, sm_case_case = cc }) 170 = text "SimplMode" <+> braces ( 171 sep [ text "Phase =" <+> ppr p <+> 172 brackets (text (concat $ intersperse "," ss)) <> comma 173 , pp_flag i (sLit "inline") <> comma 174 , pp_flag r (sLit "rules") <> comma 175 , pp_flag eta (sLit "eta-expand") <> comma 176 , pp_flag cc (sLit "case-of-case") ]) 177 where 178 pp_flag f s = ppUnless f (text "no") <+> ptext s 179 180data FloatOutSwitches = FloatOutSwitches { 181 floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if 182 -- doing so will abstract over n or fewer 183 -- value variables 184 -- Nothing <=> float all lambdas to top level, 185 -- regardless of how many free variables 186 -- Just 0 is the vanilla case: float a lambda 187 -- iff it has no free vars 188 189 floatOutConstants :: Bool, -- ^ True <=> float constants to top level, 190 -- even if they do not escape a lambda 191 floatOutOverSatApps :: Bool, 192 -- ^ True <=> float out over-saturated applications 193 -- based on arity information. 194 -- See Note [Floating over-saturated applications] 195 -- in SetLevels 196 floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. 197 } 198instance Outputable FloatOutSwitches where 199 ppr = pprFloatOutSwitches 200 201pprFloatOutSwitches :: FloatOutSwitches -> SDoc 202pprFloatOutSwitches sw 203 = text "FOS" <+> (braces $ 204 sep $ punctuate comma $ 205 [ text "Lam =" <+> ppr (floatOutLambdas sw) 206 , text "Consts =" <+> ppr (floatOutConstants sw) 207 , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) 208 209-- The core-to-core pass ordering is derived from the DynFlags: 210runWhen :: Bool -> CoreToDo -> CoreToDo 211runWhen True do_this = do_this 212runWhen False _ = CoreDoNothing 213 214runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo 215runMaybe (Just x) f = f x 216runMaybe Nothing _ = CoreDoNothing 217 218{- 219 220************************************************************************ 221* * 222 Types for Plugins 223* * 224************************************************************************ 225-} 226 227-- | A description of the plugin pass itself 228type CorePluginPass = ModGuts -> CoreM ModGuts 229 230bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts 231bindsOnlyPass pass guts 232 = do { binds' <- pass (mg_binds guts) 233 ; return (guts { mg_binds = binds' }) } 234 235{- 236************************************************************************ 237* * 238 Counting and logging 239* * 240************************************************************************ 241-} 242 243getVerboseSimplStats :: (Bool -> SDoc) -> SDoc 244getVerboseSimplStats = getPprDebug -- For now, anyway 245 246zeroSimplCount :: DynFlags -> SimplCount 247isZeroSimplCount :: SimplCount -> Bool 248hasDetailedCounts :: SimplCount -> Bool 249pprSimplCount :: SimplCount -> SDoc 250doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount 251doFreeSimplTick :: Tick -> SimplCount -> SimplCount 252plusSimplCount :: SimplCount -> SimplCount -> SimplCount 253 254data SimplCount 255 = VerySimplCount !Int -- Used when don't want detailed stats 256 257 | SimplCount { 258 ticks :: !Int, -- Total ticks 259 details :: !TickCounts, -- How many of each type 260 261 n_log :: !Int, -- N 262 log1 :: [Tick], -- Last N events; <= opt_HistorySize, 263 -- most recent first 264 log2 :: [Tick] -- Last opt_HistorySize events before that 265 -- Having log1, log2 lets us accumulate the 266 -- recent history reasonably efficiently 267 } 268 269type TickCounts = Map Tick Int 270 271simplCountN :: SimplCount -> Int 272simplCountN (VerySimplCount n) = n 273simplCountN (SimplCount { ticks = n }) = n 274 275zeroSimplCount dflags 276 -- This is where we decide whether to do 277 -- the VerySimpl version or the full-stats version 278 | dopt Opt_D_dump_simpl_stats dflags 279 = SimplCount {ticks = 0, details = Map.empty, 280 n_log = 0, log1 = [], log2 = []} 281 | otherwise 282 = VerySimplCount 0 283 284isZeroSimplCount (VerySimplCount n) = n==0 285isZeroSimplCount (SimplCount { ticks = n }) = n==0 286 287hasDetailedCounts (VerySimplCount {}) = False 288hasDetailedCounts (SimplCount {}) = True 289 290doFreeSimplTick tick sc@SimplCount { details = dts } 291 = sc { details = dts `addTick` tick } 292doFreeSimplTick _ sc = sc 293 294doSimplTick dflags tick 295 sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) 296 | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } 297 | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } 298 where 299 sc1 = sc { ticks = tks+1, details = dts `addTick` tick } 300 301doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) 302 303 304addTick :: TickCounts -> Tick -> TickCounts 305addTick fm tick = MapStrict.insertWith (+) tick 1 fm 306 307plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) 308 sc2@(SimplCount { ticks = tks2, details = dts2 }) 309 = log_base { ticks = tks1 + tks2 310 , details = MapStrict.unionWith (+) dts1 dts2 } 311 where 312 -- A hackish way of getting recent log info 313 log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 314 | null (log2 sc2) = sc2 { log2 = log1 sc1 } 315 | otherwise = sc2 316 317plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) 318plusSimplCount lhs rhs = 319 throwGhcException . PprProgramError "plusSimplCount" $ vcat 320 [ text "lhs" 321 , pprSimplCount lhs 322 , text "rhs" 323 , pprSimplCount rhs 324 ] 325 -- We use one or the other consistently 326 327pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n 328pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) 329 = vcat [text "Total ticks: " <+> int tks, 330 blankLine, 331 pprTickCounts dts, 332 getVerboseSimplStats $ \dbg -> if dbg 333 then 334 vcat [blankLine, 335 text "Log (most recent first)", 336 nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] 337 else Outputable.empty 338 ] 339 340{- Note [Which transformations are innocuous] 341~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 342At one point (Jun 18) I wondered if some transformations (ticks) 343might be "innocuous", in the sense that they do not unlock a later 344transformation that does not occur in the same pass. If so, we could 345refrain from bumping the overall tick-count for such innocuous 346transformations, and perhaps terminate the simplifier one pass 347earlier. 348 349BUt alas I found that virtually nothing was innocuous! This Note 350just records what I learned, in case anyone wants to try again. 351 352These transformations are not innocuous: 353 354*** NB: I think these ones could be made innocuous 355 EtaExpansion 356 LetFloatFromLet 357 358LetFloatFromLet 359 x = K (let z = e2 in Just z) 360 prepareRhs transforms to 361 x2 = let z=e2 in Just z 362 x = K xs 363 And now more let-floating can happen in the 364 next pass, on x2 365 366PreInlineUnconditionally 367 Example in spectral/cichelli/Auxil 368 hinsert = ...let lo = e in 369 let j = ...lo... in 370 case x of 371 False -> () 372 True -> case lo of I# lo' -> 373 ...j... 374 When we PreInlineUnconditionally j, lo's occ-info changes to once, 375 so it can be PreInlineUnconditionally in the next pass, and a 376 cascade of further things can happen. 377 378PostInlineUnconditionally 379 let x = e in 380 let y = ...x.. in 381 case .. of { A -> ...x...y... 382 B -> ...x...y... } 383 Current postinlineUnconditinaly will inline y, and then x; sigh. 384 385 But PostInlineUnconditionally might also unlock subsequent 386 transformations for the same reason as PreInlineUnconditionally, 387 so it's probably not innocuous anyway. 388 389KnownBranch, BetaReduction: 390 May drop chunks of code, and thereby enable PreInlineUnconditionally 391 for some let-binding which now occurs once 392 393EtaExpansion: 394 Example in imaginary/digits-of-e1 395 fail = \void. e where e :: IO () 396 --> etaExpandRhs 397 fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) 398 --> Next iteration of simplify 399 fail1 = \void. \s. (e |> g) s 400 fail = fail1 |> Void#->sym g 401 And now inline 'fail' 402 403CaseMerge: 404 case x of y { 405 DEFAULT -> case y of z { pi -> ei } 406 alts2 } 407 ---> CaseMerge 408 case x of { pi -> let z = y in ei 409 ; alts2 } 410 The "let z=y" case-binder-swap gets dealt with in the next pass 411-} 412 413pprTickCounts :: Map Tick Int -> SDoc 414pprTickCounts counts 415 = vcat (map pprTickGroup groups) 416 where 417 groups :: [[(Tick,Int)]] -- Each group shares a comon tag 418 -- toList returns common tags adjacent 419 groups = groupBy same_tag (Map.toList counts) 420 same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 421 422pprTickGroup :: [(Tick, Int)] -> SDoc 423pprTickGroup group@((tick1,_):_) 424 = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) 425 2 (vcat [ int n <+> pprTickCts tick 426 -- flip as we want largest first 427 | (tick,n) <- sortBy (flip (comparing snd)) group]) 428pprTickGroup [] = panic "pprTickGroup" 429 430data Tick -- See Note [Which transformations are innocuous] 431 = PreInlineUnconditionally Id 432 | PostInlineUnconditionally Id 433 434 | UnfoldingDone Id 435 | RuleFired FastString -- Rule name 436 437 | LetFloatFromLet 438 | EtaExpansion Id -- LHS binder 439 | EtaReduction Id -- Binder on outer lambda 440 | BetaReduction Id -- Lambda binder 441 442 443 | CaseOfCase Id -- Bndr on *inner* case 444 | KnownBranch Id -- Case binder 445 | CaseMerge Id -- Binder on outer case 446 | AltMerge Id -- Case binder 447 | CaseElim Id -- Case binder 448 | CaseIdentity Id -- Case binder 449 | FillInCaseDefault Id -- Case binder 450 451 | SimplifierDone -- Ticked at each iteration of the simplifier 452 453instance Outputable Tick where 454 ppr tick = text (tickString tick) <+> pprTickCts tick 455 456instance Eq Tick where 457 a == b = case a `cmpTick` b of 458 EQ -> True 459 _ -> False 460 461instance Ord Tick where 462 compare = cmpTick 463 464tickToTag :: Tick -> Int 465tickToTag (PreInlineUnconditionally _) = 0 466tickToTag (PostInlineUnconditionally _) = 1 467tickToTag (UnfoldingDone _) = 2 468tickToTag (RuleFired _) = 3 469tickToTag LetFloatFromLet = 4 470tickToTag (EtaExpansion _) = 5 471tickToTag (EtaReduction _) = 6 472tickToTag (BetaReduction _) = 7 473tickToTag (CaseOfCase _) = 8 474tickToTag (KnownBranch _) = 9 475tickToTag (CaseMerge _) = 10 476tickToTag (CaseElim _) = 11 477tickToTag (CaseIdentity _) = 12 478tickToTag (FillInCaseDefault _) = 13 479tickToTag SimplifierDone = 16 480tickToTag (AltMerge _) = 17 481 482tickString :: Tick -> String 483tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" 484tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" 485tickString (UnfoldingDone _) = "UnfoldingDone" 486tickString (RuleFired _) = "RuleFired" 487tickString LetFloatFromLet = "LetFloatFromLet" 488tickString (EtaExpansion _) = "EtaExpansion" 489tickString (EtaReduction _) = "EtaReduction" 490tickString (BetaReduction _) = "BetaReduction" 491tickString (CaseOfCase _) = "CaseOfCase" 492tickString (KnownBranch _) = "KnownBranch" 493tickString (CaseMerge _) = "CaseMerge" 494tickString (AltMerge _) = "AltMerge" 495tickString (CaseElim _) = "CaseElim" 496tickString (CaseIdentity _) = "CaseIdentity" 497tickString (FillInCaseDefault _) = "FillInCaseDefault" 498tickString SimplifierDone = "SimplifierDone" 499 500pprTickCts :: Tick -> SDoc 501pprTickCts (PreInlineUnconditionally v) = ppr v 502pprTickCts (PostInlineUnconditionally v)= ppr v 503pprTickCts (UnfoldingDone v) = ppr v 504pprTickCts (RuleFired v) = ppr v 505pprTickCts LetFloatFromLet = Outputable.empty 506pprTickCts (EtaExpansion v) = ppr v 507pprTickCts (EtaReduction v) = ppr v 508pprTickCts (BetaReduction v) = ppr v 509pprTickCts (CaseOfCase v) = ppr v 510pprTickCts (KnownBranch v) = ppr v 511pprTickCts (CaseMerge v) = ppr v 512pprTickCts (AltMerge v) = ppr v 513pprTickCts (CaseElim v) = ppr v 514pprTickCts (CaseIdentity v) = ppr v 515pprTickCts (FillInCaseDefault v) = ppr v 516pprTickCts _ = Outputable.empty 517 518cmpTick :: Tick -> Tick -> Ordering 519cmpTick a b = case (tickToTag a `compare` tickToTag b) of 520 GT -> GT 521 EQ -> cmpEqTick a b 522 LT -> LT 523 524cmpEqTick :: Tick -> Tick -> Ordering 525cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b 526cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b 527cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b 528cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b 529cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b 530cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b 531cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b 532cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b 533cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b 534cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b 535cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b 536cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b 537cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b 538cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b 539cmpEqTick _ _ = EQ 540 541{- 542************************************************************************ 543* * 544 Monad and carried data structure definitions 545* * 546************************************************************************ 547-} 548 549data CoreReader = CoreReader { 550 cr_hsc_env :: HscEnv, 551 cr_rule_base :: RuleBase, 552 cr_module :: Module, 553 cr_print_unqual :: PrintUnqualified, 554 cr_loc :: SrcSpan, -- Use this for log/error messages so they 555 -- are at least tagged with the right source file 556 cr_visible_orphan_mods :: !ModuleSet, 557 cr_uniq_mask :: !Char -- Mask for creating unique values 558} 559 560-- Note: CoreWriter used to be defined with data, rather than newtype. If it 561-- is defined that way again, the cw_simpl_count field, at least, must be 562-- strict to avoid a space leak (#7702). 563newtype CoreWriter = CoreWriter { 564 cw_simpl_count :: SimplCount 565} 566 567emptyWriter :: DynFlags -> CoreWriter 568emptyWriter dflags = CoreWriter { 569 cw_simpl_count = zeroSimplCount dflags 570 } 571 572plusWriter :: CoreWriter -> CoreWriter -> CoreWriter 573plusWriter w1 w2 = CoreWriter { 574 cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) 575 } 576 577type CoreIOEnv = IOEnv CoreReader 578 579-- | The monad used by Core-to-Core passes to register simplification statistics. 580-- Also used to have common state (in the form of UniqueSupply) for generating Uniques. 581newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } 582 deriving (Functor) 583 584instance Monad CoreM where 585 mx >>= f = CoreM $ do 586 (x, w1) <- unCoreM mx 587 (y, w2) <- unCoreM (f x) 588 let w = w1 `plusWriter` w2 589 return $ seq w (y, w) 590 -- forcing w before building the tuple avoids a space leak 591 -- (#7702) 592 593instance Applicative CoreM where 594 pure x = CoreM $ nop x 595 (<*>) = ap 596 m *> k = m >>= \_ -> k 597 598instance Alternative CoreM where 599 empty = CoreM Control.Applicative.empty 600 m <|> n = CoreM (unCoreM m <|> unCoreM n) 601 602instance MonadPlus CoreM 603 604instance MonadUnique CoreM where 605 getUniqueSupplyM = do 606 mask <- read cr_uniq_mask 607 liftIO $! mkSplitUniqSupply mask 608 609 getUniqueM = do 610 mask <- read cr_uniq_mask 611 liftIO $! uniqFromMask mask 612 613runCoreM :: HscEnv 614 -> RuleBase 615 -> Char -- ^ Mask 616 -> Module 617 -> ModuleSet 618 -> PrintUnqualified 619 -> SrcSpan 620 -> CoreM a 621 -> IO (a, SimplCount) 622runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m 623 = liftM extract $ runIOEnv reader $ unCoreM m 624 where 625 reader = CoreReader { 626 cr_hsc_env = hsc_env, 627 cr_rule_base = rule_base, 628 cr_module = mod, 629 cr_visible_orphan_mods = orph_imps, 630 cr_print_unqual = print_unqual, 631 cr_loc = loc, 632 cr_uniq_mask = mask 633 } 634 635 extract :: (a, CoreWriter) -> (a, SimplCount) 636 extract (value, writer) = (value, cw_simpl_count writer) 637 638{- 639************************************************************************ 640* * 641 Core combinators, not exported 642* * 643************************************************************************ 644-} 645 646nop :: a -> CoreIOEnv (a, CoreWriter) 647nop x = do 648 r <- getEnv 649 return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) 650 651read :: (CoreReader -> a) -> CoreM a 652read f = CoreM $ getEnv >>= (\r -> nop (f r)) 653 654write :: CoreWriter -> CoreM () 655write w = CoreM $ return ((), w) 656 657-- \subsection{Lifting IO into the monad} 658 659-- | Lift an 'IOEnv' operation into 'CoreM' 660liftIOEnv :: CoreIOEnv a -> CoreM a 661liftIOEnv mx = CoreM (mx >>= (\x -> nop x)) 662 663instance MonadIO CoreM where 664 liftIO = liftIOEnv . IOEnv.liftIO 665 666-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' 667liftIOWithCount :: IO (SimplCount, a) -> CoreM a 668liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) 669 670{- 671************************************************************************ 672* * 673 Reader, writer and state accessors 674* * 675************************************************************************ 676-} 677 678getHscEnv :: CoreM HscEnv 679getHscEnv = read cr_hsc_env 680 681getRuleBase :: CoreM RuleBase 682getRuleBase = read cr_rule_base 683 684getVisibleOrphanMods :: CoreM ModuleSet 685getVisibleOrphanMods = read cr_visible_orphan_mods 686 687getPrintUnqualified :: CoreM PrintUnqualified 688getPrintUnqualified = read cr_print_unqual 689 690getSrcSpanM :: CoreM SrcSpan 691getSrcSpanM = read cr_loc 692 693addSimplCount :: SimplCount -> CoreM () 694addSimplCount count = write (CoreWriter { cw_simpl_count = count }) 695 696getUniqMask :: CoreM Char 697getUniqMask = read cr_uniq_mask 698 699-- Convenience accessors for useful fields of HscEnv 700 701instance HasDynFlags CoreM where 702 getDynFlags = fmap hsc_dflags getHscEnv 703 704instance HasModule CoreM where 705 getModule = read cr_module 706 707-- | The original name cache is the current mapping from 'Module' and 708-- 'OccName' to a compiler-wide unique 'Name' 709getOrigNameCache :: CoreM OrigNameCache 710getOrigNameCache = do 711 nameCacheRef <- fmap hsc_NC getHscEnv 712 liftIO $ fmap nsNames $ readIORef nameCacheRef 713 714getPackageFamInstEnv :: CoreM PackageFamInstEnv 715getPackageFamInstEnv = do 716 hsc_env <- getHscEnv 717 eps <- liftIO $ hscEPS hsc_env 718 return $ eps_fam_inst_env eps 719 720{- 721************************************************************************ 722* * 723 Dealing with annotations 724* * 725************************************************************************ 726-} 727 728-- | Get all annotations of a given type. This happens lazily, that is 729-- no deserialization will take place until the [a] is actually demanded and 730-- the [a] can also be empty (the UniqFM is not filtered). 731-- 732-- This should be done once at the start of a Core-to-Core pass that uses 733-- annotations. 734-- 735-- See Note [Annotations] 736getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) 737getAnnotations deserialize guts = do 738 hsc_env <- getHscEnv 739 ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) 740 return (deserializeAnns deserialize ann_env) 741 742-- | Get at most one annotation of a given type per Unique. 743getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) 744getFirstAnnotations deserialize guts 745 = liftM (mapUFM head . filterUFM (not . null)) 746 $ getAnnotations deserialize guts 747 748{- 749Note [Annotations] 750~~~~~~~~~~~~~~~~~~ 751A Core-to-Core pass that wants to make use of annotations calls 752getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with 753annotations of a specific type. This produces all annotations from interface 754files read so far. However, annotations from interface files read during the 755pass will not be visible until getAnnotations is called again. This is similar 756to how rules work and probably isn't too bad. 757 758The current implementation could be optimised a bit: when looking up 759annotations for a thing from the HomePackageTable, we could search directly in 760the module where the thing is defined rather than building one UniqFM which 761contains all annotations we know of. This would work because annotations can 762only be given to things defined in the same module. However, since we would 763only want to deserialise every annotation once, we would have to build a cache 764for every module in the HTP. In the end, it's probably not worth it as long as 765we aren't using annotations heavily. 766 767************************************************************************ 768* * 769 Direct screen output 770* * 771************************************************************************ 772-} 773 774msg :: Severity -> WarnReason -> SDoc -> CoreM () 775msg sev reason doc 776 = do { dflags <- getDynFlags 777 ; loc <- getSrcSpanM 778 ; unqual <- getPrintUnqualified 779 ; let sty = case sev of 780 SevError -> err_sty 781 SevWarning -> err_sty 782 SevDump -> dump_sty 783 _ -> user_sty 784 err_sty = mkErrStyle dflags unqual 785 user_sty = mkUserStyle dflags unqual AllTheWay 786 dump_sty = mkDumpStyle dflags unqual 787 ; liftIO $ putLogMsg dflags reason sev loc sty doc } 788 789-- | Output a String message to the screen 790putMsgS :: String -> CoreM () 791putMsgS = putMsg . text 792 793-- | Output a message to the screen 794putMsg :: SDoc -> CoreM () 795putMsg = msg SevInfo NoReason 796 797-- | Output an error to the screen. Does not cause the compiler to die. 798errorMsgS :: String -> CoreM () 799errorMsgS = errorMsg . text 800 801-- | Output an error to the screen. Does not cause the compiler to die. 802errorMsg :: SDoc -> CoreM () 803errorMsg = msg SevError NoReason 804 805warnMsg :: WarnReason -> SDoc -> CoreM () 806warnMsg = msg SevWarning 807 808-- | Output a fatal error to the screen. Does not cause the compiler to die. 809fatalErrorMsgS :: String -> CoreM () 810fatalErrorMsgS = fatalErrorMsg . text 811 812-- | Output a fatal error to the screen. Does not cause the compiler to die. 813fatalErrorMsg :: SDoc -> CoreM () 814fatalErrorMsg = msg SevFatal NoReason 815 816-- | Output a string debugging message at verbosity level of @-v@ or higher 817debugTraceMsgS :: String -> CoreM () 818debugTraceMsgS = debugTraceMsg . text 819 820-- | Outputs a debugging message at verbosity level of @-v@ or higher 821debugTraceMsg :: SDoc -> CoreM () 822debugTraceMsg = msg SevDump NoReason 823 824-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher 825dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () 826dumpIfSet_dyn flag str doc 827 = do { dflags <- getDynFlags 828 ; unqual <- getPrintUnqualified 829 ; when (dopt flag dflags) $ liftIO $ 830 Err.dumpSDoc dflags unqual flag str doc } 831